From 2874d7a8477b8cabc72b970d3b28c0112704b2b2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 11 May 2019 20:14:59 +0200 Subject: [PATCH] Deployment tweaks (working socket activation) --- config/settings.yml | 2 ++ models/courses | 2 +- models/tutorials | 2 +- models/users | 4 ++-- package.yaml | 2 +- src/Application.hs | 22 +++++++++++++----- src/Jobs.hs | 23 ++++++++++--------- src/Model/Migration.hs | 52 +++++++++++++++++++++++++++++++++++------- src/Settings.hs | 2 ++ stack.yaml | 6 +++-- test/Database.hs | 8 +++---- 11 files changed, 89 insertions(+), 36 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 592b09ca1..049692e5b 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -64,6 +64,8 @@ database: database: "_env:PGDATABASE:uniworx" poolsize: "_env:PGPOOLSIZE:10" +auto-db-migrate: '_env:AUTO_DB_MIGRATE:true' + ldap: host: "_env:LDAPHOST:" tls: "_env:LDAPTLS:" diff --git a/models/courses b/models/courses index 4fcf67d65..5be19103a 100644 --- a/models/courses +++ b/models/courses @@ -33,7 +33,7 @@ CourseFavourite -- which user accessed which course when, only display Lecturer -- course ownership user UserId course CourseId - type LecturerType default='"lecturer"' + type LecturerType default='"lecturer"'::jsonb UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table CourseParticipant -- course enrolement course CourseId diff --git a/models/tutorials b/models/tutorials index 78571389c..444d988cd 100644 --- a/models/tutorials +++ b/models/tutorials @@ -9,7 +9,7 @@ Tutorial json registerFrom UTCTime Maybe registerTo UTCTime Maybe deregisterUntil UTCTime Maybe - lastChanged UTCTime default='NOW()' + lastChanged UTCTime default=now() UniqueTutorial course name Tutor tutorial TutorialId diff --git a/models/users b/models/users index cd08164d1..f0b3e683e 100644 --- a/models/users +++ b/models/users @@ -22,7 +22,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this) - mailLanguages MailLanguages default='[]' -- Preferred language for eMail; i18n not yet implemented; user-defined + mailLanguages MailLanguages "default='[]'::jsonb" -- Preferred language for eMail; i18n not yet implemented; user-defined notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table @@ -41,7 +41,7 @@ StudyFeatures -- multiple entries possible for students pursuing several degree field StudyTermsId -- Fach, i.e. Informatics, Philosophy, etc. type StudyFieldType -- Major or minor, i.e. Haupt-/Nebenfach semester Int - updated UTCTime default='NOW()' -- last update from LDAP + updated UTCTime default=now() -- last update from LDAP valid Bool default=true -- marked as active in LDAP (students may switch, but LDAP never forgets) UniqueStudyFeatures user degree field type semester -- UniqueUserSubject ubuser degree field -- There exists a counterexample diff --git a/package.yaml b/package.yaml index 4edc4d864..5dd414b33 100644 --- a/package.yaml +++ b/package.yaml @@ -197,7 +197,7 @@ when: library: source-dirs: src when: - - condition: (flag(dev)) || (flag(library-only)) + - condition: flag(dev) then: ghc-options: - -O0 diff --git a/src/Application.hs b/src/Application.hs index cc8843303..675c11d92 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -70,7 +70,7 @@ import Data.Proxy import qualified Data.Aeson as Aeson -import System.Exit (exitFailure) +import System.Exit import qualified Database.Memcached.Binary.IO as Memcached @@ -81,6 +81,8 @@ import System.Posix.Process (getProcessID) import Control.Monad.Trans.State (execStateT) +import Network (socketPort) + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common @@ -192,8 +194,13 @@ makeFoundation appSettings'@AppSettings{..} = do createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) -- Perform database migration using our application's logging settings. - $logDebugS "setup" "Migration" - migrateAll `runSqlPool` sqlPool + if + | appAutoDbMigrate -> do + $logDebugS "setup" "Migration" + migrateAll `runSqlPool` sqlPool + | otherwise -> whenM (requiresMigration `runSqlPool` sqlPool) $ do + $logErrorS "setup" "Migration required" + liftIO . exitWith $ ExitFailure 2 $logDebugS "setup" "Cluster-Config" appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool @@ -385,9 +392,10 @@ appMain = runResourceT $ do -- Run the application with Warp activatedSockets <- liftIO Systemd.getActivatedSocketsWithNames sockets <- case activatedSockets of - Just socks@(_ : _) -> do - $logInfoS "bind" [st|Ignoring configuration and listening on #{tshow (fmap snd socks)}|] - return $ fst <$> socks + Just socks + | not $ null socks -> do + $logInfoS "bind" [st|Ignoring configuration and listening on #{intercalate ", " (fmap (tshow . snd) socks)}|] + return $ fst <$> socks _other -> do let host = foundation ^. _appHost @@ -395,6 +403,8 @@ appMain = runResourceT $ do $logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|] liftIO $ pure <$> bindPortTCP port host + $logDebugS "bind" . tshow =<< mapM (liftIO . socketPort) sockets + let runWarp socket = runSettingsSocket (warpSettings foundation) socket app case sockets of [] -> $logErrorS "bind" "No sockets to listen on" diff --git a/src/Jobs.hs b/src/Jobs.hs index 641d3e100..efbe126b6 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -99,17 +99,18 @@ handleJobs foundation@UniWorX{..} = do atomically . modifyTVar' appJobCtl $ Map.insert tId bChan -- Start cron operation - registeredCron <- liftIO newEmptyTMVarIO - let execCrontab' = whenM (atomically $ readTMVar registeredCron) $ - unsafeHandler foundation $ runReaderT execCrontab JobContext{..} - unregister = atomically . whenM (fromMaybe False <$> tryReadTMVar registeredCron) . void $ tryTakeTMVar appCronThread - cData <- allocate (liftIO . forkFinally execCrontab' $ \_ -> unregister) (\_ -> liftIO . atomically . void $ tryTakeTMVar jobCrontab) - registeredCron' <- atomically $ do - registeredCron' <- tryPutTMVar appCronThread cData - registeredCron' <$ putTMVar registeredCron registeredCron' - when registeredCron' $ - liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $ - writeJobCtlBlock JobCtlDetermineCrontab + when (num > 0) $ do + registeredCron <- liftIO newEmptyTMVarIO + let execCrontab' = whenM (atomically $ readTMVar registeredCron) $ + unsafeHandler foundation $ runReaderT execCrontab JobContext{..} + unregister = atomically . whenM (fromMaybe False <$> tryReadTMVar registeredCron) . void $ tryTakeTMVar appCronThread + cData <- allocate (liftIO . forkFinally execCrontab' $ \_ -> unregister) (\_ -> liftIO . atomically . void $ tryTakeTMVar jobCrontab) + registeredCron' <- atomically $ do + registeredCron' <- tryPutTMVar appCronThread cData + registeredCron' <$ putTMVar registeredCron registeredCron' + when registeredCron' $ + liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $ + writeJobCtlBlock JobCtlDetermineCrontab stopJobCtl :: MonadIO m => UniWorX -> m () -- ^ Stop all worker threads currently running diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 6f6970ac3..f55638835 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -1,5 +1,6 @@ module Model.Migration ( migrateAll + , requiresMigration ) where import ClassyPrelude.Yesod @@ -23,6 +24,10 @@ import Data.CaseInsensitive (CI) import Text.Shakespeare.Text (st) +import Control.Monad.Trans.Reader (mapReaderT) +import Control.Monad.Except (MonadError(..)) +import Utils (exceptT) + -- Database versions must follow https://pvp.haskell.org: -- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format) -- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table) @@ -55,16 +60,10 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"] migrateAll :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m () migrateAll = do $logDebugS "Migration" "Initial migration" - mapM_ ($logInfoS "Migration") <=< runMigrationSilent $ do - -- Manual migrations to go to InitialVersion below: - migrateEnableExtension "citext" + mapM_ ($logInfoS "Migration") =<< runMigrationSilent initialMigration - migrateDBVersioning - - $logDebugS "Migration" "Retrieve applied migrations" - appliedMigrations <- selectKeysList [] [] + missingMigrations <- getMissingMigrations let - missingMigrations = customMigrations `Map.withoutKeys` Set.fromList appliedMigrations doCustomMigration acc desc migration = acc <* do let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc $logInfoS "Migration" [st|#{tshow appliedMigrationFrom} -> #{tshow appliedMigrationTo}|] @@ -78,6 +77,43 @@ migrateAll = do $logDebugS "Migration" "Persistent automatic migration" mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll' +requiresMigration :: forall m. (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m Bool +requiresMigration = mapReaderT (exceptT return return) $ do + initial <- getMigration initialMigration + when (not $ null initial) $ do + $logInfoS "Migration" $ intercalate "; " initial + throwError True + + customs <- getMissingMigrations @_ @m + when (not $ Map.null customs) $ do + $logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs + throwError True + + automatic <- getMigration migrateAll' + when (not $ null automatic) $ do + $logInfoS "Migration" $ intercalate "; " automatic + throwError True + + return False + +initialMigration :: Migration +-- ^ Manual migrations to go to InitialVersion below: +initialMigration = do + migrateEnableExtension "citext" + migrateDBVersioning + +getMissingMigrations :: forall m m'. + ( MonadLogger m + , MonadBaseControl IO m + , MonadIO m + , MonadIO m' + ) + => ReaderT SqlBackend m (Map (Key AppliedMigration) (ReaderT SqlBackend m' ())) +getMissingMigrations = do + $logDebugS "Migration" "Retrieve applied migrations" + appliedMigrations <- selectKeysList [] [] + return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations + {- Confusion about quotes, from the PostgreSQL Manual: Single quotes for string constants, double quotes for table/column names. diff --git a/src/Settings.hs b/src/Settings.hs index d9798caea..06b2fa836 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -77,6 +77,7 @@ data AppSettings = AppSettings -- ^ Directory from which to serve static files. , appDatabaseConf :: PostgresConf -- ^ Configuration settings for accessing the database. + , appAutoDbMigrate :: Bool , appLdapConf :: Maybe LdapConf -- ^ Configuration settings for accessing the LDAP-directory , appSmtpConf :: Maybe SmtpConf @@ -345,6 +346,7 @@ instance FromJSON AppSettings where #endif appStaticDir <- o .: "static-dir" appDatabaseConf <- o .: "database" + appAutoDbMigrate <- o .: "auto-db-migrate" let nonEmptyHost LdapConf{..} = case ldapHost of Ldap.Tls host _ -> not $ null host Ldap.Plain host -> not $ null host diff --git a/stack.yaml b/stack.yaml index df8eb7fb3..b6c31fd66 100644 --- a/stack.yaml +++ b/stack.yaml @@ -21,6 +21,10 @@ packages: git: https://github.com/pngwjpgh/memcached-binary.git commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad extra-dep: true + - location: + git: https://github.com/pngwjpgh/systemd.git + commit: 53d7ce6bd241ed4bedd25f1ae9383fd1856f9b77 + extra-dep: true extra-deps: - colonnade-1.2.0 @@ -49,6 +53,4 @@ extra-deps: - quickcheck-classes-0.4.14 - semirings-0.2.1.1 - - systemd-1.1.2 - resolver: lts-10.5 diff --git a/test/Database.hs b/test/Database.hs index 7281036f3..5f9140cb0 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -33,10 +33,10 @@ data DBAction = DBClear argsDescr :: [OptDescr DBAction] argsDescr = - [ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user" - , Option ['t'] ["truncate"] (NoArg DBTruncate) "Truncate all tables mentioned in the current schema (This cannot be run concurrently with any other activity accessing the database)" - , Option ['m'] ["migrate"] (NoArg DBMigrate) "Perform database migration" - , Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data" + [ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user" + , Option ['t'] ["truncate"] (NoArg DBTruncate) "Truncate all tables mentioned in the current schema (This cannot be run concurrently with any other activity accessing the database)" + , Option ['m'] ["migrate"] (NoArg DBMigrate) "Perform database migration" + , Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data" ]