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

autorenews certificates

Browse Source
This commit is contained in:
Keagan McClelland
2020-08-03 15:09:50 -06:00
parent abdb452a11
commit f385d23210
8 changed files with 223 additions and 148 deletions
Download Patch File Download Diff File Expand all files Collapse all files

60
brittany.yaml Normal file
View File

@@ -0,0 +1,60 @@
conf_debug:
dconf_roundtrip_exactprint_only: false
dconf_dump_bridoc_simpl_par: false
dconf_dump_ast_unknown: false
dconf_dump_bridoc_simpl_floating: false
dconf_dump_config: false
dconf_dump_bridoc_raw: false
dconf_dump_bridoc_final: false
dconf_dump_bridoc_simpl_alt: false
dconf_dump_bridoc_simpl_indent: false
dconf_dump_annotations: false
dconf_dump_bridoc_simpl_columns: false
dconf_dump_ast_full: false
conf_forward:
options_ghc:
- -XNoImplicitPrelude
- -XBlockArguments
- -XFlexibleContexts
- -XFlexibleInstances
- -XGeneralizedNewtypeDeriving
- -XLambdaCase
- -XMultiWayIf
- -XNamedFieldPuns
- -XNumericUnderscores
- -XOverloadedStrings
- -XQuasiQuotes
- -XTemplateHaskell
- -XTypeApplications
conf_errorHandling:
econf_ExactPrintFallback: ExactPrintFallbackModeInline
econf_Werror: false
econf_omit_output_valid_check: false
econf_produceOutputOnErrors: false
conf_preprocessor:
ppconf_CPPMode: CPPModeWarn
ppconf_hackAroundIncludes: false
conf_obfuscate: false
conf_roundtrip_exactprint_only: false
conf_version: 1
conf_layout:
lconfig_reformatModulePreamble: true
lconfig_altChooser:
tag: AltChooserBoundedSearch
contents: 3
lconfig_allowSingleLineExportList: false
lconfig_importColumn: 50
lconfig_hangingTypeSignature: true
lconfig_importAsColumn: 50
lconfig_alignmentLimit: 30
lconfig_allowHangingQuasiQuotes: true
lconfig_indentListSpecial: true
lconfig_indentAmount: 4
lconfig_alignmentBreakOnMultiline: true
lconfig_experimentalSemicolonNewlines: false
lconfig_cols: 120
lconfig_indentPolicy: IndentPolicyFree
lconfig_indentWhereSpecial: false
lconfig_columnAlignMode:
tag: ColumnAlignModeMajority
contents: 0.7

1
package.yaml
View File

@@ -23,6 +23,7 @@ dependencies:
- dns - dns
- either - either
- errors - errors
- extra
- file-embed - file-embed
- fast-logger >=2.2 && <2.5 - fast-logger >=2.2 && <2.5
- filepath - filepath

44
src/Application.hs
View File

