diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 4d0be8c42..ca9cab2a8 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -771,8 +771,8 @@ DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entspreche DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeilen sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde -MassInputAddDimension: Hinzufügen -MassInputDeleteCell: Entfernen +MassInputAddDimension: + +MassInputDeleteCell: - NavigationFavourites: Favoriten @@ -786,6 +786,7 @@ CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt CommCourseHeading: Kursmitteilung RecipientCustom: Weitere Empfänger +RecipientToggleAll: Alle/Keine RGCourseParticipants: Kursteilnehmer RGCourseLecturers: Kursverwalter @@ -803,4 +804,4 @@ CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu CorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor für #{shn} eingetragen CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor für #{shn} zu werden, abgelehnt SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn} -SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein. \ No newline at end of file +SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein. diff --git a/package.yaml b/package.yaml index 47917503c..470e510db 100644 --- a/package.yaml +++ b/package.yaml @@ -121,6 +121,9 @@ dependencies: - jose-jwt - mono-traversable - lens-aeson + - systemd + - lifted-async + - streaming-commons other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Application.hs b/src/Application.hs index e1dc1904e..97b671868 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -24,8 +24,10 @@ import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware) import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, - runSettings, setHost, + runSettingsSocket, setHost, + setBeforeMainLoop, setOnException, setPort, getPort) +import Data.Streaming.Network (bindPortTCP) import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (..), OutputFormat (..), destination, @@ -72,6 +74,9 @@ import System.Exit (exitFailure) import qualified Database.Memcached.Binary.IO as Memcached +import qualified System.Systemd.Daemon as Systemd +import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel) + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common @@ -160,22 +165,31 @@ makeFoundation appSettings'@AppSettings{..} = do f loc src lvl str flip runLoggingT logFunc $ do - $logDebugS "InstanceID" $ UUID.toText appInstanceID + $logInfoS "InstanceID" $ UUID.toText appInstanceID -- logDebugS "Configuration" $ tshow appSettings' - smtpPool <- traverse createSmtpPool appSmtpConf + smtpPool <- for appSmtpConf $ \c -> do + $logDebugS "setup" "SMTP-Pool" + createSmtpPool c - appWidgetMemcached <- traverse createWidgetMemcached appWidgetMemcachedConf + appWidgetMemcached <- for appWidgetMemcachedConf $ \c -> do + $logDebugS "setup" "Widget-Memcached" + createWidgetMemcached c -- Create the database connection pool + $logDebugS "setup" "PostgreSQL-Pool" sqlPool <- createPostgresqlPool (pgConnStr appDatabaseConf) (pgPoolSize appDatabaseConf) - ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) + ldapPool <- for appLdapConf $ \LdapConf{..} -> do + $logDebugS "setup" "LDAP-Pool" + 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 + $logDebugS "setup" "Cluster-Config" appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool @@ -183,9 +197,11 @@ makeFoundation appSettings'@AppSettings{..} = do let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet + $logDebugS "setup" "Job-Handling" handleJobs foundation -- Return the foundation + $logDebugS "setup" "Done" return foundation clusterSetting :: forall key m p. @@ -290,8 +306,9 @@ makeLogWare app = do -- | Warp settings for the given foundation value. warpSettings :: UniWorX -> Settings warpSettings foundation = defaultSettings - & setPort (foundation ^. _appPort) + & setBeforeMainLoop (void Systemd.notifyReady) & setHost (foundation ^. _appHost) + & setPort (foundation ^. _appPort) & setOnException (\_req e -> when (defaultShouldDisplayException e) $ do logger <- readTVarIO . snd $ appLogger foundation @@ -335,11 +352,29 @@ appMain = runResourceT $ do -- Generate the foundation from the settings foundation <- makeFoundation settings - -- Generate a WAI Application from the foundation - app <- makeApplication foundation + let logFunc loc src lvl str = do + f <- messageLoggerSource foundation <$> readTVarIO (snd $ foundation ^. _appLogger) + f loc src lvl str - -- Run the application with Warp - liftIO $ runSettings (warpSettings foundation) app + flip runLoggingT logFunc $ do + -- Generate a WAI Application from the foundation + app <- makeApplication foundation + + -- 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 $ fmap fst socks + _other -> do + let + host = foundation ^. _appHost + port = foundation ^. _appPort + $logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|] + liftIO $ pure <$> bindPortTCP port host + + let runWarp socket = runSettingsSocket (warpSettings foundation) socket app + liftIO $ void . waitAnyCancel =<< mapM (async . runWarp) sockets -------------------------------------------------------------- diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 5697b7bd4..4c1d7a153 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -553,7 +553,7 @@ courseEditHandler miButtonAction mbCourseForm = do case insertRes of Just _ -> queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy - Nothing -> + Nothing -> updateBy (UniqueLecturerInvitation lEmail cid) [ LecturerInvitationType =. mLTy ] insert_ $ CourseEdit aid now cid addMessageI Success $ MsgCourseEditOk tid ssh csh @@ -803,8 +803,9 @@ userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity Us userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures) = do -- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures - E.on $ E.just (participant E.^. CourseParticipantUser) E.==. note E.?. CourseUserNoteUser - E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId + E.on $ (note E.?. CourseUserNoteUser E.==. E.just (participant E.^. CourseParticipantUser)) + E.&&. (note E.?. CourseUserNoteCourse E.==. E.just (E.val cid)) + E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, features) @@ -1130,7 +1131,7 @@ postCCommR tid ssh csh = do evalAccessDB (CourseR tid ssh csh $ CUserR cID) False } - + data ButtonLecInvite = BtnLecInvAccept | BtnLecInvDecline deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ButtonLecInvite diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 81ca65bd4..ce39f6300 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -727,6 +727,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db isSortable = isJust sortableKey isSorted = (`elem` directions) attrs = sortableContent ^. cellAttrs + piSorting' = [ sSet | sSet <- fromMaybe [] piSorting, Just (sortKey sSet) /= sortableKey ] return $(widgetFile "table/cell/header") columnCount :: Int64 diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index b8d960301..c111e2412 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -21,6 +21,8 @@ import Database.Persist.Postgresql import Text.Read (readMaybe) import Data.CaseInsensitive (CI) +import Text.Shakespeare.Text (st) + -- 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) @@ -52,23 +54,28 @@ 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" migrateDBVersioning - appliedMigrations <- map entityKey <$> selectList [] [] + $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}|] appliedMigrationTime <- liftIO getCurrentTime _ <- migration insert AppliedMigration{..} -- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey + $logDebugS "Migration" "Apply missing migrations" Map.foldlWithKey doCustomMigration (return ()) missingMigrations + $logDebugS "Migration" "Persistent automatic migration" mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll' {- diff --git a/stack.yaml b/stack.yaml index 94be126d8..df8eb7fb3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -49,4 +49,6 @@ extra-deps: - quickcheck-classes-0.4.14 - semirings-0.2.1.1 + - systemd-1.1.2 + resolver: lts-10.5 diff --git a/static/css/utils/checkbox.scss b/static/css/utils/checkbox.scss index 9a73b01e7..6db7f97e3 100644 --- a/static/css/utils/checkbox.scss +++ b/static/css/utils/checkbox.scss @@ -74,3 +74,9 @@ filter: grayscale(1); } } + +/* special treatment for checkboxes in table headers */ +th .checkbox { + margin-right: 7px; + vertical-align: bottom; +} diff --git a/static/js/utils/checkAll.js b/static/js/utils/checkAll.js index 86749f2a9..5a15e0ac7 100644 --- a/static/js/utils/checkAll.js +++ b/static/js/utils/checkAll.js @@ -96,9 +96,9 @@ checkAllCheckbox.setAttribute('id', getCheckboxId()); th.insertBefore(checkAllCheckbox, th.firstChild); - // manually set up newly created checkbox + // manually set up new checkbox if (UtilRegistry) { - UtilRegistry.setup(UtilRegistry.find('checkbox')); + UtilRegistry.setup(UtilRegistry.find('checkbox'), th); } checkAllCheckbox.addEventListener('input', onCheckAllCheckboxInput); diff --git a/templates/table/cell/header.hamlet b/templates/table/cell/header.hamlet index 5322aef4d..408dc4561 100644 --- a/templates/table/cell/header.hamlet +++ b/templates/table/cell/header.hamlet @@ -2,10 +2,10 @@ $maybe flag <- sortableKey $case directions $of [SortAsc] - + ^{widget} $of _ - + ^{widget} $nothing ^{widget} diff --git a/templates/widgets/communication/recipientLayout.hamlet b/templates/widgets/communication/recipientLayout.hamlet index c52ff534d..5f47cb7b7 100644 --- a/templates/widgets/communication/recipientLayout.hamlet +++ b/templates/widgets/communication/recipientLayout.hamlet @@ -1,14 +1,22 @@ $newline never -$forall category <- activeCategories -
- -