Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-26 02:11:53 +00:00
Code Issues Packages Projects Releases Wiki Activity

autorenews certificates

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

60
brittany.yaml Normal file
View File

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

1
package.yaml
View File

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

42
src/Application.hs
View File

@@ -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)
shutdownApp :: AgentCtx -> IO ()
shutdownApp :: RegistryCtx -> IO ()
shutdownApp _ = return ()
---------------------------------------------

41
src/Foundation.hs
View File

@@ -8,13 +8,13 @@ module Foundation where
import Startlude
import Control.Monad.Logger (LogSource)
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 Yesod.Core.Types ( Logger )
import qualified Yesod.Core.Unsafe as Unsafe
import Lib.Types.Semver
@@ -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 :: RegistryCtx -> LogFunc
appLogFunc = appLogger >>= flip messageLoggerSource

26
src/Handler/Apps.hs
View File

@@ -16,7 +16,7 @@ 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 GHC.Show ( Show(..) )
import Network.HTTP.Types
import System.Directory
import Yesod.Core
@@ -28,8 +28,12 @@ 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
@@ -43,7 +47,7 @@ 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
@@ -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

26
src/Lib/Ssl.hs
View File

@@ -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
]
["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}|]

32
src/Settings.hs
View File

@@ -10,19 +10,21 @@ module Settings where
import Startlude
import qualified Control.Exception as Exception
import Control.Monad.Fail (fail)
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 System.FilePath ( (</>) )
import qualified Data.HashMap.Strict as HM
import Data.Yaml.Config
@@ -79,13 +81,11 @@ 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
compileTimeAppSettings = case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
Error e -> panic $ toS e
Success settings -> settings
@@ -118,8 +118,8 @@ instance FromJSON AppManifest where
storeAppDescLong <- config .: "description" >>= (.: "long")
storeAppVersionInfo <- config .: "version-info" >>= \case
[] -> fail "No Valid Version Info"
(x:xs) -> pure $ x :| xs
return $ (appId, StoreApp {..})
(x : xs) -> pure $ x :| xs
return $ (appId, StoreApp { .. })
return $ AppManifest (HM.fromList apps)
data VersionInfo = VersionInfo
@@ -131,4 +131,4 @@ instance FromJSON VersionInfo where
parseJSON = withObject "version info" $ \o -> do
versionInfoVersion <- o .: "version"
versionInfoReleaseNotes <- o .: "release-notes"
pure VersionInfo {..}
pure VersionInfo { .. }

39
test/TestImport.hs
View File

@@ -5,31 +5,33 @@
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 Yesod.Core.Unsafe ( fakeHandlerGetLogger )
import Database.Persist.Sql
import Text.Shakespeare.Text (st)
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,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 :: * -> *).
(MonadUnliftIO m) => ReaderT SqlBackend m a
type DB a = forall (m :: * -> *) . (MonadUnliftIO m) => ReaderT SqlBackend m a