From f385d23210c99c305803fe9145a2daecfab45b03 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 3 Aug 2020 15:09:50 -0600 Subject: [PATCH] autorenews certificates --- brittany.yaml | 60 ++++++++++++++++++++++++++++++++++++++ package.yaml | 1 + src/Application.hs | 44 ++++++++++++++++------------ src/Foundation.hs | 47 +++++++++++++----------------- src/Handler/Apps.hs | 66 +++++++++++++++++++++++------------------- src/Lib/Ssl.hs | 26 +++++++++-------- src/Settings.hs | 70 ++++++++++++++++++++++----------------------- test/TestImport.hs | 57 +++++++++++++++++++----------------- 8 files changed, 223 insertions(+), 148 deletions(-) create mode 100644 brittany.yaml diff --git a/brittany.yaml b/brittany.yaml new file mode 100644 index 0000000..3807b19 --- /dev/null +++ b/brittany.yaml @@ -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 diff --git a/package.yaml b/package.yaml index bfa756c..a2d0a7e 100644 --- a/package.yaml +++ b/package.yaml @@ -23,6 +23,7 @@ dependencies: - dns - either - errors +- extra - file-embed - fast-logger >=2.2 && <2.5 - filepath diff --git a/src/Application.hs b/src/Application.hs index 0942761..eb355bc 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -56,19 +56,20 @@ 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. @@ -85,8 +86,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 +106,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 +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 -- 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 +135,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) @@ -169,10 +170,17 @@ appMain = do -- allow environment variables to override 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 makeFoundation settings >>= startApp -startApp :: AgentCtx -> IO () +startApp :: RegistryCtx -> IO () startApp foundation = do -- set up ssl certificates putStrLn @Text "Setting up SSL" @@ -180,7 +188,7 @@ startApp foundation = do putStrLn @Text "SSL Setup Complete" startWeb foundation -startWeb :: AgentCtx -> IO () +startWeb :: RegistryCtx -> IO () startWeb foundation = do app <- makeApplication foundation let AppSettings{..} = appSettings foundation @@ -199,25 +207,25 @@ 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 +shutdownWeb :: RegistryCtx -> IO () +shutdownWeb RegistryCtx{..} = do mThreadId <- readIORef appWebServerThreadId for_ mThreadId $ \tid -> do killThread tid 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 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 () --------------------------------------------- diff --git a/src/Foundation.hs b/src/Foundation.hs index e468dcb..ebb434c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -8,14 +8,14 @@ module Foundation where import Startlude -import Control.Monad.Logger (LogSource) -import qualified Data.HashMap.Strict as HM +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.Core.Types ( Logger ) +import qualified Yesod.Core.Unsafe as Unsafe import Lib.Types.Semver import Settings @@ -27,7 +27,7 @@ import Yesod.Persist.Core -- access to the data present here. -data AgentCtx = AgentCtx +data RegistryCtx = RegistryCtx { appSettings :: AppSettings , appLogger :: Logger , appWebServerThreadId :: IORef (Maybe ThreadId) @@ -35,7 +35,7 @@ data AgentCtx = AgentCtx , appConnPool :: ConnectionPool } -setWebProcessThreadId :: ThreadId -> AgentCtx -> IO () +setWebProcessThreadId :: ThreadId -> RegistryCtx -> IO () setWebProcessThreadId tid a = writeIORef (appWebServerThreadId a) . Just $ tid -- 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 -- -- 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 \ No newline at end of file +appLogFunc :: RegistryCtx -> LogFunc +appLogFunc = appLogger >>= flip messageLoggerSource diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index cc9a323..b68e374 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -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 diff --git a/src/Lib/Ssl.hs b/src/Lib/Ssl.hs index c28f8f2..7dc8eff 100644 --- a/src/Lib/Ssl.hs +++ b/src/Lib/Ssl.hs @@ -8,6 +8,7 @@ import Startlude import Data.String.Interpolate.IsString import System.Directory import System.Process + import Settings -- openssl genrsa -out key.pem 2048 @@ -15,7 +16,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 +25,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 +38,14 @@ setupSsl AppSettings{..} = do selfSignSslCert :: IO ExitCode selfSignSslCert = rawSystem "openssl" - [ "x509" - , "-req" - , "-in" - , sslCsrLocation - , "-signkey" - , sslKeyLocation - , "-out" - , sslCertLocation - ] \ No newline at end of file + ["x509", "-req", "-in", sslCsrLocation, "-signkey", sslKeyLocation, "-out", sslCertLocation] + +doesSslNeedRenew :: FilePath -> IO Bool +doesSslNeedRenew cert = do + ec <- liftIO $ system [i|openssl x509 -checkend 2592000 -noout -in #{cert}|] + pure $ ec /= ExitSuccess + +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}|] diff --git a/src/Settings.hs b/src/Settings.hs index 5dd489c..d37148f 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -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 { .. } diff --git a/test/TestImport.hs b/test/TestImport.hs index c2f958d..15e243a 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -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