@@ -56,19 +56,20 @@ import Handler.Icons
import Handler.Version import Handler.Version
import Lib.Ssl import Lib.Ssl
import Settings import Settings
import Model
import System.Posix.Process import System.Posix.Process
import System.Time.Extra
import Model
-- This line actually creates our YesodDispatch instance. It is the second half -- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
-- comments there for more details. -- comments there for more details.
mkYesodDispatch "AgentCtx" resourcesAgentCtx mkYesodDispatch "RegistryCtx" resourcesRegistryCtx
-- | This function allocates resources (such as a database connection pool), -- | This function allocates resources (such as a database connection pool),
-- performs initialization and returns a foundation datatype value. This is also -- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database -- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
makeFoundation :: AppSettings -> IO AgentCtx makeFoundation :: AppSettings -> IO RegistryCtx
makeFoundation appSettings = do makeFoundation appSettings = do
-- Some basic initializations: HTTP connection manager, logger, and static -- Some basic initializations: HTTP connection manager, logger, and static
-- subsite. -- subsite.
@@ -85,8 +86,8 @@ makeFoundation appSettings = do
-- logging function. To get out of this loop, we initially create a -- logging function. To get out of this loop, we initially create a
-- temporary foundation without a real connection pool, get a log function -- temporary foundation without a real connection pool, get a log function
-- from there, and then create the real foundation. -- from there, and then create the real foundation.
let mkFoundation appConnPool = AgentCtx {..} let mkFoundation appConnPool = RegistryCtx {..}
-- The AgentCtx {..} syntax is an example of record wild cards. For more -- The RegistryCtx {..} syntax is an example of record wild cards. For more
-- information, see: -- information, see:
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
tempFoundation = mkFoundation $ panic "connPool forced in tempFoundation" tempFoundation = mkFoundation $ panic "connPool forced in tempFoundation"
@@ -105,7 +106,7 @@ makeFoundation appSettings = do
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares. -- applying some additional middlewares.
makeApplication :: AgentCtx -> IO Application makeApplication :: RegistryCtx -> IO Application
makeApplication foundation = do makeApplication foundation = do
logWare <- makeLogWare foundation logWare <- makeLogWare foundation
let authWare = makeAuthWare foundation let authWare = makeAuthWare foundation
@@ -117,10 +118,10 @@ makeApplication foundation = do
-- TODO: create a middle ware which will attempt to verify an ecdsa signed transaction against one of the public keys -- TODO: create a middle ware which will attempt to verify an ecdsa signed transaction against one of the public keys
-- in the validDevices table. -- in the validDevices table.
-- makeCheckSigWare :: AgentCtx -> IO Middleware -- makeCheckSigWare :: RegistryCtx -> IO Middleware
-- makeCheckSigWare = _ -- makeCheckSigWare = _
makeLogWare :: AgentCtx -> IO Middleware makeLogWare :: RegistryCtx -> IO Middleware
makeLogWare foundation = makeLogWare foundation =
mkRequestLogger def mkRequestLogger def
{ outputFormat = { outputFormat =
@@ -134,14 +135,14 @@ makeLogWare foundation =
} }
-- TODO : what kind of auth is needed here -- TODO : what kind of auth is needed here
makeAuthWare :: AgentCtx -> Middleware makeAuthWare :: RegistryCtx -> Middleware
makeAuthWare _ app req res = next makeAuthWare _ app req res = next
where where
next :: IO ResponseReceived next :: IO ResponseReceived
next = app req res next = app req res
-- | Warp settings for the given foundation value. -- | Warp settings for the given foundation value.
warpSettings :: AgentCtx -> Settings warpSettings :: RegistryCtx -> Settings
warpSettings foundation = warpSettings foundation =
setPort (fromIntegral . appPort $ appSettings foundation) setPort (fromIntegral . appPort $ appSettings foundation)
$ setHost (appHost $ appSettings foundation) $ setHost (appHost $ appSettings foundation)
@@ -169,10 +170,17 @@ appMain = do
-- allow environment variables to override -- allow environment variables to override
useEnv useEnv
void . forkIO $ forever $ do
shouldRenew <- doesSslNeedRenew (sslCertLocation settings)
when shouldRenew $ do
putStrLn @Text "Renewing SSL Certs."
renewSslCerts (sslCertLocation settings)
sleep 86_400
-- Generate the foundation from the settings -- Generate the foundation from the settings
makeFoundation settings >>= startApp makeFoundation settings >>= startApp
startApp :: AgentCtx -> IO () startApp :: RegistryCtx -> IO ()
startApp foundation = do startApp foundation = do
-- set up ssl certificates -- set up ssl certificates
putStrLn @Text "Setting up SSL" putStrLn @Text "Setting up SSL"
@@ -180,7 +188,7 @@ startApp foundation = do
putStrLn @Text "SSL Setup Complete" putStrLn @Text "SSL Setup Complete"
startWeb foundation startWeb foundation
startWeb :: AgentCtx -> IO () startWeb :: RegistryCtx -> IO ()
startWeb foundation = do startWeb foundation = do
app <- makeApplication foundation app <- makeApplication foundation
let AppSettings{..} = appSettings foundation let AppSettings{..} = appSettings foundation
@@ -199,25 +207,25 @@ shutdownAll threadIds = do
exitImmediately ExitSuccess exitImmediately ExitSuccess
-- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process -- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process
shutdownWeb :: AgentCtx -> IO () shutdownWeb :: RegistryCtx -> IO ()
shutdownWeb AgentCtx{..} = do shutdownWeb RegistryCtx{..} = do
mThreadId <- readIORef appWebServerThreadId mThreadId <- readIORef appWebServerThreadId
for_ mThreadId $ \tid -> do for_ mThreadId $ \tid -> do
killThread tid killThread tid
writeIORef appWebServerThreadId Nothing writeIORef appWebServerThreadId Nothing
-------------------------------------------------------------- --------------------------------------------------------------
-- Functions for DevelMain.hs (a way to run the AgentCtx from GHCi) -- Functions for DevelMain.hs (a way to run the RegistryCtx from GHCi)
-------------------------------------------------------------- --------------------------------------------------------------
getApplicationRepl :: IO (Int, AgentCtx, Application) getApplicationRepl :: IO (Int, RegistryCtx, Application)
getApplicationRepl = do getApplicationRepl = do
foundation <- getAppSettings >>= makeFoundation foundation <- getAppSettings >>= makeFoundation
wsettings <- getDevSettings $ warpSettings foundation wsettings <- getDevSettings $ warpSettings foundation
app1 <- makeApplication foundation app1 <- makeApplication foundation
return (getPort wsettings, foundation, app1) return (getPort wsettings, foundation, app1)
shutdownApp :: AgentCtx -> IO () shutdownApp :: RegistryCtx -> IO ()
shutdownApp _ = return () shutdownApp _ = return ()
--------------------------------------------- ---------------------------------------------

