autorenews certificates

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

package.yaml

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

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 {..}
+    let mkFoundation appConnPool = RegistryCtx {..}
-        -- The AgentCtx {..} syntax is an example of record wild cards. For more
+        -- The RegistryCtx {..} syntax is an example of record wild cards. For more
         -- information, see:
         -- 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 :: RegistryCtx -> IO ()
-shutdownWeb AgentCtx{..} = do
+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)
 
-shutdownApp :: AgentCtx -> IO ()
+shutdownApp :: RegistryCtx -> IO ()
 shutdownApp _ = return ()
 
 ---------------------------------------------

src/Foundation.hs

@@ -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
+-- type Handler = HandlerT RegistryCtx IO
-mkYesodData "AgentCtx" $(parseRoutesFile "config/routes")
+mkYesodData "RegistryCtx" $(parseRoutesFile "config/routes")
 
 -- Please see the documentation for the Yesod typeclass. There are a number
 -- 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
+        return $ appShouldLogAll (appSettings app) || level == LevelInfo || level == LevelWarn || level == LevelError
-            $  appShouldLogAll (appSettings app)
-            || level
-            == LevelInfo
-            || level
-            == LevelWarn
-            || level
-            == LevelError
 
-    makeLogger :: AgentCtx -> IO Logger
+    makeLogger :: RegistryCtx -> IO Logger
     makeLogger = return . appLogger
 
 -- How to run database actions.
-instance YesodPersist AgentCtx where
+instance YesodPersist RegistryCtx where
-    type YesodPersistBackend AgentCtx = SqlBackend
+    type YesodPersistBackend RegistryCtx = SqlBackend
     runDB :: SqlPersistT Handler a -> Handler a
     runDB action = runSqlPool action . appConnPool =<< getYesod
 
-instance YesodPersistRunner AgentCtx where
+instance YesodPersistRunner RegistryCtx where
-    getDBRunner :: Handler (DBRunner AgentCtx, Handler ())
+    getDBRunner :: Handler (DBRunner RegistryCtx, Handler ())
     getDBRunner = defaultGetDBRunner appConnPool
 
 
-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 :: RegistryCtx -> LogFunc
 appLogFunc = appLogger >>= flip messageLoggerSource

src/Handler/Apps.hs

@@ -28,8 +28,12 @@ import           Lib.Semver
 import           Lib.Types.Semver
 import           Lib.Types.FileSystem
 import           Lib.Error
-import           System.FilePath      ((<.>), (</>))
+import           System.FilePath                ( (<.>)
-import           System.Posix.Files   (fileSize, getFileStatus)
+                                                , (</>)
+                                                )
+import           System.Posix.Files             ( fileSize
+                                                , getFileStatus
+                                                )
 import           Settings
 import           Database.Queries
 import qualified Data.HashMap.Strict           as HM
@@ -77,7 +81,7 @@ getApp rootDir ext@(Extension appId) = do
                 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
@@ -86,13 +90,13 @@ getApp rootDir ext@(Extension appId) = do
         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
@@ -109,14 +113,18 @@ recordMetrics appId rootDir appVersion = do
     (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"
+            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

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
@@ -24,8 +25,7 @@ setupSsl AppSettings{..} = do
         void selfSignSslCert
     where
         checkForSslCert :: IO Bool
-        checkForSslCert =
+        checkForSslCert = doesPathExist sslKeyLocation <&&> doesPathExist sslCertLocation
-            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"
+            ["x509", "-req", "-in", sslCsrLocation, "-signkey", sslKeyLocation, "-out", sslCertLocation]
-            , "-req"
+
-            , "-in"
+doesSslNeedRenew :: FilePath -> IO Bool
-            , sslCsrLocation
+doesSslNeedRenew cert = do
-            , "-signkey"
+    ec <- liftIO $ system [i|openssl x509 -checkend 2592000 -noout -in #{cert}|]
-            , sslKeyLocation
+    pure $ ec /= ExitSuccess
-            , "-out"
+
-            , sslCertLocation
+renewSslCerts :: FilePath -> IO ()
-            ]
+renewSslCerts cert = do
+    void . liftIO $ system [i|certbot renew|]
+    void . liftIO $ system [i|cp /etc/letsencrypt/live/beta-registry.start9labs.com/fullchain.pem #{cert}|]

src/Settings.hs

@@ -19,7 +19,9 @@ 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           Yesod.Default.Config2          ( applyEnvValue
+                                                , configSettingsYml
+                                                )
 import           Paths_start9_registry          ( version )
 import           Lib.Types.Semver
 import           System.FilePath                ( (</>) )
@@ -79,13 +81,11 @@ configSettingsYmlBS = $(embedFile configSettingsYml)
 
 -- | @config/settings.yml@, parsed to a @Value@.
 configSettingsYmlValue :: Value
-configSettingsYmlValue =
+configSettingsYmlValue = either Exception.throw id $ decodeEither' configSettingsYmlBS
-    either Exception.throw id $ decodeEither' configSettingsYmlBS
 
 -- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@.
 compileTimeAppSettings :: AppSettings
-compileTimeAppSettings =
+compileTimeAppSettings = case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
-    case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
     Error   e        -> panic $ toS e
     Success settings -> settings
 

test/TestImport.hs

@@ -5,13 +5,18 @@
 module TestImport
     ( module TestImport
     , module X
-    ) where
+    )
+where
 
 import           Startlude
-import Application           (makeFoundation, makeLogWare)
+import           Application                    ( makeFoundation
+                                                , makeLogWare
+                                                )
 import           Foundation                    as X
 import           Test.Hspec                    as X
-import Yesod.Default.Config2 (useEnv, loadYamlSettings)
+import           Yesod.Default.Config2          ( useEnv
+                                                , loadYamlSettings
+                                                )
 import           Yesod.Test                    as X
 import           Yesod.Core.Unsafe              ( fakeHandlerGetLogger )
 import           Database.Persist.Sql
@@ -19,17 +24,14 @@ 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
+    settings   <- loadYamlSettings ["config/settings.yml"] [] useEnv
-        ["config/settings.yml"]
-        []
-        useEnv
     foundation <- makeFoundation settings
     wipeDB foundation
     logWare <- liftIO $ makeLogWare foundation
@@ -37,16 +39,18 @@ 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
     sqlBackend <- ask
@@ -55,14 +59,13 @@ wipeDB app = runDBWithApp app $ do
         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 :: * -> *).
+type DB a = forall (m :: * -> *) . (MonadUnliftIO m) => ReaderT SqlBackend m a
-    (MonadUnliftIO m) => ReaderT SqlBackend m a