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 pull request #14 from Start9Labs/feature/cert-autorenew

Browse Source 
autorenews certificates
This commit is contained in:
Keagan McClelland
2020-08-06 09:09:49 -06:00
committed by GitHub
parent abdb452a11 e307c14c6f
commit 4f33a78ddd
9 changed files with 263 additions and 166 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

2
config/settings.yml
View File

@@ -29,7 +29,7 @@ ip-from-header: "_env:YESOD_IP_FROM_HEADER:false"
# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings
app-compatibility-path: "_env:APP_COMPATIBILITY_CONFIG:/etc/start9/registry/compatibility.json"
resources-path: "_env:RESOURCES_PATH:/var/www/html/resources"
resources-path: "_env:RESOURCES_PATH:/var/www/html/resources"
ssl-path: "_env:SSL_PATH:/var/ssl"
registry-hostname: "_env:REGISTRY_HOSTNAME:registry.start9labs.com"

1
package.yaml
View File

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

89
src/Application.hs
View File

@@ -30,7 +30,6 @@ import Startlude
import Control.Monad.Logger (liftLoc, runLoggingT)
import Data.Aeson
import Data.Default
import Data.IORef
import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool, runMigration)
import Language.Haskell.TH.Syntax (qLocation)
import Network.Wai
@@ -43,6 +42,7 @@ import Network.Wai.Middleware.Cors (CorsResourcePolicy (..),
import Network.Wai.Middleware.MethodOverride
import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (..), OutputFormat (..),
destination, mkRequestLogger, outputFormat)
import System.IO (hSetBuffering, BufferMode (..))
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr)
import Yesod.Core
import Yesod.Core.Types hiding (Logger)
@@ -56,25 +56,27 @@ import Handler.Icons
import Handler.Version
import Lib.Ssl
import Settings
import Model
import System.Posix.Process
import System.Time.Extra
import Model
-- 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
-- comments there for more details.
mkYesodDispatch "AgentCtx" resourcesAgentCtx
mkYesodDispatch "RegistryCtx" resourcesRegistryCtx
-- | This function allocates resources (such as a database connection pool),
-- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation :: AppSettings -> IO AgentCtx
makeFoundation :: AppSettings -> IO RegistryCtx
makeFoundation appSettings = do
-- Some basic initializations: HTTP connection manager, logger, and static
-- subsite.
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
appWebServerThreadId <- newIORef Nothing
appWebServerThreadId <- newEmptyMVar
appShouldRestartWeb <- newMVar False
appCompatibilityMap <- decode . toS <$> readFile (appCompatibilityPath appSettings) >>= \case
Nothing -> panic "invalid compatibility config"
@@ -85,8 +87,8 @@ makeFoundation appSettings = do
-- 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 {..}
-- The AgentCtx {..} syntax is an example of record wild cards. For more
let mkFoundation appConnPool = RegistryCtx {..}
-- The RegistryCtx {..} 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"
@@ -105,7 +107,7 @@ makeFoundation appSettings = do
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
makeApplication :: AgentCtx -> IO Application
makeApplication :: RegistryCtx -> IO Application
makeApplication foundation = do
logWare <- makeLogWare foundation
let authWare = makeAuthWare foundation
@@ -117,10 +119,10 @@ makeApplication foundation = do
-- TODO: create a middle ware which will attempt to verify an ecdsa signed transaction against one of the public keys
-- in the validDevices table.
-- makeCheckSigWare :: AgentCtx -> IO Middleware
-- makeCheckSigWare :: RegistryCtx -> IO Middleware
-- makeCheckSigWare = _
makeLogWare :: AgentCtx -> IO Middleware
makeLogWare :: RegistryCtx -> IO Middleware
makeLogWare foundation =
mkRequestLogger def
{ outputFormat =
@@ -134,14 +136,14 @@ makeLogWare foundation =
}
-- TODO : what kind of auth is needed here
makeAuthWare :: AgentCtx -> Middleware
makeAuthWare :: RegistryCtx -> Middleware
makeAuthWare _ app req res = next
where
next :: IO ResponseReceived
next = app req res
-- | Warp settings for the given foundation value.
warpSettings :: AgentCtx -> Settings
warpSettings :: RegistryCtx -> Settings
warpSettings foundation =
setPort (fromIntegral . appPort $ appSettings foundation)
$ setHost (appHost $ appSettings foundation)
@@ -161,6 +163,7 @@ getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
-- | The @main@ function for an executable running this site.
appMain :: IO ()
appMain = do
hSetBuffering stdout LineBuffering
-- Get the settings from all relevant sources
settings <- loadYamlSettingsArgs
-- fall back to compile-time values, set to [] to require values at runtime
@@ -172,26 +175,50 @@ appMain = do
-- Generate the foundation from the settings
makeFoundation settings >>= startApp
startApp :: AgentCtx -> IO ()
startApp :: RegistryCtx -> IO ()
startApp foundation = do
-- set up ssl certificates
putStrLn @Text "Setting up SSL"
_ <- setupSsl $ appSettings foundation
putStrLn @Text "SSL Setup Complete"
-- certbot renew loop
void . forkIO $ forever $ flip runReaderT foundation $ do
shouldRenew <- doesSslNeedRenew
putStrLn @Text $ "Checking if SSL Certs should be renewed: " <> show shouldRenew
when shouldRenew $ do
putStrLn @Text "Renewing SSL Certs."
renewSslCerts
liftIO $ restartWeb foundation
liftIO $ sleep 86_400
startWeb foundation
startWeb :: AgentCtx -> IO ()
startWeb :: RegistryCtx -> IO ()
startWeb foundation = do
app <- makeApplication foundation
let AppSettings{..} = appSettings foundation
putStrLn @Text $ "Launching Web Server on port " <> show appPort
action <- async $ runTLS
(tlsSettings sslCertLocation sslKeyLocation)
(warpSettings foundation)
app
startWeb' app
where
startWeb' app = do
let AppSettings{..} = appSettings foundation
putStrLn @Text $ "Launching Web Server on port " <> show appPort
action <- async $ runTLS
(tlsSettings sslCertLocation sslKeyLocation)
(warpSettings foundation)
app
setWebProcessThreadId (asyncThreadId action) foundation
wait action
setWebProcessThreadId (asyncThreadId action) foundation
void $ waitCatch action
shouldRestart <- takeMVar (appShouldRestartWeb foundation)
when shouldRestart $ do
putMVar (appShouldRestartWeb foundation) False
putStrLn @Text "Restarting Web Server"
startWeb' app
restartWeb :: RegistryCtx -> IO ()
restartWeb foundation = do
void $ swapMVar (appShouldRestartWeb foundation) True
shutdownWeb foundation
shutdownAll :: [ThreadId] -> IO ()
shutdownAll threadIds = do
@@ -199,25 +226,23 @@ shutdownAll threadIds = do
exitImmediately ExitSuccess
-- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process
shutdownWeb :: AgentCtx -> IO ()
shutdownWeb AgentCtx{..} = do
mThreadId <- readIORef appWebServerThreadId
for_ mThreadId $ \tid -> do
killThread tid
writeIORef appWebServerThreadId Nothing
shutdownWeb :: RegistryCtx -> IO ()
shutdownWeb RegistryCtx{..} = do
threadId <- takeMVar appWebServerThreadId
killThread threadId
--------------------------------------------------------------
-- 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
foundation <- getAppSettings >>= makeFoundation
wsettings <- getDevSettings $ warpSettings foundation
app1 <- makeApplication foundation
return (getPort wsettings, foundation, app1)
return (getPort wsettings, foundation, app1)
shutdownApp :: AgentCtx -> IO ()
shutdownApp :: RegistryCtx -> IO ()
shutdownApp _ = return ()
---------------------------------------------