47
src/Foundation.hs
View File

@@ -8,14 +8,14 @@ module Foundation where
import Startlude import Startlude
import Control.Monad.Logger (LogSource) import Control.Monad.Logger ( LogSource )
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import Data.IORef import Data.IORef
import Database.Persist.Sql import Database.Persist.Sql
import Lib.Registry import Lib.Registry
import Yesod.Core import Yesod.Core
import Yesod.Core.Types (Logger) import Yesod.Core.Types ( Logger )
import qualified Yesod.Core.Unsafe as Unsafe import qualified Yesod.Core.Unsafe as Unsafe
import Lib.Types.Semver import Lib.Types.Semver
import Settings import Settings
@@ -27,7 +27,7 @@ import Yesod.Persist.Core
-- access to the data present here. -- access to the data present here.
data AgentCtx = AgentCtx data RegistryCtx = RegistryCtx
{ appSettings :: AppSettings { appSettings :: AppSettings
, appLogger :: Logger , appLogger :: Logger
, appWebServerThreadId :: IORef (Maybe ThreadId) , appWebServerThreadId :: IORef (Maybe ThreadId)
@@ -35,7 +35,7 @@ data AgentCtx = AgentCtx
, appConnPool :: ConnectionPool , appConnPool :: ConnectionPool
} }
setWebProcessThreadId :: ThreadId -> AgentCtx -> IO () setWebProcessThreadId :: ThreadId -> RegistryCtx -> IO ()
setWebProcessThreadId tid a = writeIORef (appWebServerThreadId a) . Just $ tid setWebProcessThreadId tid a = writeIORef (appWebServerThreadId a) . Just $ tid
-- This is where we define all of the routes in our application. For a full -- This is where we define all of the routes in our application. For a full
@@ -49,16 +49,16 @@ setWebProcessThreadId tid a = writeIORef (appWebServerThreadId a) . Just $ tid
-- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules -- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules
-- --
-- This function also generates the following type synonyms: -- This function also generates the following type synonyms:
-- type Handler = HandlerT AgentCtx IO -- type Handler = HandlerT RegistryCtx IO
mkYesodData "AgentCtx" $(parseRoutesFile "config/routes") mkYesodData "RegistryCtx" $(parseRoutesFile "config/routes")
-- Please see the documentation for the Yesod typeclass. There are a number -- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here. -- of settings which can be configured by overriding methods here.
instance Yesod AgentCtx where instance Yesod RegistryCtx where
-- Store session data on the client in encrypted cookies, -- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes -- default session idle timeout is 120 minutes
makeSessionBackend :: AgentCtx -> IO (Maybe SessionBackend) makeSessionBackend :: RegistryCtx -> IO (Maybe SessionBackend)
makeSessionBackend _ = pure Nothing makeSessionBackend _ = pure Nothing
-- Yesod Middleware allows you to run code before and after each handler function. -- Yesod Middleware allows you to run code before and after each handler function.
@@ -73,32 +73,25 @@ instance Yesod AgentCtx where
-- What messages should be logged. The following includes all messages when -- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production. -- in development, and warnings and errors in production.
shouldLogIO :: AgentCtx -> LogSource -> LogLevel -> IO Bool shouldLogIO :: RegistryCtx -> LogSource -> LogLevel -> IO Bool
shouldLogIO app _source level = shouldLogIO app _source level =
return return $ appShouldLogAll (appSettings app) || level == LevelInfo || level == LevelWarn || level == LevelError
$ appShouldLogAll (appSettings app)
|| level
== LevelInfo
|| level
== LevelWarn
|| level
== LevelError
makeLogger :: AgentCtx -> IO Logger makeLogger :: RegistryCtx -> IO Logger
makeLogger = return . appLogger makeLogger = return . appLogger
-- How to run database actions. -- How to run database actions.
instance YesodPersist AgentCtx where instance YesodPersist RegistryCtx where
type YesodPersistBackend AgentCtx = SqlBackend type YesodPersistBackend RegistryCtx = SqlBackend
runDB :: SqlPersistT Handler a -> Handler a runDB :: SqlPersistT Handler a -> Handler a
runDB action = runSqlPool action . appConnPool =<< getYesod runDB action = runSqlPool action . appConnPool =<< getYesod
instance YesodPersistRunner AgentCtx where instance YesodPersistRunner RegistryCtx where
getDBRunner :: Handler (DBRunner AgentCtx, Handler ()) getDBRunner :: Handler (DBRunner RegistryCtx, Handler ())
getDBRunner = defaultGetDBRunner appConnPool getDBRunner = defaultGetDBRunner appConnPool
unsafeHandler :: AgentCtx -> Handler a -> IO a unsafeHandler :: RegistryCtx -> Handler a -> IO a
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
-- Note: Some functionality previously present in the scaffolding has been -- Note: Some functionality previously present in the scaffolding has been
@@ -109,5 +102,5 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
appLogFunc :: AgentCtx -> LogFunc appLogFunc :: RegistryCtx -> LogFunc
appLogFunc = appLogger >>= flip messageLoggerSource appLogFunc = appLogger >>= flip messageLoggerSource

