From f385d23210c99c305803fe9145a2daecfab45b03 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 3 Aug 2020 15:09:50 -0600 Subject: [PATCH 01/14] 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 From 7c008f321ce7d814765b1302270ab05ad8c53057 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 4 Aug 2020 13:18:43 -0600 Subject: [PATCH 02/14] fixes path dependence --- config/settings.yml | 2 +- src/Application.hs | 15 +++++++++------ src/Lib/Ssl.hs | 6 ++++-- 3 files changed, 14 insertions(+), 9 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 6780d74..7cda8fe 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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" diff --git a/src/Application.hs b/src/Application.hs index eb355bc..a1f0dac 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -170,12 +170,6 @@ 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 @@ -186,6 +180,15 @@ startApp foundation = do putStrLn @Text "Setting up SSL" _ <- setupSsl $ appSettings foundation putStrLn @Text "SSL Setup Complete" + + -- certbot renew loop + void . forkIO $ forever $ do + shouldRenew <- doesSslNeedRenew (sslCertLocation $ appSettings foundation) + when shouldRenew $ do + putStrLn @Text "Renewing SSL Certs." + runReaderT (renewSslCerts (sslCertLocation $ appSettings foundation)) foundation + sleep 86_400 + startWeb foundation startWeb :: RegistryCtx -> IO () diff --git a/src/Lib/Ssl.hs b/src/Lib/Ssl.hs index 7dc8eff..00cadfc 100644 --- a/src/Lib/Ssl.hs +++ b/src/Lib/Ssl.hs @@ -9,6 +9,7 @@ import Data.String.Interpolate.IsString import System.Directory import System.Process +import Foundation import Settings -- openssl genrsa -out key.pem 2048 @@ -45,7 +46,8 @@ doesSslNeedRenew cert = do ec <- liftIO $ system [i|openssl x509 -checkend 2592000 -noout -in #{cert}|] pure $ ec /= ExitSuccess -renewSslCerts :: FilePath -> IO () +renewSslCerts :: FilePath -> ReaderT RegistryCtx IO () renewSslCerts cert = do + domain <- asks $ registryHostname . appSettings void . liftIO $ system [i|certbot renew|] - void . liftIO $ system [i|cp /etc/letsencrypt/live/beta-registry.start9labs.com/fullchain.pem #{cert}|] + void . liftIO $ system [i|cp /etc/letsencrypt/live/#{domain}/fullchain.pem #{cert}|] From b26ad51ba2ef3120a55f674bc0030fa607d7d84b Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 4 Aug 2020 15:11:48 -0600 Subject: [PATCH 03/14] printing things for testing --- src/Lib/Ssl.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Lib/Ssl.hs b/src/Lib/Ssl.hs index 00cadfc..821dc60 100644 --- a/src/Lib/Ssl.hs +++ b/src/Lib/Ssl.hs @@ -49,5 +49,7 @@ doesSslNeedRenew cert = do renewSslCerts :: FilePath -> ReaderT RegistryCtx IO () renewSslCerts cert = do domain <- asks $ registryHostname . appSettings + liftIO $ putStrLn $ "DOMAIN: " <> domain + liftIO $ putStrLn $ "CERT: " <> cert void . liftIO $ system [i|certbot renew|] void . liftIO $ system [i|cp /etc/letsencrypt/live/#{domain}/fullchain.pem #{cert}|] From 949f2f867c12bbcc1a77486e822f1efb2994006c Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 4 Aug 2020 15:50:42 -0600 Subject: [PATCH 04/14] print check --- src/Application.hs | 2 ++ src/Lib/Ssl.hs | 2 -- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index a1f0dac..bcda1aa 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -183,6 +183,8 @@ startApp foundation = do -- certbot renew loop void . forkIO $ forever $ do + putStrLn $ "DOMAIN: " <> registryHostname (appSettings foundation) + putStrLn $ "CERT: " <> sslCertLocation (appSettings foundation) shouldRenew <- doesSslNeedRenew (sslCertLocation $ appSettings foundation) when shouldRenew $ do putStrLn @Text "Renewing SSL Certs." diff --git a/src/Lib/Ssl.hs b/src/Lib/Ssl.hs index 821dc60..00cadfc 100644 --- a/src/Lib/Ssl.hs +++ b/src/Lib/Ssl.hs @@ -49,7 +49,5 @@ doesSslNeedRenew cert = do renewSslCerts :: FilePath -> ReaderT RegistryCtx IO () renewSslCerts cert = do domain <- asks $ registryHostname . appSettings - liftIO $ putStrLn $ "DOMAIN: " <> domain - liftIO $ putStrLn $ "CERT: " <> cert void . liftIO $ system [i|certbot renew|] void . liftIO $ system [i|cp /etc/letsencrypt/live/#{domain}/fullchain.pem #{cert}|] From c157a99b0a17650ae2e4b5a166bd076a3f545944 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 4 Aug 2020 16:12:31 -0600 Subject: [PATCH 05/14] test setup --- src/Lib/Ssl.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Lib/Ssl.hs b/src/Lib/Ssl.hs index 00cadfc..0c06e3e 100644 --- a/src/Lib/Ssl.hs +++ b/src/Lib/Ssl.hs @@ -49,5 +49,5 @@ doesSslNeedRenew cert = do renewSslCerts :: FilePath -> ReaderT RegistryCtx IO () renewSslCerts cert = do domain <- asks $ registryHostname . appSettings - void . liftIO $ system [i|certbot renew|] + void . liftIO $ system [i|certbot renew --dry-run|] void . liftIO $ system [i|cp /etc/letsencrypt/live/#{domain}/fullchain.pem #{cert}|] From c75c9fd250a4c588b03e7c9f81b9e6c01c5489e9 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 4 Aug 2020 16:25:00 -0600 Subject: [PATCH 06/14] test setup --- src/Application.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Application.hs b/src/Application.hs index bcda1aa..a365b60 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -185,6 +185,7 @@ startApp foundation = do void . forkIO $ forever $ do putStrLn $ "DOMAIN: " <> registryHostname (appSettings foundation) putStrLn $ "CERT: " <> sslCertLocation (appSettings foundation) + runReaderT (renewSslCerts (sslCertLocation $ appSettings foundation)) foundation shouldRenew <- doesSslNeedRenew (sslCertLocation $ appSettings foundation) when shouldRenew $ do putStrLn @Text "Renewing SSL Certs." From 5df3523f871adbeb17992754d876c513c7396464 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 4 Aug 2020 16:33:21 -0600 Subject: [PATCH 07/14] fixes key issues --- src/Application.hs | 4 ++-- src/Lib/Ssl.hs | 8 +++++--- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index a365b60..33ad98e 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -185,11 +185,11 @@ startApp foundation = do void . forkIO $ forever $ do putStrLn $ "DOMAIN: " <> registryHostname (appSettings foundation) putStrLn $ "CERT: " <> sslCertLocation (appSettings foundation) - runReaderT (renewSslCerts (sslCertLocation $ appSettings foundation)) foundation + runReaderT renewSslCerts foundation shouldRenew <- doesSslNeedRenew (sslCertLocation $ appSettings foundation) when shouldRenew $ do putStrLn @Text "Renewing SSL Certs." - runReaderT (renewSslCerts (sslCertLocation $ appSettings foundation)) foundation + runReaderT renewSslCerts foundation sleep 86_400 startWeb foundation diff --git a/src/Lib/Ssl.hs b/src/Lib/Ssl.hs index 0c06e3e..3bd86d8 100644 --- a/src/Lib/Ssl.hs +++ b/src/Lib/Ssl.hs @@ -46,8 +46,10 @@ doesSslNeedRenew cert = do ec <- liftIO $ system [i|openssl x509 -checkend 2592000 -noout -in #{cert}|] pure $ ec /= ExitSuccess -renewSslCerts :: FilePath -> ReaderT RegistryCtx IO () -renewSslCerts cert = do - domain <- asks $ registryHostname . appSettings +renewSslCerts :: ReaderT RegistryCtx IO () +renewSslCerts = do + domain <- asks $ registryHostname . appSettings + (cert, key) <- asks $ (sslCertLocation &&& sslKeyLocation) . appSettings void . liftIO $ system [i|certbot renew --dry-run|] void . liftIO $ system [i|cp /etc/letsencrypt/live/#{domain}/fullchain.pem #{cert}|] + void . liftIO $ system [i|cp /etc/letsencrypt/live/#{domain}/privkey.pem #{key}|] From f9bba3b65bf1e61eb3942f971b40d4d4e1227c70 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 4 Aug 2020 17:01:51 -0600 Subject: [PATCH 08/14] testing complete --- src/Application.hs | 11 ++++------- src/Lib/Ssl.hs | 9 +++++---- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 33ad98e..07f1929 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -182,15 +182,12 @@ startApp foundation = do putStrLn @Text "SSL Setup Complete" -- certbot renew loop - void . forkIO $ forever $ do - putStrLn $ "DOMAIN: " <> registryHostname (appSettings foundation) - putStrLn $ "CERT: " <> sslCertLocation (appSettings foundation) - runReaderT renewSslCerts foundation - shouldRenew <- doesSslNeedRenew (sslCertLocation $ appSettings foundation) + void . forkIO $ forever $ flip runReaderT foundation $ do + shouldRenew <- doesSslNeedRenew when shouldRenew $ do putStrLn @Text "Renewing SSL Certs." - runReaderT renewSslCerts foundation - sleep 86_400 + renewSslCerts + liftIO $ sleep 86_400 startWeb foundation diff --git a/src/Lib/Ssl.hs b/src/Lib/Ssl.hs index 3bd86d8..0173af7 100644 --- a/src/Lib/Ssl.hs +++ b/src/Lib/Ssl.hs @@ -41,15 +41,16 @@ setupSsl AppSettings {..} = do "openssl" ["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}|] +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 --dry-run|] + 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}|] From 64c35f3807548346d48c272cffcfc3c639b68e09 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 4 Aug 2020 17:44:06 -0600 Subject: [PATCH 09/14] friendly messaging --- src/Application.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Application.hs b/src/Application.hs index 07f1929..c53fa1a 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -184,6 +184,7 @@ startApp foundation = do -- 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 From 364a4433cd10b4785caef708ebacb4925c101b4d Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 4 Aug 2020 17:55:01 -0600 Subject: [PATCH 10/14] line buffering for journald --- src/Application.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Application.hs b/src/Application.hs index c53fa1a..3c0829c 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -43,6 +43,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) @@ -162,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 From d8a3ace8410b62529f11ba2b4524a54ad7d450c8 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 4 Aug 2020 18:41:15 -0600 Subject: [PATCH 11/14] restart semantics --- src/Application.hs | 45 +++++++++++++++++++++++++++++---------------- src/Foundation.hs | 6 +++--- 2 files changed, 32 insertions(+), 19 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 3c0829c..c345b28 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 @@ -76,7 +75,8 @@ makeFoundation appSettings = do -- 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" @@ -172,9 +172,10 @@ appMain = do -- allow environment variables to override useEnv - -- Generate the foundation from the settings - makeFoundation settings >>= startApp + makeFoundation settings >>= \f -> do + forkIO $ restartWeb f + startApp f startApp :: RegistryCtx -> IO () startApp foundation = do @@ -190,6 +191,7 @@ startApp foundation = do when shouldRenew $ do putStrLn @Text "Renewing SSL Certs." renewSslCerts + liftIO $ restartWeb foundation liftIO $ sleep 86_400 startWeb foundation @@ -197,15 +199,28 @@ startApp foundation = do 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 @@ -215,10 +230,8 @@ shutdownAll threadIds = do -- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process shutdownWeb :: RegistryCtx -> IO () shutdownWeb RegistryCtx{..} = do - mThreadId <- readIORef appWebServerThreadId - for_ mThreadId $ \tid -> do - killThread tid - writeIORef appWebServerThreadId Nothing + threadId <- takeMVar appWebServerThreadId + killThread threadId -------------------------------------------------------------- -- Functions for DevelMain.hs (a way to run the RegistryCtx from GHCi) diff --git a/src/Foundation.hs b/src/Foundation.hs index ebb434c..4aa52e5 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -10,7 +10,6 @@ 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 @@ -30,13 +29,14 @@ import Yesod.Persist.Core 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 -> RegistryCtx -> IO () -setWebProcessThreadId tid a = writeIORef (appWebServerThreadId a) . Just $ tid +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: From cf2bdf1e572c6a9caa16912ee7ef57358c9003c2 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 4 Aug 2020 18:45:57 -0600 Subject: [PATCH 12/14] printf debugging --- src/Application.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Application.hs b/src/Application.hs index c345b28..d20cfad 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -211,14 +211,17 @@ startWeb foundation = do setWebProcessThreadId (asyncThreadId action) foundation void $ waitCatch action + putStrLn @Text "WebServer Killed" shouldRestart <- takeMVar (appShouldRestartWeb foundation) when shouldRestart $ do + putStrLn @Text "Resetting Restart" putMVar (appShouldRestartWeb foundation) False putStrLn @Text "Restarting Web Server" startWeb' app restartWeb :: RegistryCtx -> IO () restartWeb foundation = do + putStrLn @Text "Should restart" void $ swapMVar (appShouldRestartWeb foundation) True shutdownWeb foundation @@ -230,7 +233,9 @@ shutdownAll threadIds = do -- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process shutdownWeb :: RegistryCtx -> IO () shutdownWeb RegistryCtx{..} = do + putStrLn @Text "Taking MVar" threadId <- takeMVar appWebServerThreadId + putStrLn @Text "Killing Thread" killThread threadId -------------------------------------------------------------- From 0624e6667aa5b6d2a2960c53498bb3d84c924eea Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 4 Aug 2020 18:51:00 -0600 Subject: [PATCH 13/14] revert printf debugging --- src/Application.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index d20cfad..c345b28 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -211,17 +211,14 @@ startWeb foundation = do setWebProcessThreadId (asyncThreadId action) foundation void $ waitCatch action - putStrLn @Text "WebServer Killed" shouldRestart <- takeMVar (appShouldRestartWeb foundation) when shouldRestart $ do - putStrLn @Text "Resetting Restart" putMVar (appShouldRestartWeb foundation) False putStrLn @Text "Restarting Web Server" startWeb' app restartWeb :: RegistryCtx -> IO () restartWeb foundation = do - putStrLn @Text "Should restart" void $ swapMVar (appShouldRestartWeb foundation) True shutdownWeb foundation @@ -233,9 +230,7 @@ shutdownAll threadIds = do -- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process shutdownWeb :: RegistryCtx -> IO () shutdownWeb RegistryCtx{..} = do - putStrLn @Text "Taking MVar" threadId <- takeMVar appWebServerThreadId - putStrLn @Text "Killing Thread" killThread threadId -------------------------------------------------------------- From e307c14c6f011a7c0c7f150b55bb16db12cbcef4 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 4 Aug 2020 18:52:08 -0600 Subject: [PATCH 14/14] removes unnecessary webserver kill --- src/Application.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index c345b28..17c3008 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -173,9 +173,7 @@ appMain = do useEnv -- Generate the foundation from the settings - makeFoundation settings >>= \f -> do - forkIO $ restartWeb f - startApp f + makeFoundation settings >>= startApp startApp :: RegistryCtx -> IO () startApp foundation = do