Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-26 02:11:53 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into bugfix/version-spec-resilience

Browse Source
This commit is contained in:
Keagan McClelland
2020-02-27 21:05:08 -07:00
committed by GitHub
parent ab04f6151a 0a74f88171
commit 5544988d0d
7 changed files with 28 additions and 85 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
config/settings.yml
View File

@@ -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"

32
src/Application.hs
View File

@@ -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

15
src/Foundation.hs
View File

@@ -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

11
src/Handler/Version.hs
View File

@@ -8,6 +8,7 @@ import Startlude
import Control.Monad.Trans.Maybe
import Data.Char
import qualified Data.HashMap.Strict as HM
import Data.String.Interpolate.IsString
import qualified Data.Text as T
import Network.HTTP.Types
@@ -49,9 +50,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|]
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

7
src/Lib/Types/Semver.hs
View File

@@ -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
------------------------------------------------------------------------------------------------------------------------

23
src/Model.hs
View File

@@ -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
|]

9
src/Settings.hs
View File

@@ -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 { .. }