66
src/Handler/Apps.hs
View File

@@ -11,12 +11,12 @@ import Startlude
import Control.Monad.Logger import Control.Monad.Logger
import Data.Aeson import Data.Aeson
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
import Data.Char import Data.Char
import Data.Conduit import Data.Conduit
import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Binary as CB
import qualified Data.Text as T import qualified Data.Text as T
import qualified GHC.Show (Show (..)) import qualified GHC.Show ( Show(..) )
import Network.HTTP.Types import Network.HTTP.Types
import System.Directory import System.Directory
import Yesod.Core import Yesod.Core
@@ -28,11 +28,15 @@ import Lib.Semver
import Lib.Types.Semver import Lib.Types.Semver
import Lib.Types.FileSystem import Lib.Types.FileSystem
import Lib.Error import Lib.Error
import System.FilePath ((<.>), (</>)) import System.FilePath ( (<.>)
import System.Posix.Files (fileSize, getFileStatus) , (</>)
)
import System.Posix.Files ( fileSize
, getFileStatus
)
import Settings import Settings
import Database.Queries import Database.Queries
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import Database.Persist import Database.Persist
pureLog :: Show a => a -> Handler a pureLog :: Show a => a -> Handler a
@@ -43,12 +47,12 @@ logRet = (>>= liftA2 (*>) ($logInfo . decodeUtf8 . BS.toStrict . encode) pure)
data FileExtension = FileExtension FilePath (Maybe String) data FileExtension = FileExtension FilePath (Maybe String)
instance Show FileExtension where instance Show FileExtension where
show (FileExtension f Nothing) = f show (FileExtension f Nothing ) = f
show (FileExtension f (Just e)) = f <.> e show (FileExtension f (Just e)) = f <.> e
getAppsManifestR :: Handler TypedContent getAppsManifestR :: Handler TypedContent
getAppsManifestR = do getAppsManifestR = do
appResourceDir <- (</> "apps" </> "apps.yaml") . resourcesDir . appSettings <$> getYesod appResourceDir <- (</> "apps" </> "apps.yaml") . resourcesDir . appSettings <$> getYesod
respondSource typePlain $ CB.sourceFile appResourceDir .| awaitForever sendChunkBS respondSource typePlain $ CB.sourceFile appResourceDir .| awaitForever sendChunkBS
getSysR :: Extension "" -> Handler TypedContent getSysR :: Extension "" -> Handler TypedContent
@@ -64,7 +68,7 @@ getAppR e = do
getApp :: KnownSymbol a => FilePath -> Extension a -> Handler TypedContent getApp :: KnownSymbol a => FilePath -> Extension a -> Handler TypedContent
getApp rootDir ext@(Extension appId) = do getApp rootDir ext@(Extension appId) = do
specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec" specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec"
spec <- case readMaybe specString of spec <- case readMaybe specString of
Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text) Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
Just t -> pure t Just t -> pure t
appVersions <- liftIO $ getAvailableAppVersions rootDir ext appVersions <- liftIO $ getAvailableAppVersions rootDir ext
@@ -73,50 +77,54 @@ getApp rootDir ext@(Extension appId) = do
Nothing -> notFound Nothing -> notFound
Just (RegisteredAppVersion (appVersion, filePath)) -> do Just (RegisteredAppVersion (appVersion, filePath)) -> do
exists <- liftIO $ doesFileExist filePath >>= \case exists <- liftIO $ doesFileExist filePath >>= \case
True -> pure Existent True -> pure Existent
False -> pure NonExistent False -> pure NonExistent
determineEvent exists (extension ext) filePath appVersion determineEvent exists (extension ext) filePath appVersion
where where
determineEvent :: FileExistence -> String -> FilePath -> AppVersion -> HandlerFor AgentCtx TypedContent determineEvent :: FileExistence -> String -> FilePath -> AppVersion -> HandlerFor RegistryCtx TypedContent
-- for app files -- for app files
determineEvent Existent "s9pk" fp av = do determineEvent Existent "s9pk" fp av = do
_ <- recordMetrics appId rootDir av _ <- recordMetrics appId rootDir av
chunkIt fp chunkIt fp
-- for png, system, etc -- for png, system, etc
determineEvent Existent _ fp _ = chunkIt fp determineEvent Existent _ fp _ = chunkIt fp
determineEvent NonExistent _ _ _ = notFound determineEvent NonExistent _ _ _ = notFound
chunkIt :: FilePath -> HandlerFor AgentCtx TypedContent chunkIt :: FilePath -> HandlerFor RegistryCtx TypedContent
chunkIt fp = do chunkIt fp = do
sz <- liftIO $ fileSize <$> getFileStatus fp sz <- liftIO $ fileSize <$> getFileStatus fp
addHeader "Content-Length" (show sz) addHeader "Content-Length" (show sz)
respondSource typeOctet $ CB.sourceFile fp .| awaitForever sendChunkBS respondSource typeOctet $ CB.sourceFile fp .| awaitForever sendChunkBS
recordMetrics :: String -> FilePath -> AppVersion -> HandlerFor AgentCtx () recordMetrics :: String -> FilePath -> AppVersion -> HandlerFor RegistryCtx ()
recordMetrics appId rootDir appVersion = do recordMetrics appId rootDir appVersion = do
let appId' = T.pack appId let appId' = T.pack appId
manifest <- liftIO $ getAppManifest rootDir manifest <- liftIO $ getAppManifest rootDir
(storeApp, versionInfo) <- case HM.lookup appId' $ unAppManifest manifest of (storeApp, versionInfo) <- case HM.lookup appId' $ unAppManifest manifest of
Nothing -> sendResponseStatus status400 ("App not present in manifest" :: Text) Nothing -> sendResponseStatus status400 ("App not present in manifest" :: Text)
Just sa -> do Just sa -> do
-- look up at specfic version -- look up at specfic version
vi <- case find ((appVersion ==) . versionInfoVersion) (storeAppVersionInfo sa) of vi <- case find ((appVersion ==) . versionInfoVersion) (storeAppVersionInfo sa) of
Nothing -> sendResponseStatus status400 ("App version not present in manifest" :: Text) Nothing -> sendResponseStatus status400 ("App version not present in manifest" :: Text)
Just x -> pure x Just x -> pure x
pure (sa, vi) pure (sa, vi)
-- lazy load app at requested version if it does not yet exist to automatically transfer from using apps.yaml -- lazy load app at requested version if it does not yet exist to automatically transfer from using apps.yaml
sa <- runDB $ fetchApp appId' sa <- runDB $ fetchApp appId'
(appKey, versionKey) <- case sa of (appKey, versionKey) <- case sa of
Nothing -> do Nothing -> do
appKey' <- runDB $ createApp appId' storeApp >>= errOnNothing status500 "duplicate app created" appKey' <- runDB $ createApp appId' storeApp >>= errOnNothing status500 "duplicate app created"
versionKey' <- runDB $ createAppVersion appKey' versionInfo >>= errOnNothing status500 "duplicate app version created" versionKey' <- runDB $ createAppVersion appKey' versionInfo >>= errOnNothing
status500
"duplicate app version created"
pure (appKey', versionKey') pure (appKey', versionKey')
Just a -> do Just a -> do
let appKey' = entityKey a let appKey' = entityKey a
existingVersion <- runDB $ fetchAppVersion appVersion appKey' existingVersion <- runDB $ fetchAppVersion appVersion appKey'
case existingVersion of case existingVersion of
Nothing -> do Nothing -> do
appVersion' <- runDB $ createAppVersion appKey' versionInfo >>= errOnNothing status500 "duplicate app version created" appVersion' <- runDB $ createAppVersion appKey' versionInfo >>= errOnNothing
status500
"duplicate app version created"
pure (appKey', appVersion') pure (appKey', appVersion')
Just v -> pure (appKey', entityKey v) Just v -> pure (appKey', entityKey v)
runDB $ createMetric appKey versionKey runDB $ createMetric appKey versionKey