53
src/Foundation.hs
View File

@@ -8,14 +8,13 @@ module Foundation where
import Startlude
import Control.Monad.Logger (LogSource)
import qualified Data.HashMap.Strict as HM
import Data.IORef
import Control.Monad.Logger ( LogSource )
import qualified Data.HashMap.Strict as HM
import Database.Persist.Sql
import Lib.Registry
import Yesod.Core
import Yesod.Core.Types (Logger)
import qualified Yesod.Core.Unsafe as Unsafe
import Yesod.Core.Types ( Logger )
import qualified Yesod.Core.Unsafe as Unsafe
import Lib.Types.Semver
import Settings
@@ -27,16 +26,17 @@ import Yesod.Persist.Core
-- access to the data present here.
data AgentCtx = AgentCtx
data RegistryCtx = RegistryCtx
{ appSettings :: AppSettings
, appLogger :: Logger
, appWebServerThreadId :: IORef (Maybe ThreadId)
, appWebServerThreadId :: MVar ThreadId
, appShouldRestartWeb :: MVar Bool
, appCompatibilityMap :: HM.HashMap AppVersion AppVersion
, appConnPool :: ConnectionPool
}
setWebProcessThreadId :: ThreadId -> AgentCtx -> IO ()
setWebProcessThreadId tid a = writeIORef (appWebServerThreadId a) . Just $ tid
setWebProcessThreadId :: ThreadId -> RegistryCtx -> IO ()
setWebProcessThreadId tid a = putMVar (appWebServerThreadId a) $ tid
-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:
@@ -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
--
-- This function also generates the following type synonyms:
-- type Handler = HandlerT AgentCtx IO
mkYesodData "AgentCtx" $(parseRoutesFile "config/routes")
-- type Handler = HandlerT RegistryCtx IO
mkYesodData "RegistryCtx" $(parseRoutesFile "config/routes")
-- Please see the documentation for the Yesod typeclass. There are a number
-- 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,
-- default session idle timeout is 120 minutes
makeSessionBackend :: AgentCtx -> IO (Maybe SessionBackend)
makeSessionBackend :: RegistryCtx -> IO (Maybe SessionBackend)
makeSessionBackend _ = pure Nothing
-- 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
-- in development, and warnings and errors in production.
shouldLogIO :: AgentCtx -> LogSource -> LogLevel -> IO Bool
shouldLogIO :: RegistryCtx -> LogSource -> LogLevel -> IO Bool
shouldLogIO app _source level =
return
$ appShouldLogAll (appSettings app)
|| level
== LevelInfo
|| level
== LevelWarn
|| level
== LevelError
return $ appShouldLogAll (appSettings app) || level == LevelInfo || level == LevelWarn || level == LevelError
makeLogger :: AgentCtx -> IO Logger
makeLogger :: RegistryCtx -> IO Logger
makeLogger = return . appLogger
-- How to run database actions.
instance YesodPersist AgentCtx where
type YesodPersistBackend AgentCtx = SqlBackend
instance YesodPersist RegistryCtx where
type YesodPersistBackend RegistryCtx = SqlBackend
runDB :: SqlPersistT Handler a -> Handler a
runDB action = runSqlPool action . appConnPool =<< getYesod
instance YesodPersistRunner AgentCtx where
getDBRunner :: Handler (DBRunner AgentCtx, Handler ())
instance YesodPersistRunner RegistryCtx where
getDBRunner :: Handler (DBRunner RegistryCtx, Handler ())
getDBRunner = defaultGetDBRunner appConnPool
unsafeHandler :: AgentCtx -> Handler a -> IO a
unsafeHandler :: RegistryCtx -> Handler a -> IO a
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
-- 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/i18n-messages-in-the-scaffolding
appLogFunc :: AgentCtx -> LogFunc
appLogFunc = appLogger >>= flip messageLoggerSource
appLogFunc :: RegistryCtx -> LogFunc
appLogFunc = appLogger >>= flip messageLoggerSource

66
src/Handler/Apps.hs
View File

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

31
src/Lib/Ssl.hs
View File

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

70
src/Settings.hs
View File

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

57
test/TestImport.hs
View File

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