Deployment tweaks (working socket activation)

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:"

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

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

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

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

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"
+      if
-      migrateAll `runSqlPool` sqlPool
+        | 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
+        Just socks
-          $logInfoS "bind" [st|Ignoring configuration and listening on #{tshow (fmap snd socks)}|]
+          | not $ null socks -> do
-          return $ fst <$> socks
+            $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"

src/Jobs.hs

@@ -99,17 +99,18 @@ handleJobs foundation@UniWorX{..} = do
     atomically . modifyTVar' appJobCtl $ Map.insert tId bChan
 
   -- Start cron operation
-  registeredCron <- liftIO newEmptyTMVarIO
+  when (num > 0) $ do
-  let execCrontab' = whenM (atomically $ readTMVar registeredCron) $
+    registeredCron <- liftIO newEmptyTMVarIO
-        unsafeHandler foundation $ runReaderT execCrontab JobContext{..}
+    let execCrontab' = whenM (atomically $ readTMVar registeredCron) $
-      unregister = atomically . whenM (fromMaybe False <$> tryReadTMVar registeredCron) . void $ tryTakeTMVar appCronThread
+          unsafeHandler foundation $ runReaderT execCrontab JobContext{..}
-  cData <- allocate (liftIO . forkFinally execCrontab' $ \_ -> unregister) (\_ -> liftIO . atomically . void $ tryTakeTMVar jobCrontab)
+        unregister = atomically . whenM (fromMaybe False <$> tryReadTMVar registeredCron) . void $ tryTakeTMVar appCronThread
-  registeredCron' <- atomically $ do
+    cData <- allocate (liftIO . forkFinally execCrontab' $ \_ -> unregister) (\_ -> liftIO . atomically . void $ tryTakeTMVar jobCrontab)
-    registeredCron' <- tryPutTMVar appCronThread cData
+    registeredCron' <- atomically $ do
-    registeredCron' <$ putTMVar registeredCron registeredCron'
+      registeredCron' <- tryPutTMVar appCronThread cData
-  when registeredCron' $
+      registeredCron' <$ putTMVar registeredCron registeredCron'
-    liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $
+    when registeredCron' $
-      writeJobCtlBlock JobCtlDetermineCrontab
+      liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $
+        writeJobCtlBlock JobCtlDetermineCrontab
 
 stopJobCtl :: MonadIO m => UniWorX -> m ()
 -- ^ Stop all worker threads currently running

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
+  mapM_ ($logInfoS "Migration") =<< runMigrationSilent initialMigration
-    -- Manual migrations to go to InitialVersion below:
-    migrateEnableExtension "citext"
 
-    migrateDBVersioning
+  missingMigrations <- getMissingMigrations
-
-  $logDebugS "Migration" "Retrieve applied migrations"
-  appliedMigrations <- selectKeysList [] []
   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.

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

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

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 ['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 ['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 ['m'] ["migrate"]  (NoArg DBMigrate)  "Perform database migration"
-  , Option ['f'] ["fill"]    (NoArg DBFill)     "Fill database with example data"
+  , Option ['f'] ["fill"]     (NoArg DBFill)     "Fill database with example data"
   ]