merge master

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.
+SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein.

package.yaml

@@ -121,6 +121,9 @@ dependencies:
   - jose-jwt
   - mono-traversable
   - lens-aeson
+  - systemd
+  - lifted-async
+  - streaming-commons
 
 other-extensions:
   - GeneralizedNewtypeDeriving

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

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

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

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'
 
 {-

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

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;
+}

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);

templates/table/cell/header.hamlet

@@ -2,10 +2,10 @@
   $maybe flag <- sortableKey
     $case directions
       $of [SortAsc]
-        <a .table__th-link href=^{tblLink' $ setParam (wIdent "sorting") (Just $ toPathPiece (SortingSetting flag SortDesc))}>
+        <a .table__th-link href=^{tblLink' $ setParams (wIdent "sorting") (map toPathPiece (SortingSetting flag SortDesc : piSorting'))}>
           ^{widget}
       $of _
-        <a .table__th-link href=^{tblLink' $ setParam (wIdent "sorting") (Just $ toPathPiece (SortingSetting flag SortAsc))}>
+        <a .table__th-link href=^{tblLink' $ setParams (wIdent "sorting") (map toPathPiece (SortingSetting flag SortAsc : piSorting'))}>
           ^{widget}
   $nothing
     ^{widget}

templates/widgets/communication/recipientLayout.hamlet

@@ -1,14 +1,22 @@
 $newline never
-$forall category <- activeCategories
-  <div .recipient-category>
-    <input type=checkbox id=#{checkedIdent category} :elem category checkedCategories:checked>
-    <label .recipient-category__label for=#{checkedIdent category}>
-      _{category}
+$if not (null activeCategories)
+  <div .recipient-categories>
+    $forall category <- activeCategories
+      <div .recipient-category>
+        <input type=checkbox id=#{checkedIdent category} .recipient-category__checkbox :elem category checkedCategories:checked>
+        <label .recipient-category__label for=#{checkedIdent category}>
+          _{category}
 
-    $if hasContent category
-      <fieldset .recipient-category__fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{checkedIdent category}>
-        $forall optIx <- categoryIndices category
-          ^{cellWdgts ! optIx}
+        $if hasContent category
+          <fieldset .recipient-category__fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{checkedIdent category}>
+            $if not (null (categoryIndices category))
+              <div .recipient-category__checked-counter>
+              <div .recipient-category__toggle-all>
+                <input type=checkbox id=#{checkedIdent category}-toggle-all>
+                <label for=#{checkedIdent category}-toggle-all .recipient-category__option-label>_{MsgRecipientToggleAll}
+              <div .recipient-category__options>
+                $forall optIx <- categoryIndices category
+                  ^{cellWdgts ! optIx}
 
-        $maybe addWdgt <- addWdgts !? (1, (EnumPosition category, 0))
-          ^{addWdgt}
+            $maybe addWdgt <- addWdgts !? (1, (EnumPosition category, 0))
+              ^{addWdgt}

templates/widgets/communication/recipientLayout.julius

