diff --git a/config/settings.yml b/config/settings.yml index 19ab8f1..4f00f02 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -28,16 +28,4 @@ ip-from-header: "_env:YESOD_IP_FROM_HEADER:false" # NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:YESOD_PGPASS:'123'") # See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings -database: - database: "_env:YESOD_SQLITE_DATABASE:start9_agent.sqlite3" - poolsize: "_env:YESOD_SQLITE_POOLSIZE:10" - -ap-password: "_env:AP_PASSWORD:at_first_I_was_afraid" -copyright: Insert copyright statement here - -registry-host: "_env:REGISTRY_HOST:registry.start9labs.com" -registry-port: "_env:REGISTRY_PORT:443" -agent-dir: "_env:AGENT_DIR:/root/agent" -app-mgr-version-spec: "_env:APP_MGR_VERSION_SPEC:=0.0.0" - -#analytics: UA-YOURCODE +app-compatibility-path: "_env:APP_COMPATIBILITY_CONFIG:/etc/start9/registry/compatibility.json" \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index de9a8f5..f95ba9c 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -23,16 +23,14 @@ module Application , getAppSettings -- * for GHCI , handler - , db ) where import Startlude -import Control.Monad.Logger (liftLoc, runLoggingT) +import Control.Monad.Logger (liftLoc) +import Data.Aeson import Data.Default import Data.IORef -import Database.Persist.Sql -import Database.Persist.Sqlite (createSqlitePool, runSqlPool, sqlDatabase, sqlPoolSize) import Language.Haskell.TH.Syntax (qLocation) import Network.Wai import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, @@ -48,7 +46,6 @@ import System.Log.FastLogger (defaultBufSize, newStdou import Yesod.Core import Yesod.Core.Types hiding (Logger) import Yesod.Default.Config2 -import Yesod.Persist.Core -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! @@ -57,7 +54,6 @@ import Handler.Apps import Handler.Icons import Handler.Version import Lib.Ssl -import Model import Settings import System.Posix.Process @@ -79,30 +75,22 @@ makeFoundation appSettings = do appWebServerThreadId <- newIORef Nothing + appCompatibilityMap <- decode . toS <$> readFile (appCompatibilityPath appSettings) >>= \case + Nothing -> panic "invalid compatibility config" + Just x -> pure x + -- We need a log function to create a connection pool. We need a connection -- pool to create our foundation. And we need our foundation to get a -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool = AgentCtx {..} + let mkFoundation = AgentCtx {..} -- The AgentCtx {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html - tempFoundation = mkFoundation $ panic "connPool forced in tempFoundation" - logFunc = messageLoggerSource tempFoundation appLogger - - -- Create the database connection pool - pool <- flip runLoggingT logFunc $ createSqlitePool - (sqlDatabase $ appDatabaseConf appSettings) - (sqlPoolSize $ appDatabaseConf appSettings) - -- Perform database migration using our application's logging settings. - runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc - - -- TODO :: compute and seed the Tor address into the db, possibly grabbing it from settings - -- seedTorAddress appSettings -- Return the foundation - return $ mkFoundation pool + return $ mkFoundation -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. @@ -229,7 +217,3 @@ shutdownApp _ = return () -- | Run a handler handler :: Handler a -> IO a handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h - --- | Run DB queries -db :: ReaderT SqlBackend Handler a -> IO a -db = handler . runDB diff --git a/src/Foundation.hs b/src/Foundation.hs index 96726de..8709129 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -9,14 +9,15 @@ module Foundation where import Startlude import Control.Monad.Logger (LogSource) +import qualified Data.HashMap.Strict as HM import Data.IORef import Database.Persist.Sql import Lib.Registry import Yesod.Core import Yesod.Core.Types (Logger) import qualified Yesod.Core.Unsafe as Unsafe -import Yesod.Persist.Core +import Lib.Types.Semver import Settings -- | The foundation datatype for your application. This can be a good place to @@ -27,9 +28,9 @@ import Settings data AgentCtx = AgentCtx { appSettings :: AppSettings - , appConnPool :: ConnectionPool -- ^ Database connection pool. , appLogger :: Logger , appWebServerThreadId :: IORef (Maybe ThreadId) + , appCompatibilityMap :: HM.HashMap AppVersion AppVersion } setWebProcessThreadId :: ThreadId -> AgentCtx -> IO () @@ -84,16 +85,6 @@ instance Yesod AgentCtx where makeLogger :: AgentCtx -> IO Logger makeLogger = return . appLogger --- How to run database actions. -instance YesodPersist AgentCtx where - type YesodPersistBackend AgentCtx = SqlBackend - runDB :: SqlPersistT Handler a -> Handler a - runDB action = runSqlPool action . appConnPool =<< getYesod - -instance YesodPersistRunner AgentCtx where - getDBRunner :: Handler (DBRunner AgentCtx, Handler ()) - getDBRunner = defaultGetDBRunner appConnPool - unsafeHandler :: AgentCtx -> Handler a -> IO a unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index 53ff70b..6cdae66 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -7,6 +7,7 @@ module Handler.Version where import Startlude import Control.Monad.Trans.Maybe +import qualified Data.HashMap.Strict as HM import Data.String.Interpolate.IsString import Network.HTTP.Types import Yesod.Core @@ -44,9 +45,9 @@ getVersionWSpec rootDir ext = do pure $ liftA2 AppVersionRes av (pure Nothing) meshCompanionCompatibility :: AppVersion -> Handler AppVersion -meshCompanionCompatibility (AppVersion (0,1,0,_)) = pure $ AppVersion (1,0,0,0) -meshCompanionCompatibility (AppVersion (0,1,1,_)) = pure $ AppVersion (1,0,0,0) -meshCompanionCompatibility (AppVersion (0,1,2,_)) = pure $ AppVersion (1,1,0,0) -meshCompanionCompatibility other = do - $logError [i|MESH DEPLOYMENT "#{other}" HAS NO COMPATIBILITY ENTRY! FIX IMMEDIATELY|] - sendResponseStatus status500 ("Internal Server Error" :: Text) +meshCompanionCompatibility av = getsYesod appCompatibilityMap >>= \hm -> do + case HM.lookup av hm of + Nothing -> do + $logError [i|MESH DEPLOYMENT "#{av}" HAS NO COMPATIBILITY ENTRY! FIX IMMEDIATELY|] + sendResponseStatus status500 ("Internal Server Error" :: Text) + Just x -> pure x diff --git a/src/Lib/Types/Semver.hs b/src/Lib/Types/Semver.hs index d68d729..c59c970 100644 --- a/src/Lib/Types/Semver.hs +++ b/src/Lib/Types/Semver.hs @@ -19,7 +19,7 @@ import Yesod.Core ------------------------------------------------------------------------------------------------------------------------ newtype AppVersion = AppVersion - { unAppVersion :: (Word16, Word16, Word16, Word16) } deriving (Eq, Ord) + { unAppVersion :: (Word16, Word16, Word16, Word16) } deriving (Eq, Ord, Hashable) instance Read AppVersion where readsPrec _ s = case traverse (readMaybe . toS) $ splitOn "+" <=< splitOn "." $ (toS s) of @@ -53,6 +53,11 @@ instance ToTypedContent AppVersion where instance ToContent AppVersion where toContent = toContent . toJSON +instance FromJSONKey AppVersion where + fromJSONKey = FromJSONKeyTextParser $ \t -> case readMaybe (toS t) of + Nothing -> fail "invalid app version" + Just x -> pure x + ------------------------------------------------------------------------------------------------------------------------ -- Semver AppVersionSpecification ------------------------------------------------------------------------------------------------------------------------ diff --git a/src/Model.hs b/src/Model.hs deleted file mode 100644 index c624306..0000000 --- a/src/Model.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -module Model where - -import Database.Persist.TH - -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| --- AuthorizedKey --- createdAt UTCTime --- updatedAt UTCTime --- name Text --- pubKey CompressedKey --- root Bool --- UniquePubKey pubKey --- deriving Eq --- deriving Show -|] diff --git a/src/Settings.hs b/src/Settings.hs index 98cef44..0729683 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -13,7 +13,6 @@ import qualified Control.Exception as Exception import Data.Aeson import Data.FileEmbed (embedFile) import Data.Yaml (decodeEither') -import Database.Persist.Sqlite (SqliteConf (..)) import Network.Wai.Handler.Warp (HostPreference) import Yesod.Default.Config2 (applyEnvValue, configSettingsYml) @@ -21,10 +20,7 @@ import Yesod.Default.Config2 (applyEnvValue, configSettingsYml) -- loaded from various sources: defaults, environment variables, config files, -- theoretically even a database. data AppSettings = AppSettings - { appDatabaseConf :: SqliteConf - -- ^ Configuration settings for accessing the database. - - , appHost :: HostPreference + { appHost :: HostPreference -- ^ Host/interface the server should bind to. , appPort :: Word16 -- ^ Port to listen on @@ -36,16 +32,17 @@ data AppSettings = AppSettings -- ^ Use detailed request logging system , appShouldLogAll :: Bool -- ^ Should all log messages be displayed? + , appCompatibilityPath :: FilePath } instance FromJSON AppSettings where parseJSON = withObject "AppSettings" $ \o -> do - appDatabaseConf <- o .: "database" appHost <- fromString <$> o .: "host" appPort <- o .: "port" appIpFromHeader <- o .: "ip-from-header" appDetailedRequestLogging <- o .:? "detailed-logging" .!= True appShouldLogAll <- o .:? "should-log-all" .!= False + appCompatibilityPath <- o .: "app-compatibility-path" return AppSettings { .. }