26
src/Lib/Ssl.hs
View File

@@ -8,6 +8,7 @@ import Startlude
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
import System.Directory import System.Directory
import System.Process import System.Process
import Settings import Settings
-- openssl genrsa -out key.pem 2048 -- openssl genrsa -out key.pem 2048
@@ -15,7 +16,7 @@ import Settings
-- openssl x509 -req -in certificate.csr -signkey key.pem -out certificate.pem -- openssl x509 -req -in certificate.csr -signkey key.pem -out certificate.pem
setupSsl :: AppSettings -> IO () setupSsl :: AppSettings -> IO ()
setupSsl AppSettings{..} = do setupSsl AppSettings {..} = do
exists <- checkForSslCert exists <- checkForSslCert
unless exists $ do unless exists $ do
void $ system $ "mkdir -p " <> sslPath void $ system $ "mkdir -p " <> sslPath
@@ -24,8 +25,7 @@ setupSsl AppSettings{..} = do
void selfSignSslCert void selfSignSslCert
where where
checkForSslCert :: IO Bool checkForSslCert :: IO Bool
checkForSslCert = checkForSslCert = doesPathExist sslKeyLocation <&&> doesPathExist sslCertLocation
doesPathExist sslKeyLocation <&&> doesPathExist sslCertLocation
generateSslKey :: IO ExitCode generateSslKey :: IO ExitCode
generateSslKey = rawSystem "openssl" ["genrsa", "-out", sslKeyLocation, "2048"] generateSslKey = rawSystem "openssl" ["genrsa", "-out", sslKeyLocation, "2048"]
@@ -38,12 +38,14 @@ setupSsl AppSettings{..} = do
selfSignSslCert :: IO ExitCode selfSignSslCert :: IO ExitCode
selfSignSslCert = rawSystem selfSignSslCert = rawSystem
"openssl" "openssl"
[ "x509" ["x509", "-req", "-in", sslCsrLocation, "-signkey", sslKeyLocation, "-out", sslCertLocation]
, "-req"
, "-in" doesSslNeedRenew :: FilePath -> IO Bool
, sslCsrLocation doesSslNeedRenew cert = do
, "-signkey" ec <- liftIO $ system [i|openssl x509 -checkend 2592000 -noout -in #{cert}|]
, sslKeyLocation pure $ ec /= ExitSuccess
, "-out"
, sslCertLocation renewSslCerts :: FilePath -> IO ()
] renewSslCerts cert = do
void . liftIO $ system [i|certbot renew|]
void . liftIO $ system [i|cp /etc/letsencrypt/live/beta-registry.start9labs.com/fullchain.pem #{cert}|]

70
src/Settings.hs
View File

@@ -9,22 +9,24 @@ module Settings where
import Startlude import Startlude
import qualified Control.Exception as Exception import qualified Control.Exception as Exception
import Control.Monad.Fail (fail) import Control.Monad.Fail ( fail )
import Data.Maybe import Data.Maybe
import Data.Aeson import Data.Aeson
import Data.Aeson.Types import Data.Aeson.Types
import Data.Version (showVersion) import Data.Version ( showVersion )
import Data.FileEmbed (embedFile) import Data.FileEmbed ( embedFile )
import Data.Yaml (decodeEither') import Data.Yaml ( decodeEither' )
import Database.Persist.Postgresql (PostgresConf) import Database.Persist.Postgresql ( PostgresConf )
import Network.Wai.Handler.Warp (HostPreference) import Network.Wai.Handler.Warp ( HostPreference )
import Yesod.Default.Config2 (applyEnvValue, configSettingsYml) import Yesod.Default.Config2 ( applyEnvValue
import Paths_start9_registry (version) , configSettingsYml
)
import Paths_start9_registry ( version )
import Lib.Types.Semver import Lib.Types.Semver
import System.FilePath ((</>)) import System.FilePath ( (</>) )
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import Data.Yaml.Config import Data.Yaml.Config
-- | Runtime settings to configure this application. These settings can be -- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files, -- loaded from various sources: defaults, environment variables, config files,
@@ -65,9 +67,9 @@ instance FromJSON AppSettings where
resourcesDir <- o .: "resources-path" resourcesDir <- o .: "resources-path"
sslPath <- o .: "ssl-path" sslPath <- o .: "ssl-path"
registryHostname <- o .: "registry-hostname" registryHostname <- o .: "registry-hostname"
let sslKeyLocation = sslPath </> "key.pem" let sslKeyLocation = sslPath </> "key.pem"
let sslCsrLocation = sslPath </> "certificate.csr" let sslCsrLocation = sslPath </> "certificate.csr"
let sslCertLocation = sslPath </> "certificate.pem" let sslCertLocation = sslPath </> "certificate.pem"
let registryVersion = fromJust . parseMaybe parseJSON . String . toS . showVersion $ version let registryVersion = fromJust . parseMaybe parseJSON . String . toS . showVersion $ version
@@ -79,15 +81,13 @@ configSettingsYmlBS = $(embedFile configSettingsYml)
-- | @config/settings.yml@, parsed to a @Value@. -- | @config/settings.yml@, parsed to a @Value@.
configSettingsYmlValue :: Value configSettingsYmlValue :: Value
configSettingsYmlValue = configSettingsYmlValue = either Exception.throw id $ decodeEither' configSettingsYmlBS
either Exception.throw id $ decodeEither' configSettingsYmlBS
-- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@. -- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@.
compileTimeAppSettings :: AppSettings compileTimeAppSettings :: AppSettings
compileTimeAppSettings = compileTimeAppSettings = case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of Error e -> panic $ toS e
Error e -> panic $ toS e Success settings -> settings
Success settings -> settings
getAppManifest :: FilePath -> IO AppManifest getAppManifest :: FilePath -> IO AppManifest
getAppManifest resourcesDir = do getAppManifest resourcesDir = do
@@ -95,8 +95,8 @@ getAppManifest resourcesDir = do
loadYamlSettings [appFile] [] useEnv loadYamlSettings [appFile] [] useEnv
type AppIdentifier = Text type AppIdentifier = Text
data StoreApp = StoreApp data StoreApp = StoreApp
{ storeAppTitle :: Text { storeAppTitle :: Text
, storeAppDescShort :: Text , storeAppDescShort :: Text
, storeAppDescLong :: Text , storeAppDescLong :: Text
@@ -110,25 +110,25 @@ newtype AppManifest = AppManifest { unAppManifest :: HM.HashMap AppIdentifier St
instance FromJSON AppManifest where instance FromJSON AppManifest where
parseJSON = withObject "app details to seed" $ \o -> do parseJSON = withObject "app details to seed" $ \o -> do
apps <- for (HM.toList o) $ \(appId', c) -> do apps <- for (HM.toList o) $ \(appId', c) -> do
appId <- parseJSON $ String appId' appId <- parseJSON $ String appId'
config <- parseJSON c config <- parseJSON c
storeAppTitle <- config .: "title" storeAppTitle <- config .: "title"
storeAppIconType <- config .: "icon-type" storeAppIconType <- config .: "icon-type"
storeAppDescShort <- config .: "description" >>= (.: "short") storeAppDescShort <- config .: "description" >>= (.: "short")
storeAppDescLong <- config .: "description" >>= (.: "long") storeAppDescLong <- config .: "description" >>= (.: "long")
storeAppVersionInfo <- config .: "version-info" >>= \case storeAppVersionInfo <- config .: "version-info" >>= \case
[] -> fail "No Valid Version Info" [] -> fail "No Valid Version Info"
(x:xs) -> pure $ x :| xs (x : xs) -> pure $ x :| xs
return $ (appId, StoreApp {..}) return $ (appId, StoreApp { .. })
return $ AppManifest (HM.fromList apps) return $ AppManifest (HM.fromList apps)
data VersionInfo = VersionInfo data VersionInfo = VersionInfo
{ versionInfoVersion :: AppVersion { versionInfoVersion :: AppVersion
, versionInfoReleaseNotes :: Text , versionInfoReleaseNotes :: Text
} deriving (Eq, Ord, Show) } deriving (Eq, Ord, Show)
instance FromJSON VersionInfo where instance FromJSON VersionInfo where
parseJSON = withObject "version info" $ \o -> do parseJSON = withObject "version info" $ \o -> do
versionInfoVersion <- o .: "version" versionInfoVersion <- o .: "version"
versionInfoReleaseNotes <- o .: "release-notes" versionInfoReleaseNotes <- o .: "release-notes"
pure VersionInfo {..} pure VersionInfo { .. }

57
test/TestImport.hs
View File

@@ -5,31 +5,33 @@
module TestImport module TestImport
( module TestImport ( module TestImport
, module X , module X
) where )
where
import Startlude import Startlude
import Application (makeFoundation, makeLogWare) import Application ( makeFoundation
import Foundation as X , makeLogWare
import Test.Hspec as X )
import Yesod.Default.Config2 (useEnv, loadYamlSettings) import Foundation as X
import Yesod.Test as X import Test.Hspec as X
import Yesod.Core.Unsafe (fakeHandlerGetLogger) import Yesod.Default.Config2 ( useEnv
import Database.Persist.Sql , loadYamlSettings
import Text.Shakespeare.Text (st) )
import Yesod.Core import Yesod.Test as X
import qualified Data.Text as T import Yesod.Core.Unsafe ( fakeHandlerGetLogger )
import Database.Persist.Sql
import Text.Shakespeare.Text ( st )
import Yesod.Core
import qualified Data.Text as T
runHandler :: Handler a -> YesodExample AgentCtx a runHandler :: Handler a -> YesodExample RegistryCtx a
runHandler handler = do runHandler handler = do
app <- getTestYesod app <- getTestYesod
fakeHandlerGetLogger appLogger app handler fakeHandlerGetLogger appLogger app handler
withApp :: SpecWith (TestApp AgentCtx) -> Spec withApp :: SpecWith (TestApp RegistryCtx) -> Spec
withApp = before $ do withApp = before $ do
settings <- loadYamlSettings settings <- loadYamlSettings ["config/settings.yml"] [] useEnv
["config/settings.yml"]
[]
useEnv
foundation <- makeFoundation settings foundation <- makeFoundation settings
wipeDB foundation wipeDB foundation
logWare <- liftIO $ makeLogWare foundation logWare <- liftIO $ makeLogWare foundation
@@ -37,32 +39,33 @@ withApp = before $ do
getTables :: DB [Text] getTables :: DB [Text]
getTables = do getTables = do
tables <- rawSql [st| tables <- rawSql
[st|
SELECT table_name SELECT table_name
FROM information_schema.tables FROM information_schema.tables
WHERE table_schema = 'public' WHERE table_schema = 'public'
AND table_type = 'BASE TABLE'; AND table_type = 'BASE TABLE';
|] [] |]
[]
return $ fmap unSingle tables return $ fmap unSingle tables
wipeDB :: AgentCtx -> IO () wipeDB :: RegistryCtx -> IO ()
wipeDB app = runDBWithApp app $ do wipeDB app = runDBWithApp app $ do
tables <- getTables tables <- getTables
sqlBackend <- ask sqlBackend <- ask
let escapedTables = map (T.unpack . connEscapeName sqlBackend . DBName) tables let escapedTables = map (T.unpack . connEscapeName sqlBackend . DBName) tables
query = "TRUNCATE TABLE " ++ (intercalate ", " escapedTables) query = "TRUNCATE TABLE " ++ (intercalate ", " escapedTables)
rawExecute (T.pack query) [] rawExecute (T.pack query) []
runDBtest :: SqlPersistM a -> YesodExample AgentCtx a runDBtest :: SqlPersistM a -> YesodExample RegistryCtx a
runDBtest query = do runDBtest query = do
app <- getTestYesod app <- getTestYesod
liftIO $ runDBWithApp app query liftIO $ runDBWithApp app query
runDBWithApp :: AgentCtx -> SqlPersistM a -> IO a runDBWithApp :: RegistryCtx -> SqlPersistM a -> IO a
runDBWithApp app query = runSqlPersistMPool query (appConnPool app) runDBWithApp app query = runSqlPersistMPool query (appConnPool app)
-- A convenient synonym for database access functions -- A convenient synonym for database access functions
type DB a = forall (m :: * -> *). type DB a = forall (m :: * -> *) . (MonadUnliftIO m) => ReaderT SqlBackend m a
(MonadUnliftIO m) => ReaderT SqlBackend m a