@@ -0,0 +1,87 @@
+(function() {
+
+  var MASS_INPUT_SELECTOR = '.massinput';
+  var RECIPIENT_CATEGORIES_SELECTOR = '.recipient-categories';
+  var RECIPIENT_CATEGORY_SELECTOR = '.recipient-category';
+  var RECIPIENT_CATEGORY_CHECKBOX_SELECTOR = '.recipient-category__checkbox ';
+  var RECIPIENT_CATEGORY_OPTIONS_SELECTOR = '.recipient-category__options';
+  var RECIPIENT_CATEGORY_TOGGLE_ALL_SELECTOR = '.recipient-category__toggle-all [type="checkbox"]';
+  var RECIPIENT_CATEGORY_CHECKED_COUNTER_SELECTOR = '.recipient-category__checked-counter';
+
+  var massInputElement;
+
+  document.addEventListener('DOMContentLoaded', function() {
+    var recipientCategoriesElement = document.querySelector(RECIPIENT_CATEGORIES_SELECTOR);
+    massInputElement = recipientCategoriesElement.closest(MASS_INPUT_SELECTOR);
+
+    setupRecipientCategories();
+
+    var recipientObserver = new MutationObserver(setupRecipientCategories);
+    recipientObserver.observe(massInputElement, { childList: true });
+  });
+
+  function setupRecipientCategories() {
+    var recipientCategoryElements = Array.from(massInputElement.querySelectorAll(RECIPIENT_CATEGORY_SELECTOR));
+
+    recipientCategoryElements.forEach(function(element) {
+      setupRecipientCategory(element);
+    });
+  }
+
+  function setupRecipientCategory(recipientCategoryElement) {
+    var categoryCheckbox = recipientCategoryElement.querySelector(RECIPIENT_CATEGORY_CHECKBOX_SELECTOR);
+    var categoryOptions = recipientCategoryElement.querySelector(RECIPIENT_CATEGORY_OPTIONS_SELECTOR);
+    if (categoryOptions) {
+
+      var categoryCheckboxes = Array.from(categoryOptions.querySelectorAll('[type="checkbox"]'));
+      var toggleAllCheckbox = recipientCategoryElement.querySelector(RECIPIENT_CATEGORY_TOGGLE_ALL_SELECTOR);
+
+      // setup category checkbox to toggle all child checkboxes if changed
+      categoryCheckbox.addEventListener('change', function() {
+        categoryCheckboxes.forEach(function(checkbox) {
+          checkbox.checked = categoryCheckbox.checked;
+        });
+        updateCheckedCounter(recipientCategoryElement, categoryCheckboxes);
+        updateToggleAllCheckbox(toggleAllCheckbox, categoryCheckboxes);
+      });
+
+      // update counter and toggle checkbox initially
+      updateCheckedCounter(recipientCategoryElement, categoryCheckboxes);
+      updateToggleAllCheckbox(toggleAllCheckbox, categoryCheckboxes);
+
+      // register change listener for individual checkboxes
+      categoryCheckboxes.forEach(function(checkbox) {
+        checkbox.addEventListener('change', function() {
+          updateCheckedCounter(recipientCategoryElement, categoryCheckboxes);
+          updateToggleAllCheckbox(toggleAllCheckbox, categoryCheckboxes);
+        });
+      });
+
+      // register change listener for toggle all checkbox
+      if (toggleAllCheckbox) {
+        toggleAllCheckbox.addEventListener('change', function() {
+          categoryCheckboxes.forEach(function(checkbox) {
+            checkbox.checked = toggleAllCheckbox.checked;
+          });
+          updateCheckedCounter(recipientCategoryElement, categoryCheckboxes);
+        });
+      }
+    }
+  }
+
+  // update checked state of toggle all checkbox based on all other checkboxes
+  function updateToggleAllCheckbox(toggleAllCheckbox, categoryCheckboxes) {
+    var allChecked = categoryCheckboxes.reduce(function(acc, checkbox) {
+      return acc && checkbox.checked;
+    }, true);
+    toggleAllCheckbox.checked = allChecked;
+  }
+
+  // update value of checked counter
+  function updateCheckedCounter(recipientCategoryElement, categoryCheckboxes) {
+    var checkedCounter = recipientCategoryElement.querySelector(RECIPIENT_CATEGORY_CHECKED_COUNTER_SELECTOR);
+    var checkedCheckboxes = categoryCheckboxes.reduce(function(acc, checkbox) { return checkbox.checked ? acc + 1 : acc; }, 0);
+    checkedCounter.innerHTML = checkedCheckboxes + '/' + categoryCheckboxes.length;
+  }
+
+})();

templates/widgets/communication/recipientLayout.lucius

@@ -11,6 +11,11 @@
   }
 }
 
+.recipient-category__options {
+  max-height: 150px;
+  overflow-y: auto;
+}
+
 .recipient-category__option {
   display: flex;
 
@@ -30,8 +35,7 @@
   padding: 5px 0 10px;
   border-left: 1px solid #bcbcbc;
   padding-left: 16px;
-  max-height: 200px;
-  overflow-y: auto;
+  position: relative;
 }
 
 .recipient-category__option-add {
@@ -42,3 +46,20 @@
     padding: 10px 0;
   }
 }
+
+.recipient-category__options + .recipient-category__option-add {
+  margin-top: 10px;
+}
+
+.recipient-category__toggle-all {
+  display: flex;
+  border-bottom: 1px solid #bcbcbc;
+  padding-bottom: 8px;
+  margin-bottom: 8px;
+}
+
+.recipient-category__checked-counter {
+  position: absolute;
+  right: 5px;
+  top: 5px;
+}

templates/widgets/massinput/massinput.lucius

@@ -0,0 +1,8 @@
+.btn.btn-mass-input-delete,
+.btn.btn-mass-input-add {
+  background-color: #999;
+  min-width: 50px;
+  padding: 5px 15px;
+  font-weight: 700;
+  font-size: 1.3rem;
+}