Merge branch 'master' into utility-refactoring

.vscode/tasks.json

@@ -43,6 +43,16 @@
         "panel": "dedicated",
         "showReuseMessage": false
       }
+    },
+    {
+      "type": "npm",
+      "script": "yesod:lint",
+      "problemMatcher": []
+    },
+    {
+      "type": "npm",
+      "script": "yesod:start",
+      "problemMatcher": []
     }
   ]
 }

config/settings.yml

@@ -30,9 +30,14 @@ session-timeout: 7200
 jwt-expiration: 604800
 jwt-encoding: HS256
 maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728"
-health-check-interval: "_env:HEALTHCHECK_INTERVAL:600" # or WATCHDOG_USEC/2, whichever is smaller
+health-check-interval:
-health-check-http: "_env:HEALTHCHECK_HTTP:true"
+  matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG:600"
+  http-reachable: "_env:HEALTHCHECK_INTERVAL_HTTP_REACHABLE:600"
+  ldap-admins: "_env:HEALTHCHECK_INTERVAL_LDAP_ADMINS:600"
+  smtp-connect: "_env:HEALTHCHECK_INTERVAL_SMTP_CONNECT:600"
+  widget-memcached: "_env:HEALTHCHECK_INTERVAL_WIDGET_MEMCACHED:600"
 health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true"
+health-check-http: "_env:HEALTHCHECK_HTTP:true" # Can we assume, that we can reach ourselves under APPROOT via HTTP (reverse proxies or firewalls might prevent this)?
 
 log-settings:
   detailed:      "_env:DETAILED_LOGGING:false"

frontend/src/utils/form/navigate-away-prompt.js

@@ -3,6 +3,7 @@ import { AUTO_SUBMIT_BUTTON_UTIL_SELECTOR } from "./auto-submit-button";
 import { AUTO_SUBMIT_INPUT_UTIL_SELECTOR } from "./auto-submit-input";
 
 const NAVIGATE_AWAY_PROMPT_INITIALIZED_CLASS = 'navigate-away-prompt--initialized';
+const NAVIGATE_AWAY_PROMPT_UTIL_OPTOUT = '[uw-no-navigate-away-prompt]';
 
 @Utility({
   selector: 'form',
@@ -30,6 +31,10 @@ export class NavigateAwayPrompt {
       return false;
     }
 
+    if (this._element.matches(NAVIGATE_AWAY_PROMPT_UTIL_OPTOUT)) {
+      return false;
+    }
+
     window.addEventListener('beforeunload', this._beforeUnloadHandler);
 
     this._element.addEventListener('submit', () => {

frontend/src/utils/form/navigate-away-prompt.md

@@ -6,6 +6,7 @@ This utility asks the user if (s)he really wants to navigate away from a page co
 
 ## Attribute: (none)
 (automatically setup on all form tags that dont automatically submit, see AutoSubmitButtonUtil)
+(Does not setup on forms that have uw-no-navigate-away-prompt)
 
 ## Example usage:
 (any page with a form)

messages/uniworx/de.msg

@@ -239,7 +239,6 @@ MaterialVisibleFrom: Sichtbar für Teilnehmer ab
 MaterialVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für unfertige Materialien oder zur ausschließlichen Verteilung an Korrektoren
 MaterialVisibleFromEditWarning: Das Datum der Veröffentlichung liegt in der Vergangenheit und sollte nicht mehr verändert werden, da dies die Benutzer verwirren könnte.
 MaterialInvisible: Dieses Material ist für Teilnehmer momentan unsichtbar!
-MaterialInvisibleUntil date@Text: Dieses Material ist für Teilnehmer momentan unsichtbar bis #{date}!
 MaterialFiles: Dateien
 MaterialHeading materialName@MaterialName: Material "#{materialName}"
 MaterialListHeading: Materialien

package.yaml

@@ -126,6 +126,7 @@ dependencies:
   - streaming-commons
   - hourglass
   - unix
+  - stm-delay
 
 other-extensions:
   - GeneralizedNewtypeDeriving

src/Application.hs

@@ -19,7 +19,7 @@ module Application
 import Control.Monad.Logger                 (liftLoc, LoggingT(..), MonadLoggerIO(..))
 import Database.Persist.Postgresql          (createPostgresqlPool, pgConnStr,
                                              pgPoolSize, runSqlPool)
-import Import
+import Import                        hiding (cancel)
 import Language.Haskell.TH.Syntax           (qLocation)
 import Network.Wai (Middleware)
 import Network.Wai.Handler.Warp             (Settings, defaultSettings,
@@ -36,6 +36,8 @@ import System.Log.FastLogger                ( defaultBufSize, newStderrLoggerSet
                                             , toLogStr, rmLoggerSet
                                             )
 
+import Handler.Utils                        (runAppLoggingT)
+
 import qualified Data.Map.Strict as Map
 
 import Foreign.Store
@@ -75,17 +77,22 @@ import System.Exit
 import qualified Database.Memcached.Binary.IO as Memcached
 
 import qualified System.Systemd.Daemon as Systemd
-import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel)
+import Control.Concurrent.Async.Lifted.Safe
 import System.Environment (lookupEnv)
 import System.Posix.Process (getProcessID)
 import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM)
 import qualified System.Posix.Signals as Signals (Handler(..))
 
-import Control.Monad.Trans.State (execStateT)
-
 import Network (socketPort)
 import qualified Network.Socket as Socket (close)
 
+import Control.Concurrent.STM.Delay
+import Control.Monad.STM (retry)
+
+import qualified Data.Set as Set
+
+import Data.Semigroup (Max(..), Min(..))
+
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
 import Handler.Common
@@ -152,7 +159,7 @@ makeFoundation appSettings'@AppSettings{..} = do
 
     appJobCtl <- liftIO $ newTVarIO Map.empty
     appCronThread <- liftIO newEmptyTMVarIO
-    appHealthReport <- liftIO $ newTVarIO Nothing
+    appHealthReport <- liftIO $ newTVarIO Set.empty
 
     -- We need a log function to create a connection pool. We need a connection
     -- pool to create our foundation. And we need our foundation to get a
@@ -217,13 +224,6 @@ makeFoundation appSettings'@AppSettings{..} = do
       $logDebugS "setup" "Done"
       return foundation
 
-runAppLoggingT :: UniWorX -> LoggingT m a -> m a
-runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
-  where
-    logFunc loc src lvl str = do
-      f <- messageLoggerSource app <$> readTVarIO loggerTVar
-      f loc src lvl str
-
 clusterSetting :: forall key m p.
                   ( MonadIO m
                   , ClusterSetting key
@@ -333,7 +333,12 @@ warpSettings foundation = defaultSettings
                             if
                               | foundation ^. _appHealthCheckDelayNotify
                                 -> void . fork $ do
-                                  atomically $ readTVar (foundation ^. _appHealthReport) >>= guard . maybe False ((== HealthSuccess) . classifyHealthReport . snd)
+                                  let activeChecks = Set.fromList universeF
+                                                   & Set.filter (is _Just . (foundation ^. _appHealthCheckInterval))
+                                  atomically $ do
+                                    results <- readTVar $ foundation ^. _appHealthReport
+                                    guard $ activeChecks == Set.map (classifyHealthReport . snd) results
+                                    guard . (== Min HealthSuccess) $ foldMap (Min . healthReportStatus . snd) results
                                   notifyReady
                               | otherwise
                                 -> notifyReady
@@ -354,19 +359,8 @@ warpSettings foundation = defaultSettings
                            
 
 getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings
-getAppDevSettings = liftIO $ adjustSettings =<< loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
+getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
-getAppSettings = liftIO $ adjustSettings =<< loadYamlSettingsArgs [configSettingsYmlValue] useEnv
+getAppSettings = liftIO $ loadYamlSettingsArgs [configSettingsYmlValue] useEnv
-
-adjustSettings :: MonadIO m => AppSettings -> m AppSettings
-adjustSettings = execStateT $ do
-  watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC"
-  watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID"
-  myProcessID <- liftIO getProcessID
-  case watchdogMicroSec of
-    Just wInterval
-      | maybe True (== myProcessID) watchdogProcess
-        -> _appHealthCheckInterval %= min (fromRational $ (toRational wInterval / 1e6) / 2)
-    _other -> return ()
 
 -- | main function for use by yesod devel
 develMain :: IO ()
@@ -417,7 +411,47 @@ appMain = runResourceT $ do
         case didStore of
           Just () -> $logInfoS "shutdown" "Stored all bound sockets for restart"
           Nothing -> forM_ sockets $ liftIO . Socket.close
-        liftIO . throwTo mainThreadId . ExitFailure $ 0b10000000 + fromIntegral siginfoSignal
+        liftIO $ throwTo mainThreadId ExitSuccess
+
+      watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC"
+      watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID"
+      myProcessID <- liftIO getProcessID
+      case watchdogMicroSec of
+        Just wInterval
+          | maybe True (== myProcessID) watchdogProcess
+            -> let notifyWatchdog :: IO ()
+                   notifyWatchdog = runAppLoggingT foundation $ go Nothing
+                     where
+                       go pStatus = do
+                         d <- liftIO . newDelay . floor $ wInterval % 2
+
+                         status <- atomically $ asum
+                           [ Nothing <$ waitDelay d
+                           , Just <$> do
+                               results <- readTVar $ foundation ^. _appHealthReport
+                               case fromNullable results of
+                                 Nothing -> retry
+                                 Just rs -> do
+                                   let status = ofoldMap1 (Max *** Min . healthReportStatus) rs
+                                   guard $ pStatus /= Just status
+                                   return status
+                           ]
+
+                         case status of
+                           Just (_, Min status') -> do
+                             $logInfoS "NotifyStatus" $ toPathPiece status'
+                             liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status'
+                           Nothing -> return ()
+
+                         case status of
+                           Just (_, Min HealthSuccess) -> do
+                             $logInfoS "NotifyWatchdog" "Notify"
+                             liftIO $ void Systemd.notifyWatchdog
+                           _other -> return ()
+
+                         go status
+                in void $ allocate (async notifyWatchdog >>= \a -> a <$ link a) cancel
+        _other -> return ()
 
       let runWarp socket = runSettingsSocket (warpSettings foundation) socket app
       case sockets of

src/Auth/Dummy.hs

@@ -57,7 +57,7 @@ dummyLogin = AuthPlugin{..}
             { formMethod = POST
             , formAction = Just . SomeRoute . toMaster $ PluginR "dummy" []
             , formEncoding = loginEnctype
-            , formAttrs = []
+            , formAttrs = [("uw-no-navigate-away-prompt","")]
             , formSubmit = FormSubmit
             , formAnchor = Just "login--dummy" :: Maybe Text
             }

src/Auth/LDAP.hs

@@ -117,7 +117,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
             { formMethod = POST
             , formAction = Just . SomeRoute . toMaster $ PluginR "LDAP" []
             , formEncoding = loginEnctype
-            , formAttrs = []
+            , formAttrs = [("uw-no-navigate-away-prompt","")]
             , formSubmit = FormSubmit
             , formAnchor = Just "login--campus" :: Maybe Text
             }

src/Auth/PWHash.hs

@@ -93,7 +93,7 @@ hashLogin pwHashAlgo = AuthPlugin{..}
             { formMethod = POST
             , formAction = Just . SomeRoute . toMaster $ PluginR "PWHash" []
             , formEncoding = loginEnctype
-            , formAttrs = []
+            , formAttrs = [("uw-no-navigate-away-prompt","")]
             , formSubmit = FormSubmit
             , formAnchor = Just "login--hash" :: Maybe Text
             }

src/CryptoID.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module CryptoID

src/CryptoID/TH.hs

@@ -11,6 +11,11 @@ import Data.Binary.SerializationLength
 import Data.CaseInsensitive (CI)
 import System.FilePath (FilePath)
 
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+import Database.Persist.Sql
+
 
 decCryptoIDs :: [Name] -> DecsQ
 decCryptoIDs = fmap concat . mapM decCryptoID
@@ -21,6 +26,11 @@ decCryptoIDs = fmap concat . mapM decCryptoID
           instance HasFixedSerializationLength $(t) where
             type SerializationLength $(t) = SerializationLength Int64
 
+          instance {-# OVERLAPPING #-} Binary $(t) where
+            put = Binary.put . fromSqlKey
+            putList = Binary.putList . map fromSqlKey
+            get = toSqlKey <$> Binary.get
+
           type instance CryptoIDNamespace a $(t) = $(litT $ strTyLit ns)
         |]
 

src/Data/Aeson/Types/Instances.hs

@@ -14,9 +14,13 @@ import Data.Binary (Binary)
 import Data.HashMap.Strict.Instances ()
 import Data.Vector.Instances ()
 
+import Model.Types.TH.JSON (derivePersistFieldJSON)
+
 
 instance MonadThrow Parser where
   throwM = fail . show
 
-
 instance Binary Value
+
+
+derivePersistFieldJSON ''Value

src/Data/CaseInsensitive/Instances.hs

@@ -26,6 +26,9 @@ import qualified Database.Esqueleto as E
 
 import Web.HttpApiData
 
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
 
 instance PersistField (CI Text) where
   toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
@@ -92,5 +95,9 @@ instance FromHttpApiData (CI Text) where
 
 instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
   fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
-  toPathMultiPiece = toPathMultiPiece . CI.foldedCase
+  toPathMultiPiece = toPathMultiPiece . CI.original
 
+instance (CI.FoldCase s, Binary s) => Binary (CI s) where
+  get = CI.mk <$> Binary.get
+  put = Binary.put . CI.original
+  putList = Binary.putList . map CI.original

src/Data/Time/Calendar/Instances.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Time.Calendar.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+
+deriving newtype instance Hashable Day
+
+instance Binary Day where
+  get = ModifiedJulianDay <$> Binary.get
+  put = Binary.put . toModifiedJulianDay
+

src/Data/Time/Clock/Instances.hs

@@ -11,14 +11,17 @@ import Data.Time.Clock
 import Data.Binary (Binary)
 import qualified Data.Binary as Binary
 
+import Data.Time.Calendar.Instances ()
+
+
+instance Hashable DiffTime where
+  hashWithSalt s = hashWithSalt s . toRational
+
 
 deriving instance Generic UTCTime
+instance Hashable UTCTime
 
 
-instance Binary Day where
-  get = ModifiedJulianDay <$> Binary.get
-  put = Binary.put . toModifiedJulianDay
-
 instance Binary DiffTime where
   get = fromRational <$> Binary.get
   put = Binary.put . toRational

src/Data/Time/Format/Instances.hs

@@ -0,0 +1,14 @@
+{-# OPTIONS -fno-warn-orphans #-}
+
+module Data.Time.Format.Instances
+  (
+  ) where
+
+import qualified Language.Haskell.TH.Syntax as TH
+
+import Data.Time.Format
+
+import Data.Time.LocalTime.Instances ()
+
+
+deriving instance TH.Lift TimeLocale

src/Data/Time/LocalTime/Instances.hs

@@ -0,0 +1,23 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Time.LocalTime.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Time.LocalTime
+
+import Data.Binary (Binary)
+
+import qualified Language.Haskell.TH.Syntax as TH
+
+
+deriving instance Generic TimeOfDay
+deriving instance Typeable TimeOfDay
+
+instance Hashable TimeOfDay
+instance Binary TimeOfDay
+
+
+deriving instance TH.Lift TimeZone

src/Data/UUID/Instances.hs

@@ -0,0 +1,27 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.UUID.Instances
+  () where
+
+import ClassyPrelude
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+
+import Database.Persist.Sql
+import Web.PathPieces
+  
+
+instance PathPiece UUID where
+  fromPathPiece = UUID.fromString . unpack
+  toPathPiece = pack . UUID.toString
+
+instance PersistField UUID where
+  toPersistValue = PersistDbSpecific . UUID.toASCIIBytes
+
+  fromPersistValue (PersistText t)        = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t
+  fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
+  fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
+  fromPersistValue  x                     = Left $ "Expected UUID, received: " <> tshow x
+
+instance PersistFieldSql UUID where
+  sqlType _ = SqlOther "uuid"

src/Data/Universe/Instances/Reverse/MonoTraversable.hs

@@ -0,0 +1,17 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Universe.Instances.Reverse.MonoTraversable
+  (
+  ) where
+
+import Data.Universe
+import Data.MonoTraversable
+
+import Data.Universe.Instances.Reverse 
+  
+
+type instance Element (a -> b) = b
+
+instance Finite a => MonoFoldable (a -> b)
+instance (Ord a, Finite a) => MonoTraversable (a -> b)
+  

src/Database/Persist/Class/Instances.hs

@@ -0,0 +1,23 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Database.Persist.Class.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Database.Persist.Class
+import Database.Persist.Types.Instances ()
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+
+instance PersistEntity record => Hashable (Key record) where
+  hashWithSalt s = hashWithSalt s . toPersistValue
+
+instance PersistEntity record => Binary (Key record) where
+  put = Binary.put . toPersistValue
+  putList = Binary.putList . map toPersistValue
+  get = either (fail . unpack) return . fromPersistValue =<< Binary.get

src/Database/Persist/Sql/Instances.hs

@@ -1,33 +0,0 @@
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Database.Persist.Sql.Instances
-  (
-  ) where
-
-import ClassyPrelude.Yesod
-
-import Data.Binary (Binary)
-import qualified Data.Binary as B
-
-import Database.Persist.Sql
-
-
-instance Binary (BackendKey SqlWriteBackend) where
-  put = B.put . unSqlWriteBackendKey
-  putList = B.putList . map unSqlWriteBackendKey
-  get = SqlWriteBackendKey <$> B.get
-instance Binary (BackendKey SqlReadBackend) where
-  put = B.put . unSqlReadBackendKey
-  putList = B.putList . map unSqlReadBackendKey
-  get = SqlReadBackendKey <$> B.get
-instance Binary (BackendKey SqlBackend) where
-  put = B.put . unSqlBackendKey
-  putList = B.putList . map unSqlBackendKey
-  get = SqlBackendKey <$> B.get
-  
-
-instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Binary (Key record) where
-  put = B.put . fromSqlKey
-  putList = B.putList . map fromSqlKey
-  get = toSqlKey <$> B.get

src/Database/Persist/Types/Instances.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Database.Persist.Types.Instances
@@ -6,7 +5,18 @@ module Database.Persist.Types.Instances
   ) where
 
 import ClassyPrelude
+
 import Database.Persist.Types
 
-instance (Hashable record, Hashable (Key record)) => Hashable (Entity record) where
+import Data.Time.Calendar.Instances ()
-  s `hashWithSalt` Entity{..} = s `hashWithSalt` entityKey `hashWithSalt` entityVal
+import Data.Time.LocalTime.Instances ()
+import Data.Time.Clock.Instances ()
+
+import Data.Binary (Binary)
+
+
+deriving instance Generic PersistValue
+deriving instance Typeable PersistValue
+
+instance Hashable PersistValue
+instance Binary PersistValue

src/Foundation.hs

@@ -46,7 +46,7 @@ import Data.Map (Map, (!?))
 import qualified Data.Map as Map
 import qualified Data.HashSet as HashSet
 
-import Data.List (nubBy, (!!))
+import Data.List (nubBy, (!!), findIndex)
 
 import Data.Monoid (Any(..))
 
@@ -130,7 +130,7 @@ data UniWorX = UniWorX
     , appSessionKey      :: ClientSession.Key
     , appSecretBoxKey    :: SecretBox.Key
     , appJSONWebKeySet   :: Jose.JwkSet
-    , appHealthReport    :: TVar (Maybe (UTCTime, HealthReport))
+    , appHealthReport    :: TVar (Set (UTCTime, HealthReport))
     }
 
 makeLenses_ ''UniWorX
@@ -493,7 +493,7 @@ askTokenUnsafe = $cachedHere $ do
       throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid
 
 validateToken :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> DB AuthResult
-validateToken mAuthId' route' isWrite' token' = runCachedMemoT $ for4 memo validateToken' mAuthId' route' isWrite' token'
+validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateToken' mAuthId' route' isWrite' token'
   where
     validateToken' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult
     validateToken' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
@@ -524,7 +524,7 @@ tagAccessPredicate :: AuthTag -> AccessPredicate
 tagAccessPredicate AuthFree = trueAP
 tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
   -- Courses: access only to school admins
-  CourseR tid ssh csh _ -> exceptT return return $ do
+  CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
       E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
@@ -536,7 +536,7 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
     guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
     return Authorized
   -- other routes: access to any admin is granted here
-  _other -> exceptT return return $ do
+  _other -> $cachedHereBinary mAuthId . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
     guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
@@ -566,7 +566,7 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
   return $ Unauthorized "Route under development"
 #endif
 tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
-  CourseR tid ssh csh _ -> exceptT return return $ do
+  CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
      [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
        E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
@@ -578,13 +578,13 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
      guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer)
      return Authorized
   -- lecturer for any school will do
-  _ -> exceptT return return $ do
+  _ -> $cachedHereBinary mAuthId . exceptT return return $ do
      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
      void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
      return Authorized
 tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
   authId <- maybeExceptT AuthenticationRequired $ return mAuthId
-  resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
+  resList <- $cachedHereBinary (mAuthId) . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
     E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
     E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
     E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
@@ -593,17 +593,17 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret
     resMap :: Map CourseId (Set SheetId)
     resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
   case route of
-    CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
+    CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
       sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
       Submission{..} <- MaybeT . lift $ get sid
       guard $ maybe False (== authId) submissionRatingBy
       return Authorized
-    CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
+    CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
       Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
       Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
       guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
       return Authorized
-    CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
+    CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
       Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
       guard $ cid `Set.member` Map.keysSet resMap
       return Authorized
@@ -612,7 +612,7 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret
       return Authorized
 tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do
   authId <- maybeExceptT AuthenticationRequired $ return mAuthId
-  resList <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
+  resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
     E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
     E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId
     E.where_ $ tutor E.^. TutorUser E.==. E.val authId
@@ -622,12 +622,12 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return
     resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ]
   case route of
     CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do
-      Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
+      Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
-      Entity tutid _ <- MaybeT . lift . getBy $ UniqueTutorial cid tutn
+      Entity tutid _ <- $cachedHereBinary (cid, tutn) . MaybeT . lift . getBy $ UniqueTutorial cid tutn
       guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid)
       return Authorized
     CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do
-      Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
+      Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
       guard $ cid `Set.member` Map.keysSet resMap
       return Authorized
     _ -> do
@@ -636,10 +636,10 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return
 tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
   CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do
     now <- liftIO getCurrentTime
-    course <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-    Entity tutId Tutorial{..} <- MaybeT . getBy $ UniqueTutorial course tutn
+    Entity tutId Tutorial{..} <- $cachedHereBinary (course, tutn) . MaybeT . getBy $ UniqueTutorial course tutn
     registered <- case mAuthId of
-      Just uid -> lift . existsBy $ UniqueTutorialParticipant tutId uid
+      Just uid -> $cachedHereBinary (tutId, uid) . lift . existsBy $ UniqueTutorialParticipant tutId uid
       Nothing  -> return False
 
     if
@@ -654,8 +654,8 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
         -> mzero
 
   CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
-    cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-    Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
+    Entity _sid Sheet{..} <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
     cTime <- liftIO getCurrentTime
     let
       visible = NTop sheetVisibleFrom <= NTop (Just cTime)
@@ -684,8 +684,8 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
     return Authorized
 
   CourseR tid ssh csh (MaterialR mnm _) -> maybeT (unauthorizedI MsgUnauthorizedMaterialTime) $ do
-    cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-    Entity _mid Material{materialVisibleFrom} <- MaybeT . getBy $ UniqueMaterial cid mnm
+    Entity _mid Material{materialVisibleFrom} <- $cachedHereBinary (cid, mnm) . MaybeT . getBy $ UniqueMaterial cid mnm
     cTime <- liftIO getCurrentTime
     let visible = NTop materialVisibleFrom <= NTop (Just cTime)
     guard visible
@@ -693,9 +693,9 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
 
   CourseR tid ssh csh CRegisterR -> do
     now <- liftIO getCurrentTime
-    mbc <- getBy $ TermSchoolCourseShort tid ssh csh
+    mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh
     registered <- case (mbc,mAuthId) of
-      (Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid)
+      (Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ isJust <$> (getBy $ UniqueParticipant uid cid)
       _ -> return False
     case mbc of
       (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo}))
@@ -709,7 +709,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
 
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
     smId <- decrypt cID
-    SystemMessage{systemMessageFrom, systemMessageTo} <- MaybeT $ get smId
+    SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
     cTime <- (NTop . Just) <$> liftIO getCurrentTime
     guard $ NTop systemMessageFrom <= cTime
          && NTop systemMessageTo   >= cTime
@@ -719,7 +719,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
 tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of
   CourseR tid ssh csh _ -> exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
-    [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
+    [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
       E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
       E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
            E.&&. course E.^. CourseTerm      E.==. E.val tid
@@ -732,7 +732,7 @@ tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route
 tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of
   CTutorialR tid ssh csh tutn _ -> exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
-    [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
+    [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
       E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
       E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
       E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
@@ -745,7 +745,7 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case rout
     return Authorized
   CourseR tid ssh csh _ -> exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
-    [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
+    [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
       E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
       E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
       E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
@@ -763,14 +763,14 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
           whenExceptT ok Authorized
     participant <- decrypt cID
     -- participant is currently registered
-    authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
+    $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
       E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
       E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant
            E.&&. course E.^. CourseTerm      E.==. E.val tid
            E.&&. course E.^. CourseSchool    E.==. E.val ssh
            E.&&. course E.^. CourseShorthand E.==. E.val csh
     -- participant has at least one submission
-    authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
+    $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
       E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
       E.on $ sheet  E.^. SheetId   E.==. submission E.^. SubmissionSheet
       E.on $ course E.^. CourseId  E.==. sheet E.^. SheetCourse
@@ -779,7 +779,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
            E.&&. course E.^. CourseSchool    E.==. E.val ssh
            E.&&. course E.^. CourseShorthand E.==. E.val csh
     -- participant is member of a submissionGroup
-    authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do
+    $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do
       E.on $ submissionGroup E.^. SubmissionGroupId  E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
       E.on $ course E.^. CourseId  E.==. submissionGroup E.^. SubmissionGroupCourse
       E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant
@@ -787,7 +787,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
            E.&&. course E.^. CourseSchool    E.==. E.val ssh
            E.&&. course E.^. CourseShorthand E.==. E.val csh
     -- participant is a sheet corrector
-    authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
+    $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
       E.on $ sheet  E.^. SheetId   E.==. sheetCorrector E.^. SheetCorrectorSheet
       E.on $ course E.^. CourseId  E.==. sheet E.^. SheetCourse
       E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant
@@ -795,7 +795,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
            E.&&. course E.^. CourseSchool    E.==. E.val ssh
            E.&&. course E.^. CourseShorthand E.==. E.val csh
     -- participant is a tutorial user
-    authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
+    $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
       E.on $ tutorial  E.^. TutorialId   E.==. tutorialUser E.^. TutorialParticipantTutorial
       E.on $ course E.^. CourseId  E.==. tutorial E.^. TutorialCourse
       E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant
@@ -803,7 +803,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
            E.&&. course E.^. CourseSchool    E.==. E.val ssh
            E.&&. course E.^. CourseShorthand E.==. E.val csh
     -- participant is tutor for this course
-    authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
+    $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
       E.on $ tutorial  E.^. TutorialId   E.==. tutor E.^. TutorTutorial
       E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
       E.where_ $ tutor E.^. TutorUser E.==. E.val participant
@@ -811,7 +811,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
            E.&&. course E.^. CourseSchool    E.==. E.val ssh
            E.&&. course E.^. CourseShorthand E.==. E.val csh
     -- participant is lecturer for this course
-    authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do
+    $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do
       E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
       E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant
            E.&&. course E.^. CourseTerm      E.==. E.val tid
@@ -821,26 +821,26 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
   r -> $unsupportedAuthPredicate AuthParticipant r
 tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
   CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do
-    cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-    Entity tutId Tutorial{..} <- MaybeT . getBy $ UniqueTutorial cid tutn
+    Entity tutId Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
-    registered <- lift $ fromIntegral <$> count [ TutorialParticipantTutorial ==. tutId ]
+    registered <- $cachedHereBinary tutId . lift $ fromIntegral <$> count [ TutorialParticipantTutorial ==. tutId ]
     guard $ NTop tutorialCapacity > NTop (Just registered)
     return Authorized
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
-    Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
+    Entity cid Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
-    registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
+    registered <- $cachedHereBinary cid . lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
     guard $ NTop courseCapacity > NTop (Just registered)
     return Authorized
   r -> $unsupportedAuthPredicate AuthCapacity r
 tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of
   CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do
-    cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-    Entity _ Tutorial{..} <- MaybeT . getBy $ UniqueTutorial cid tutn
+    Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
     case (tutorialRegGroup, mAuthId) of
       (Nothing, _) -> return Authorized
       (_, Nothing) -> return AuthenticationRequired
       (Just rGroup, Just uid) -> do
-        [E.Value hasOther] <- lift . E.select . return . E.exists . E.from $ \(tutorial `E.InnerJoin` participant) -> do
+        [E.Value hasOther] <- $cachedHereBinary (uid, rGroup) . lift . E.select . return . E.exists . E.from $ \(tutorial `E.InnerJoin` participant) -> do
           E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
           E.where_ $ participant E.^. TutorialParticipantUser E.==. E.val uid
                E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup)
@@ -850,9 +850,9 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of
 tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
     -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
-    cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-    assertM_ (<= 0) . lift $ count [ CourseParticipantCourse ==. cid ]
+    assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ]
-    assertM_ ((<= 0) :: Int -> Bool) . lift . fmap (E.unValue . unsafeHead) $ E.select . E.from $ \(sheet `E.InnerJoin` submission) -> do
+    assertM_ ((<= 0) :: Int -> Bool) . $cachedHereBinary cid . lift . fmap (E.unValue . unsafeHead) $ E.select . E.from $ \(sheet `E.InnerJoin` submission) -> do
       E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
       E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
       return E.countRows
@@ -860,26 +860,26 @@ tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of
   r -> $unsupportedAuthPredicate AuthEmpty r
 tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
-    Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
+    Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     guard courseMaterialFree
     return Authorized
   r -> $unsupportedAuthPredicate AuthMaterials r
 tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of
-  CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
+  CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
     sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
     return Authorized
   r -> $unsupportedAuthPredicate AuthOwner r
 tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of
-  CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
+  CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
     sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
     sub <- MaybeT $ get sid
     guard $ submissionRatingDone sub
     return Authorized
   r -> $unsupportedAuthPredicate AuthRated r
 tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of
-  CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
+  CSheetR tid ssh csh shn _ -> $cachedHereBinary (tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
     Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
     guard $ is _Just submissionModeUser
@@ -887,8 +887,8 @@ tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of
   r -> $unsupportedAuthPredicate AuthUserSubmissions r
 tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
   CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
-    Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
+    Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
-    Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
+    Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
     guard submissionModeCorrector
     return Authorized
   r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
@@ -909,7 +909,7 @@ tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return ret
 tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
     smId <- decrypt cID
-    SystemMessage{..} <- MaybeT $ get smId
+    SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
     let isAuthenticated = isJust mAuthId
     guard $ not systemMessageAuthenticatedOnly || isAuthenticated
     return Authorized
@@ -918,6 +918,21 @@ tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorize
 tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
 
 
+authTagSpecificity :: AuthTag -> AuthTag -> Ordering
+-- ^ Heuristic for which `AuthTag`s to evaluate first
+authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem
+  where
+    eqClasses :: [[AuthTag]]
+    -- ^ Constructors of `AuthTag` ordered (increasing) by execution order
+    eqClasses =
+      [ [ AuthFree, AuthDeprecated, AuthDevelopment ] -- Route wide
+      , [ AuthRead, AuthWrite, AuthToken ] -- Request wide
+      , [ AuthAdmin ] -- Site wide
+      , [ AuthLecturer, AuthCourseRegistered, AuthParticipant, AuthTime, AuthMaterials, AuthUserSubmissions, AuthCorrectorSubmissions, AuthCapacity, AuthEmpty ] ++ [ AuthSelf, AuthNoEscalation ] ++ [ AuthAuthentication ] -- Course/User/SystemMessage wide
+      , [ AuthCorrector ] ++ [ AuthTutor ] ++ [ AuthTutorialRegistered, AuthRegisterGroup ] -- Tutorial/Material/Sheet wide
+      , [ AuthOwner, AuthRated ] -- Submission wide
+      ]
+
 defaultAuthDNF :: AuthDNF
 defaultAuthDNF = PredDNF $ Set.fromList
   [ impureNonNull . Set.singleton $ PLVariable AuthAdmin
@@ -945,16 +960,19 @@ routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partiti
 
 evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
 -- ^ `tell`s disabled predicates, identified as pivots
-evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF) mAuthId route isWrite
+evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite
   = do
       mr <- getMsgRenderer
       let
+        authVarSpecificity = authTagSpecificity `on` plVar
+        authDNF = sortBy (authVarSpecificity `on` maximumBy authVarSpecificity . impureNonNull) $ map (sortBy authVarSpecificity) authDNF'
+        
         authTagIsInactive = not . authTagIsActive
 
         evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult
-        evalAuthTag authTag = lift . (runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite
+        evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite
           where
-            evalAccessPred' authTag' mAuthId' route' isWrite' = CachedMemoT $ do
+            evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
               $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
               evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite'
 

src/Handler/Corrections.hs

@@ -35,7 +35,9 @@ import Data.Monoid (All(..))
 -- import qualified Data.UUID.Cryptographic as UUID
 -- import qualified Data.Conduit.List as C
 
+import Database.Esqueleto.Utils.TH
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
 import qualified Database.Esqueleto.Internal.Language (From)
 -- import qualified Database.Esqueleto.Internal.Sql as E
 
@@ -77,6 +79,18 @@ lastEditQuery submission = E.sub_select $ E.from $ \edit -> do
   E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
   return $ E.max_ $ edit E.^. SubmissionEditTime
 
+queryCourse :: CorrectionTableExpr -> E.SqlExpr (Entity Course)
+queryCourse = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1)
+
+querySheet :: CorrectionTableExpr -> E.SqlExpr (Entity Sheet)
+querySheet = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1)
+
+querySubmission :: CorrectionTableExpr -> E.SqlExpr (Entity Submission)
+querySubmission = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1)
+
+queryCorrector :: CorrectionTableExpr -> E.SqlExpr (Maybe (Entity User))
+queryCorrector = $(sqlLOJproj 2 2)
+
 -- Where Clauses
 ratedBy :: UserId -> CorrectionTableWhere
 ratedBy uid   ((_course `E.InnerJoin` _sheet `E.InnerJoin`  submission) `E.LeftOuterJoin` _corrector) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
@@ -325,6 +339,35 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
             Just True -> E.not_ . E.isNothing $ submission E.^. SubmissionRatingTime
             Just False-> E.isNothing $ submission E.^. SubmissionRatingTime
         )
+      , ( "corrector-name-email" -- corrector filter does not work for text-filtering
+        , FilterColumn $ E.anyFilter
+            [ E.mkContainsFilter $ queryCorrector >>> (E.?. UserSurname)
+            , E.mkContainsFilter $ queryCorrector >>> (E.?. UserDisplayName)
+            , E.mkContainsFilter $ queryCorrector >>> (E.?. UserEmail)
+            ]
+        )
+      , ( "user-name-email"
+        , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do
+              E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
+              E.where_ $ querySubmission table E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
+              E.where_ $ (\f -> f user $ Set.singleton needle) $ E.anyFilter
+                [ E.mkContainsFilter (E.^. UserSurname)
+                , E.mkContainsFilter (E.^. UserDisplayName)
+                , E.mkContainsFilter (E.^. UserEmail)
+                ]
+        )
+      , ( "user-matriclenumber"
+        , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do
+              E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
+              E.where_ $ querySubmission table E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
+              E.where_ $ (\f -> f user $ Set.singleton needle) $
+                E.mkContainsFilter (E.^. UserMatrikelnummer)
+        )
+      -- , ( "pseudonym"
+      --   , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(pseudonym) -> do
+      --       E.where_ $ querySheet table E.^. SheetId E.==. pseudonym E.^. SheetPseudonymSheet
+      --       E.where_ $ E.mkContainsFilter -- DB only stores Pseudonym == Word24. Conversion not possible in DB.
+      --   )
       ]
     , dbtFilterUI  = fromMaybe mempty dbtFilterUI
     , dbtStyle     = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI }
@@ -442,7 +485,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
                 [whamlet|_{MsgAssignSubmissionExceptionSubmissionsNotFound (length subCIDs)}|]
                 (Right $(widgetFile "messages/submissionsAssignNotFound"))
           addMessageWidget Error errorModal
-                
+
       handle assignExceptions . runDB $ do
         alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
         unless (null alreadyAssigned) $ do
@@ -583,8 +626,16 @@ postCCorrectionsR tid ssh csh = do
         , colCorrector
         , colAssigned
         ] -- Continue here
-      psValidator = def
+      filterUI = Just $ \mPrev -> mconcat
-  correctionsR whereClause colonnade Nothing psValidator $ Map.fromList
+        [ prismAForm (singletonFilter "user-name-email")      mPrev $ aopt textField (fslI MsgCourseMembers)
+        , prismAForm (singletonFilter "user-matriclenumber")  mPrev $ aopt textField (fslI MsgMatrikelNr)
+        , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector)
+          -- "pseudonym" TODO DB only stores Word24
+        , Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgSheet)        (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
+        , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField             (fslI MsgRatingTime)
+        ]
+      psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
+  correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
     [ downloadAction
     , assignAction (Left cid)
     , deleteAction
@@ -607,8 +658,15 @@ postSSubsR tid ssh csh shn = do
         , colCorrector
         , colAssigned
         ]
-      psValidator = def
+      filterUI = Just $ \mPrev -> mconcat
-  correctionsR whereClause colonnade Nothing psValidator $ Map.fromList
+        [ prismAForm (singletonFilter "user-name-email")      mPrev $ aopt textField (fslI MsgCourseMembers)
+        , prismAForm (singletonFilter "user-matriclenumber")  mPrev $ aopt textField (fslI MsgMatrikelNr)
+        , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector)
+          -- "pseudonym" TODO DB only stores Word24
+        , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField             (fslI MsgRatingTime)
+        ]
+      psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
+  correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
     [ downloadAction
     , assignAction (Right shid)
     , autoAssignAction shid

src/Handler/Health.hs

@@ -9,55 +9,71 @@ import Utils.Lens
 
 import qualified Data.UUID as UUID
 
+import Data.Semigroup (Min(..), Max(..))
+
+import qualified Data.Set as Set
+
+import Control.Concurrent.STM.Delay
+
 
 getHealthR :: Handler TypedContent
 getHealthR = do
-  healthReport' <- liftIO . readTVarIO =<< getsYesod appHealthReport
+  reportStore <- getsYesod appHealthReport
-  let
+  healthReports' <- liftIO $ readTVarIO reportStore
-    handleMissing = do
-      interval <- getsYesod $ round . (* 1e6) . toRational . view _appHealthCheckInterval
-      reportStore <- getsYesod appHealthReport
-      waitResult <- threadDelay interval `race` atomically (readTVar reportStore >>= guard . is _Just)
-      case waitResult of
-        Left () -> fail "System is not generating HealthReports"
-        Right _ -> redirect HealthR
-  (lastUpdated, healthReport) <- maybe handleMissing return healthReport'
   interval <- getsYesod $ view _appHealthCheckInterval
-  instanceId <- getsYesod appInstanceID
 
-  setWeakEtagHashable (instanceId, lastUpdated)
+  case fromNullable healthReports' of
-  expiresAt $ interval `addUTCTime` lastUpdated
+    Nothing -> do
-  setLastModified lastUpdated
+      let Min (NTop minInterval) = ofoldMap1 (Min . NTop) $ impureNonNull interval
-  
+      delay <- for minInterval $ \minInterval' -> liftIO . newDelay . round $ toRational minInterval' * 1e6
-  let status 
+      waitResult <- atomically $ maybe (pure $ Left False) (fmap (const $ Left True) . waitDelay) delay <|> (fmap Right . assertM (not. Set.null) $ readTVar reportStore)
-        | HealthSuccess <- classifyHealthReport healthReport
+      case waitResult of
-        = ok200
+        Left False -> sendResponseStatus noContent204 ()
-        | otherwise
+        Left True  -> fail "System is not generating HealthReports"
-        = internalServerError500
+        Right _    -> redirect HealthR
-  sendResponseStatus status <=< selectRep $ do
+    Just healthReports -> do
-    provideRep . siteLayoutMsg MsgHealthReport $ do
+      let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports
-      setTitleI MsgHealthReport
+          reportNextUpdate (lastCheck, classifyHealthReport -> kind)
-      let HealthReport{..} = healthReport
+            = fromMaybe 0 (interval kind) `addUTCTime` lastCheck
-      [whamlet|
+          Max nextUpdate = ofoldMap1 (Max . reportNextUpdate) healthReports
-        $newline never
+      instanceId <- getsYesod appInstanceID
-        <dl .deflist>
+
-          <dt .deflist__dt>_{MsgHealthMatchingClusterConfig}
+      setWeakEtagHashable (instanceId, lastUpdated)
-          <dd .deflist__dd>#{boolSymbol healthMatchingClusterConfig}
+      expiresAt nextUpdate
-          $maybe httpReachable <- healthHTTPReachable
+      setLastModified lastUpdated
-            <dt .deflist__dt>_{MsgHealthHTTPReachable}
+
-            <dd .deflist__dd>#{boolSymbol httpReachable}
+      let status'
-          $maybe ldapAdmins <- healthLDAPAdmins
+            | HealthSuccess <- status
-            <dt .deflist__dt>_{MsgHealthLDAPAdmins}
+            = ok200
-            <dd .deflist__dd>#{textPercent ldapAdmins}
+            | otherwise
-          $maybe smtpConnect <- healthSMTPConnect
+            = internalServerError500
-            <dt .deflist__dt>_{MsgHealthSMTPConnect}
+      sendResponseStatus status' <=< selectRep $ do
-            <dd .deflist__dd>#{boolSymbol smtpConnect}
+        provideRep . siteLayoutMsg MsgHealthReport $ do
-          $maybe widgetMemcached <- healthWidgetMemcached
+          setTitleI MsgHealthReport
-            <dt .deflist__dt>_{MsgHealthWidgetMemcached}
+          [whamlet|
-            <dd .deflist__dd>#{boolSymbol widgetMemcached}
+            $newline never
-      |]
+            <dl .deflist>
-    provideJson healthReport
+              $forall (_, report) <- healthReports'
-    provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReport
+                $case report
+                  $of HealthMatchingClusterConfig passed
+                    <dt .deflist__dt>_{MsgHealthMatchingClusterConfig}
+                    <dd .deflist__dd>#{boolSymbol passed}
+                  $of HealthHTTPReachable (Just passed)
+                    <dt .deflist__dt>_{MsgHealthHTTPReachable}
+                    <dd .deflist__dd>#{boolSymbol passed}
+                  $of HealthLDAPAdmins (Just found)
+                    <dt .deflist__dt>_{MsgHealthLDAPAdmins}
+                    <dd .deflist__dd>#{textPercent found}
+                  $of HealthSMTPConnect (Just passed)
+                    <dt .deflist__dt>_{MsgHealthSMTPConnect}
+                    <dd .deflist__dd>#{boolSymbol passed}
+                  $of HealthWidgetMemcached (Just passed)
+                    <dt .deflist__dt>_{MsgHealthWidgetMemcached}
+                    <dd .deflist__dd>#{boolSymbol passed}
+                  $of _
+          |]
+        provideJson healthReports
+        provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports
 
 getInstanceR :: Handler TypedContent
 getInstanceR = do

src/Handler/Material.hs

@@ -222,12 +222,8 @@ getMShowR tid ssh csh mnm = do
       }
     return (matEnt,fileTable')
 
-  let matVisFro = materialVisibleFrom material
+  let matLastEdit      = formatTimeW    SelFormatDateTime  $  materialLastEdit    material
-  now <- liftIO getCurrentTime
+  let matVisibleFromMB = visibleUTCTime SelFormatDateTime <$> materialVisibleFrom material
-  materialLastEdit    <-           formatTime SelFormatDateTime  $ materialLastEdit    material
-  materialVisibleFrom <- traverse (formatTime SelFormatDateTime) matVisFro
-  when (NTop matVisFro >= NTop (Just now)) $ addMessageI Warning $
-    maybe MsgMaterialInvisible MsgMaterialInvisibleUntil materialVisibleFrom
 
   let headingLong  = prependCourseTitle tid ssh csh $ MsgMaterialHeading mnm
       headingShort = prependCourseTitle tid ssh csh $ SomeMessage mnm

src/Handler/Utils.hs

@@ -37,6 +37,8 @@ import System.FilePath.Posix (takeBaseName, takeFileName)
 import qualified Data.List as List
 import qualified Data.List.NonEmpty as NonEmpty
 
+import Control.Monad.Logger
+
 
 -- | Check whether the user's preference for files is inline-viewing or downloading
 downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
@@ -80,7 +82,7 @@ serveSomeFiles archiveName source = do
   results <- runDB . runConduit $ source .| peekN 2
 
   $logDebugS "serveSomeFiles" . tshow $ length results
-  
+
   case results of
     []         -> notFound
     [file]     -> sendThisFile file
@@ -91,9 +93,27 @@ serveSomeFiles archiveName source = do
         source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
 
 
+
+---------
+-- Simple utilities for consistent display
+-- Please use these throughout, to ensure that users have a consistent experience
+
 tidFromText :: Text -> Maybe TermId
 tidFromText = fmap TermKey . maybeRight . termFromText
 
+-- | Display given UTCTime and maybe an invisible icon if it is in the future
+--
+--   Also see `Handler.Utils.Table.Cells.dateTimeCellVisible` for a similar function (in case of refactoring)
+visibleUTCTime :: SelDateTimeFormat -> UTCTime -> Widget
+visibleUTCTime dtf t = do
+    let timeStampWgt = formatTimeW dtf t
+    now <- liftIO getCurrentTime
+    if now >= t
+      then timeStampWgt
+      else $(widgetFile "widgets/date-time/yet-invisible")
+
+
+-- | Simple link to a known route
 simpleLink :: Widget -> Route UniWorX -> Widget
 simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]
 
@@ -229,3 +249,12 @@ guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h
   => Route UniWorX -> a -> m (ReaderT SqlBackend h) a
 guardAuthorizedFor link val =
   val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False)
+
+  
+runAppLoggingT :: UniWorX -> LoggingT m a -> m a
+runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
+  where
+    logFunc loc src lvl str = do
+      f <- messageLoggerSource app <$> readTVarIO loggerTVar
+      f loc src lvl str
+

src/Handler/Utils/Communication.hs

@@ -20,9 +20,6 @@ import Data.Map ((!), (!?))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
-import Data.Aeson.TH
-import Data.Aeson.Types (ToJSONKey(..), FromJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..))
-
 
 data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors
                     | RGTutorialParticipants

src/Handler/Utils/Form.hs

@@ -420,8 +420,8 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp
                 let iStart = maybe 0 (succ . fst) $ Map.lookupMax oldRess
                  in pure $ Map.singleton iStart fileRes
           return (addRes', formWidget')
-        miCell _ initFile initFile' nudge csrf =
+        miCell _ initFile _ nudge csrf =
-          sFileForm nudge (Just $ fromMaybe initFile initFile') csrf
+          sFileForm nudge (Just initFile) csrf
         miDelete = miDeleteList
         miAllowAdd _ _ _ = True
         miAddEmpty _ _ _ = Set.empty

src/Handler/Utils/Form/MassInput.hs

@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- tupleBoxCoord
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module Handler.Utils.Form.MassInput
@@ -9,6 +9,7 @@ module Handler.Utils.Form.MassInput
   , massInputA, massInputW
   , massInputList
   , massInputAccum, massInputAccumA, massInputAccumW
+  , massInputAccumEdit, massInputAccumEditA, massInputAccumEditW
   , ListLength(..), ListPosition(..), miDeleteList
   , EnumLiveliness(..), EnumPosition(..)
   , MapLiveliness(..)
@@ -20,8 +21,6 @@ import Utils.Lens
 import Handler.Utils.Form.MassInput.Liveliness
 import Handler.Utils.Form.MassInput.TH
 
-import Data.Aeson hiding (Result(..))
-
 import Algebra.Lattice hiding (join)
 
 import Text.Blaze (Markup)
@@ -566,6 +565,83 @@ massInputAccumW :: forall handler cellData ident.
 massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
   = mFormToWForm $ massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty
 
+  
+-- | Wrapper around `massInput` for the common case, that we just want a list of data with existing data modified the same way as new data is added
+massInputAccumEdit :: forall handler cellData ident.
+                      ( MonadHandler handler, HandlerSite handler ~ UniWorX
+                      , MonadLogger handler
+                      , ToJSON cellData, FromJSON cellData
+                      , PathPiece ident
+                      )
+                   => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
+                   -> ((Text -> Text) -> cellData          -> (Markup -> MForm handler (FormResult cellData, Widget)))
+                   -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+                   -> MassInputLayout ListLength cellData cellData
+                   -> ident
+                   -> FieldSettings UniWorX
+                   -> Bool
+                   -> Maybe [cellData]
+                   -> (Markup -> MForm handler (FormResult [cellData], FieldView UniWorX))
+massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequired mPrev csrf
+  = over (_1 . mapped) (map snd . Map.elems) <$> massInput MassInput{..} fSettings fRequired (Map.fromList . zip [0..] . map (\x -> (x, x)) <$> mPrev) csrf
+  where
+    miAdd :: ListPosition -> Natural
+          -> (Text -> Text) -> FieldView UniWorX
+          -> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
+    miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf'
+
+    doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
+    doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
+      where
+        prevElems = Map.elems prevData
+        startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData
+
+    miCell :: ListPosition -> cellData -> Maybe cellData -> (Text -> Text)
+           -> (Markup -> MForm handler (FormResult cellData, Widget))
+    miCell _pos dat _mPrev nudge = miCell' nudge dat
+
+    miDelete = miDeleteList
+
+    miAllowAdd _ _ _ = True
+
+    miAddEmpty _ _ _ = Set.empty
+
+massInputAccumEditA :: forall handler cellData ident.
+                       ( MonadHandler handler, HandlerSite handler ~ UniWorX
+                       , MonadLogger handler
+                       , ToJSON cellData, FromJSON cellData
+                       , PathPiece ident
+                       )
+                    => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
+                    -> ((Text -> Text) -> cellData          -> (Markup -> MForm handler (FormResult cellData, Widget)))
+                    -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+                    -> MassInputLayout ListLength cellData cellData
+                    -> ident
+                    -> FieldSettings UniWorX
+                    -> Bool
+                    -> Maybe [cellData]
+                    -> AForm handler [cellData]
+massInputAccumEditA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
+  = formToAForm $ over _2 pure <$> massInputAccumEdit miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty
+
+massInputAccumEditW :: forall handler cellData ident.
+                       ( MonadHandler handler, HandlerSite handler ~ UniWorX
+                       , MonadLogger handler
+                       , ToJSON cellData, FromJSON cellData
+                       , PathPiece ident
+                       )
+                    => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
+                    -> ((Text -> Text) -> cellData          -> (Markup -> MForm handler (FormResult cellData, Widget)))
+                    -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+                    -> MassInputLayout ListLength cellData cellData
+                    -> ident
+                    -> FieldSettings UniWorX
+                    -> Bool
+                    -> Maybe [cellData]
+                    -> WForm handler (FormResult [cellData])
+massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
+  = mFormToWForm $ massInputAccumEdit miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty
+
 
 massInputA :: forall handler cellData cellResult liveliness.
            ( MonadHandler handler, HandlerSite handler ~ UniWorX

src/Handler/Utils/Invitations.hs

@@ -32,7 +32,6 @@ import qualified Data.HashSet as HashSet
 
 import Data.Aeson (fromJSON)
 import qualified Data.Aeson as JSON
-import Data.Aeson.TH
 
 import Data.Proxy (Proxy(..))
 import Data.Typeable

src/Handler/Utils/Submission.hs

@@ -129,7 +129,7 @@ assignSubmissions sid restriction = do
         (E.Value sheetId, Entity subId Submission{..}, _) <- submissionDataRaw
         guard $ sheetId == sid
         case restriction of
-          Just restriction' -> 
+          Just restriction' ->
             guard $ subId `Set.member` restriction'
           Nothing ->
             guard $ is _Nothing submissionRatingBy
@@ -146,7 +146,7 @@ assignSubmissions sid restriction = do
                          => (Map SubmissionId a -> b)
                          -> m b
       withSubmissionData f = f <$> (mappend <$> ask <*> State.get)
-      
+
       -- | How many additional submission should the given corrector be assigned, if possible?
       calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational
       calculateDeficit corrector submissionState = getSum $ foldMap Sum deficitBySheet
@@ -178,7 +178,7 @@ assignSubmissions sid restriction = do
                     , fromMaybe 0 $ do
                         guard $ corrState /= CorrectorExcused
                         return . negate $ (byProportion / proportionSum) * fromIntegral sheetSize
-                    ] 
+                    ]
                   | otherwise
                   = assigned
             return $ negate extra
@@ -257,6 +257,7 @@ submissionMultiArchive (Set.toList -> ids) = do
         execWriter . forM ratedSubmissions $ \(_rating,_submission,(shn,csh,ssh,tid)) ->
           tell (Set.singleton shn, Set.singleton csh, Set.singleton ssh, Set.singleton tid)
 
+  setContentDisposition' $ Just "submissions.zip"
   (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
     let
       fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> Source (YesodDB UniWorX) File

src/Handler/Utils/Table/Cells.hs

@@ -131,7 +131,9 @@ dateCell t = cell $ formatTime SelFormatDate t >>= toWidget
 dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a
 dateTimeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
 
--- | Show a date, and highlight date earlier than given watershed with an icon
+-- | Show a date, and highlight date earlier than given watershed with an icon and cell class Warning
+--
+--   Cannot use `Handler.Utils.visibleUTCTime`, since setting the UrgencyClass must be done outside the monad, hence the watershed argument.
 dateTimeCellVisible :: IsDBTable m a => UTCTime -> UTCTime -> DBCell m a
 dateTimeCellVisible watershed t
     | watershed < t = cell $(widgetFile "widgets/date-time/yet-invisible") & addUrgencyClass

src/Handler/Utils/Table/Columns.hs

@@ -151,7 +151,7 @@ fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bo
   -> (d, FilterColumn t)
 fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName))
 
--- | Searche all names, i.e. DisplayName, Surname, EMail
+-- | Search all names, i.e. DisplayName, Surname, EMail
 fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
    => (a -> E.SqlExpr (Entity User))
    -> (d, FilterColumn t)

src/Handler/Utils/Table/Pagination.hs

@@ -1,5 +1,3 @@
-{-# OPTIONS -fno-warn-orphans #-}
-
 module Handler.Utils.Table.Pagination
   ( module Handler.Utils.Table.Pagination.Types
   , SortColumn(..), SortDirection(..)
@@ -15,6 +13,7 @@ module Handler.Utils.Table.Pagination
   , PagesizeLimit(..)
   , PaginationSettings(..), PaginationInput(..), piIsUnset
   , PSValidator(..)
+  , defaultPagesize
   , defaultFilter, defaultSorting
   , restrictFilter, restrictSorting
   , ToSortable(..), Sortable(..)
@@ -316,6 +315,13 @@ defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable' -> inje
       Just _  -> id
       Nothing -> set (_2._psSorting) psSorting
 
+defaultPagesize :: PagesizeLimit -> PSValidator m x -> PSValidator m x
+defaultPagesize psLimit (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
+  where
+    injectDefault x = case x >>= piLimit of
+      Just _  -> id
+      Nothing -> set (_2._psLimit) psLimit
+
 restrictFilter :: (FilterKey -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
 restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps
   where

src/Import/NoFoundation.hs

@@ -1,107 +1,17 @@
 module Import.NoFoundation
     ( module Import
-    , MForm
     ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons)
+import Import.NoModel         as Import
 import Model                  as Import
-import Model.Types.JSON       as Import
 import Model.Migration        as Import
 import Model.Rating           as Import
 import Model.Submission       as Import
 import Model.Tokens           as Import
+import Utils.Tokens           as Import
+import Utils.Frontend.Modal   as Import
+
 import Settings               as Import
 import Settings.StaticFiles   as Import
-import Yesod.Auth             as Import
-import Yesod.Core.Types       as Import (loggerSet)
-import Yesod.Default.Config2  as Import
-import Utils                  as Import
-import Utils.Frontend.Modal   as Import
-import Utils.Frontend.I18n    as Import
-import Utils.DB               as Import
-import Yesod.Core.Json        as Import (provideJson)
-import Yesod.Core.Types.Instances as Import (CachedMemoT(..))
-
-import Language.Haskell.TH.Instances as Import ()
-
-import Utils.Tokens           as Import
-
-
-import Data.Fixed             as Import
 
 import CryptoID               as Import
-import Data.UUID              as Import (UUID)
-
-import Text.Lucius            as Import
-
-import Text.Shakespeare.Text  as Import hiding (text, stext)
-
-import Data.Universe          as Import
-import Data.Universe.TH       as Import
-import Data.Pool              as Import (Pool)
-import Network.HaskellNet.SMTP as Import (SMTPConnection)
-
-import Mail                   as Import
-
-import Data.Data              as Import (Data)
-import Data.Typeable          as Import (Typeable)
-import GHC.Generics           as Import (Generic)
-import GHC.Exts               as Import (IsList)
-
-import Data.Hashable          as Import
-import Data.List.NonEmpty     as Import (NonEmpty(..), nonEmpty)
-import Data.List.NonEmpty.Instances as Import ()
-import Data.NonNull.Instances as Import ()
-import Data.Text.Encoding.Error as Import(UnicodeException(..))
-import Data.Semigroup         as Import (Semigroup)
-import Data.Monoid            as Import (Last(..), First(..), Any(..), All(..), Sum(..))
-import Data.Monoid.Instances  as Import ()
-import Data.Set.Instances     as Import ()
-import Data.HashMap.Strict.Instances as Import ()
-import Data.HashSet.Instances as Import ()
-import Data.Vector.Instances  as Import ()
-import Data.Time.Clock.Instances as Import ()
-
-import Data.Binary            as Import (Binary)
-
-import Control.Monad.Morph    as Import (MFunctor(..))
-
-import Control.Monad.Trans.Resource as Import (ReleaseKey)
-
-import Network.Mail.Mime.Instances as Import ()
-import Yesod.Core.Instances as Import ()
-import Data.Aeson.Types.Instances as Import ()
-
-import Ldap.Client.Pool as Import
-
-import Database.Esqueleto.Instances as Import ()
-import Database.Persist.Sql.Instances as Import ()
-import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
-import Database.Persist.Types.Instances as Import ()
-
-import Numeric.Natural.Instances as Import ()
-import System.Random as Import (Random)
-import Control.Monad.Random.Class as Import (MonadRandom(..))
-
-import Text.Blaze.Instances as Import ()
-import Jose.Jwt.Instances as Import ()
-import Jose.Jwt as Import (Jwt)
-import Web.PathPieces.Instances as Import ()
-
-import Data.Time.Calendar as Import
-import Data.Time.Clock as Import
-import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC)
-import Time.Types as Import (WeekDay(..))
-
-import Time.Types.Instances as Import ()
-
-import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase)
-
-import Data.Ratio as Import ((%))
-
-import Network.Mime as Import
-
-
-import Control.Monad.Trans.RWS (RWST)
-
-type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m

src/Import/NoModel.hs

@@ -0,0 +1,105 @@
+module Import.NoModel
+  ( module Import
+  , MForm
+  ) where
+
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons)
+
+import Model.Types.TH.JSON as Import
+import Model.Types.TH.Wordlist as Import
+
+import Mail                   as Import
+
+import Yesod.Auth             as Import
+import Yesod.Core.Types       as Import (loggerSet)
+import Yesod.Default.Config2  as Import
+import Yesod.Core.Json        as Import (provideJson)
+import Yesod.Core.Types.Instances as Import
+
+import Utils                  as Import
+import Utils.Frontend.I18n    as Import
+import Utils.DB               as Import
+
+import Data.Fixed             as Import
+
+import Data.UUID              as Import (UUID)
+
+import Data.CaseInsensitive   as Import (CI, FoldCase(..), foldedCase)
+
+import Text.Lucius            as Import
+import Text.Shakespeare.Text  as Import hiding (text, stext)
+
+import Data.Universe          as Import
+import Data.Universe.TH       as Import
+import Data.Pool              as Import (Pool)
+import Network.HaskellNet.SMTP as Import (SMTPConnection)
+
+import Data.Data              as Import (Data)
+import Data.Typeable          as Import (Typeable)
+import GHC.Generics           as Import (Generic)
+import GHC.Exts               as Import (IsList)
+import Data.Ix                as Import (Ix)
+
+import Data.Hashable          as Import
+import Data.List.NonEmpty     as Import (NonEmpty(..), nonEmpty)
+import Data.Text.Encoding.Error as Import(UnicodeException(..))
+import Data.Semigroup         as Import (Semigroup)
+import Data.Monoid            as Import (Last(..), First(..), Any(..), All(..), Sum(..))
+import Data.Binary            as Import (Binary)
+
+import Numeric.Natural        as Import (Natural)
+import Data.Ratio             as Import ((%))
+
+import Database.Persist.Sql as Import (SqlReadT, SqlWriteT, fromSqlKey, toSqlKey)
+  
+import Ldap.Client.Pool as Import
+
+import System.Random as Import (Random(..))
+import Control.Monad.Random.Class as Import (MonadRandom(..))
+
+import Control.Monad.Morph    as Import (MFunctor(..))
+import Control.Monad.Trans.Resource as Import (ReleaseKey)
+
+import Jose.Jwt as Import (Jwt)
+
+import Data.Time.Calendar as Import
+import Data.Time.Clock as Import
+import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC)
+import Time.Types as Import (WeekDay(..))
+
+import Network.Mime as Import
+  
+import Data.Aeson.TH as Import
+import Data.Aeson.Types as Import (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..), ToJSONKeyFunction(..), Value)
+
+import Language.Haskell.TH.Instances as Import ()
+import Data.List.NonEmpty.Instances as Import ()
+import Data.NonNull.Instances as Import ()
+import Data.Monoid.Instances  as Import ()
+import Data.Set.Instances     as Import ()
+import Data.HashMap.Strict.Instances as Import ()
+import Data.HashSet.Instances as Import ()
+import Data.Vector.Instances  as Import ()
+import Data.Time.Clock.Instances as Import ()
+import Data.Time.LocalTime.Instances as Import ()
+import Data.Time.Calendar.Instances as Import ()
+import Data.Time.Format.Instances as Import ()
+import Time.Types.Instances as Import ()
+import Network.Mail.Mime.Instances as Import ()
+import Yesod.Core.Instances as Import ()
+import Data.Aeson.Types.Instances as Import ()
+import Database.Esqueleto.Instances as Import ()
+import Numeric.Natural.Instances as Import ()
+import Text.Blaze.Instances as Import ()
+import Jose.Jwt.Instances as Import ()
+import Web.PathPieces.Instances as Import ()
+import Data.Universe.Instances.Reverse.MonoTraversable ()
+import Database.Persist.Class.Instances as Import ()
+import Database.Persist.Types.Instances as Import ()
+import Data.UUID.Instances as Import ()
+import System.FilePath.Instances as Import ()
+
+
+import Control.Monad.Trans.RWS (RWST)
+
+type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m

src/Jobs.hs

@@ -7,6 +7,7 @@ module Jobs
 
 import Import
 import Utils.Lens
+import Handler.Utils
 
 import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
 import Jobs.Types (JobCtl(JobCtlQueue))
@@ -32,6 +33,7 @@ import Control.Monad.Random (evalRand, mkStdGen, getRandomR)
 import Cron
 import qualified Data.HashMap.Strict as HashMap
 import Data.HashMap.Strict (HashMap)
+import qualified Data.Set as Set
 
 import qualified Data.List.NonEmpty as NonEmpty
 
@@ -51,8 +53,6 @@ import Data.Time.Zones
 
 import Control.Concurrent.STM (retry)
 
-import qualified System.Systemd.Daemon as Systemd
-
 
 import Jobs.Handler.SendNotification
 import Jobs.Handler.SendTestEmail
@@ -94,7 +94,7 @@ handleJobs foundation@UniWorX{..} = do
       logStart = $logDebugS ("Jobs #" <> tshow n) "Starting"
       logStop = $logDebugS ("Jobs #" <> tshow n) "Stopping"
       removeChan = atomically . modifyTVar' appJobCtl . Map.delete =<< myThreadId
-      doFork = flip forkFinally (\_ -> removeChan) . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n
+      doFork = flip forkFinally (\_ -> removeChan) . runAppLoggingT foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' foundation n
     (_, tId) <- allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan)
     atomically . modifyTVar' appJobCtl $ Map.insert tId bChan
 
@@ -102,7 +102,7 @@ handleJobs foundation@UniWorX{..} = do
   when (num > 0) $ do
     registeredCron <- liftIO newEmptyTMVarIO
     let execCrontab' = whenM (atomically $ readTMVar registeredCron) $
-          unsafeHandler foundation $ runReaderT execCrontab JobContext{..}
+          runReaderT (execCrontab foundation) 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
@@ -127,73 +127,75 @@ stopJobCtl UniWorX{appJobCtl, appCronThread} = do
     guard . none (`Map.member` wMap') $ Map.keysSet wMap
 
 
-execCrontab :: ReaderT JobContext (HandlerT UniWorX IO) ()
+execCrontab :: MonadIO m => UniWorX -> ReaderT JobContext m ()
 -- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have
 --   seen, wait for the time of the next job and fire it
-execCrontab = evalStateT go HashMap.empty
+execCrontab foundation = evalStateT go HashMap.empty
   where
     go = do
-      mapStateT (liftHandlerT . runDB . setSerializable) $ do
+      cont <- mapStateT (mapReaderT $ liftIO . unsafeHandler foundation) $ do
-        let
+        mapStateT (liftHandlerT . runDB . setSerializable) $ do
-          merge (Entity leId CronLastExec{..})
+          let
-            | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
+            merge (Entity leId CronLastExec{..})
-            = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
+              | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
-            | otherwise = lift $ delete leId
+              = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
-        runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
+              | otherwise = lift $ delete leId
+          runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
 
-      refT <- liftIO getCurrentTime
+        refT <- liftIO getCurrentTime
-      settings <- getsYesod appSettings'
+        settings <- getsYesod appSettings'
-      currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
+        currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
-        crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
+          crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
-        case crontab' of
+          case crontab' of
-          Nothing -> return Nothing
+            Nothing -> return Nothing
-          Just crontab -> Just <$> do
+            Just crontab -> Just <$> do
-            State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
+              State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
-            prevExec <- State.get
+              prevExec <- State.get
-            case earliestJob settings prevExec crontab refT of
+              case earliestJob settings prevExec crontab refT of
-              Nothing -> liftBase retry
+                Nothing -> liftBase retry
-              Just (_, MatchNone) -> liftBase retry
+                Just (_, MatchNone) -> liftBase retry
-              Just x -> return (crontab, x)
+                Just x -> return (crontab, x)
 
-      case currentState of
+        case currentState of
-        Nothing -> return ()
+          Nothing -> return False
-        Just (currentCrontab, (jobCtl, nextMatch)) -> do
+          Just (currentCrontab, (jobCtl, nextMatch)) -> do
-          let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do
+            let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do
-                  newCrontab <- lift . lift . hoist lift $ determineCrontab'
+                    newCrontab <- lift . lift . hoist lift $ determineCrontab'
-                  if
+                    if
-                    | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
+                      | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
-                      -> do
+                        -> do
-                        now <- liftIO $ getCurrentTime
+                          now <- liftIO $ getCurrentTime
-                        instanceID' <- getsYesod appInstanceID
+                          instanceID' <- getsYesod appInstanceID
-                        State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
+                          State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
-                        case jobCtl of
+                          case jobCtl of
-                          JobCtlQueue job -> do
+                            JobCtlQueue job -> do
-                            void . lift . lift $ upsertBy
+                              void . lift . lift $ upsertBy
-                              (UniqueCronLastExec $ toJSON job)
+                                (UniqueCronLastExec $ toJSON job)
-                              CronLastExec
+                                CronLastExec
-                                { cronLastExecJob = toJSON job
+                                  { cronLastExecJob = toJSON job
-                                , cronLastExecTime = now
+                                  , cronLastExecTime = now
-                                , cronLastExecInstance = instanceID'
+                                  , cronLastExecInstance = instanceID'
-                                }
+                                  }
-                              [ CronLastExecTime =. now ]
+                                [ CronLastExecTime =. now ]
-                            lift . lift $ queueDBJob job
+                              lift . lift $ queueDBJob job
-                          other -> writeJobCtl other
+                            other -> writeJobCtl other
-                    | otherwise
+                      | otherwise
-                      -> lift . mapReaderT (liftIO . atomically) $
+                        -> lift . mapReaderT (liftIO . atomically) $
-                           lift . void . flip swapTMVar newCrontab =<< asks jobCrontab
+                             lift . void . flip swapTMVar newCrontab =<< asks jobCrontab
 
-          case nextMatch of
+            case nextMatch of
-            MatchAsap -> doJob
+              MatchAsap -> doJob
-            MatchNone -> return ()
+              MatchNone -> return ()
-            MatchAt nextTime -> do
+              MatchAt nextTime -> do
-              JobContext{jobCrontab} <- ask
+                JobContext{jobCrontab} <- ask
-              nextTime' <- applyJitter jobCtl nextTime
+                nextTime' <- applyJitter jobCtl nextTime
-              $logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|]
+                $logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|]
-              logFunc <- askLoggerIO
+                logFunc <- askLoggerIO
-              whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
+                whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
-                doJob
+                  doJob
 
-          go
+            return True
+      when cont go
       where
         acc :: NominalDiffTime
         acc = 1e-3
@@ -245,12 +247,12 @@ execCrontab = evalStateT go HashMap.empty
                 bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged
 
 
-handleJobs' :: Natural -> Sink JobCtl (ReaderT JobContext Handler) ()
+handleJobs' :: (MonadIO m, MonadLogger m, MonadCatch m) => UniWorX -> Natural -> Sink JobCtl (ReaderT JobContext m) ()
-handleJobs' wNum = C.mapM_ $ \jctl -> do
+handleJobs' foundation wNum = C.mapM_ $ \jctl -> do
   $logDebugS logIdent $ tshow jctl
   resVars <- mapReaderT (liftIO . atomically) $
     HashMap.lookup jctl <$> (lift . readTVar =<< asks jobConfirm)
-  res <- fmap (either Just $ const Nothing) . try $ handleCmd jctl
+  res <- fmap (either Just $ const Nothing) . try . (mapReaderT $ liftIO . unsafeHandler foundation) $ handleCmd jctl
   sentRes <- liftIO . atomically $ foldrM (\resVar -> bool (tryPutTMVar resVar res) $ return True) False (maybe [] NonEmpty.toList resVars)
   case res of
     Just err
@@ -284,21 +286,19 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
       -- logDebugS logIdent $ tshow newCTab
       mapReaderT (liftIO . atomically) $ 
         lift . void . flip swapTMVar newCTab =<< asks jobCrontab
-    handleCmd JobCtlGenerateHealthReport = do
+    handleCmd (JobCtlGenerateHealthReport kind) = do
       hrStorage <- getsYesod appHealthReport
-      newReport@(classifyHealthReport -> newStatus) <- lift generateHealthReport
+      newReport@(healthReportStatus -> newStatus) <- lift $ generateHealthReport kind
 
-      $logInfoS "HealthReport" $ toPathPiece newStatus
+      $logInfoS (tshow kind) $ toPathPiece newStatus
       unless (newStatus == HealthSuccess) $ do
-        $logErrorS "HealthReport" $ tshow newReport
+        $logErrorS (tshow kind) $ tshow newReport
   
       liftIO $ do
         now <- getCurrentTime
-        atomically . writeTVar hrStorage $ Just (now, newReport)
+        let updateReports = Set.insert (now, newReport)
-        
+                          . Set.filter (((/=) `on` classifyHealthReport) newReport . snd)
-        void . Systemd.notifyStatus . unpack $ toPathPiece newStatus
+        atomically . modifyTVar' hrStorage $ force . updateReports
-        when (newStatus == HealthSuccess) $
-          void Systemd.notifyWatchdog
 
 jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a
 jLocked jId act = do

src/Jobs/Crontab.hs

@@ -43,14 +43,17 @@ determineCrontab = execWriterT $ do
       , cronNotAfter = Right CronNotScheduled
       }
 
-  tell $ HashMap.singleton
+  tell . flip foldMap universeF $ \kind -> 
-    JobCtlGenerateHealthReport
+    case appHealthCheckInterval kind of
-    Cron
+      Just int -> HashMap.singleton
-      { cronInitial = CronAsap
+        (JobCtlGenerateHealthReport kind)
-      , cronRepeat = CronRepeatScheduled CronAsap
+        Cron
-      , cronRateLimit = appHealthCheckInterval
+          { cronInitial = CronAsap
-      , cronNotAfter = Right CronNotScheduled
+          , cronRepeat = CronRepeatScheduled CronAsap
-      }
+          , cronRateLimit = int
+          , cronNotAfter = Right CronNotScheduled
+          }
+      Nothing  -> mempty
 
   let
     sheetJobs (Entity nSheet Sheet{..}) = do

src/Jobs/HealthReport.hs

@@ -28,18 +28,13 @@ import qualified Network.HaskellNet.SMTP as SMTP
 import Data.Pool (withResource)
 
 
-generateHealthReport :: Handler HealthReport
+generateHealthReport :: HealthCheck -> Handler HealthReport
-generateHealthReport
+generateHealthReport = $(dispatchTH ''HealthCheck)
-  = runConcurrently $ HealthReport
-    <$> Concurrently matchingClusterConfig
-    <*> Concurrently httpReachable
-    <*> Concurrently ldapAdmins
-    <*> Concurrently smtpConnect
-    <*> Concurrently widgetMemcached
   
-matchingClusterConfig :: Handler Bool
+dispatchHealthCheckMatchingClusterConfig :: Handler HealthReport
 -- ^ Can the cluster configuration be read from the database and does it match our configuration?
-matchingClusterConfig = runDB $ and <$> forM universeF clusterSettingMatches
+dispatchHealthCheckMatchingClusterConfig
+  = fmap HealthMatchingClusterConfig . runDB $ and <$> forM universeF clusterSettingMatches
   where
     clusterSettingMatches ClusterCryptoIDKey = do
       ourSetting <- getsYesod appCryptoIDKey
@@ -74,11 +69,11 @@ matchingClusterConfig = runDB $ and <$> forM universeF clusterSettingMatches
         _other                 -> return Nothing
 
 
-httpReachable :: Handler (Maybe Bool)
+dispatchHealthCheckHTTPReachable :: Handler HealthReport
-httpReachable = do
+dispatchHealthCheckHTTPReachable = HealthHTTPReachable <$> do
   staticAppRoot <- getsYesod $ view _appRoot
   doHTTP <- getsYesod $ view _appHealthCheckHTTP
-  for (staticAppRoot <* guard doHTTP) $ \_textAppRoot -> do
+  for (staticAppRoot <* guard doHTTP) $ \_ -> do
     url <- getUrlRender <*> pure InstanceR
     baseRequest <- HTTP.parseRequest $ unpack url
     httpManager <- getsYesod appHttpManager
@@ -88,8 +83,8 @@ httpReachable = do
     getsYesod $ (== clusterId) . appClusterID
 
 
-ldapAdmins :: Handler (Maybe Rational)
+dispatchHealthCheckLDAPAdmins :: Handler HealthReport
-ldapAdmins = do
+dispatchHealthCheckLDAPAdmins = HealthLDAPAdmins <$> do
   ldapPool' <- getsYesod appLdapPool
   ldapConf' <- getsYesod $ view _appLdapConf
   ldapAdminUsers <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
@@ -109,8 +104,8 @@ ldapAdmins = do
     _other -> return Nothing
 
 
-smtpConnect :: Handler (Maybe Bool)
+dispatchHealthCheckSMTPConnect :: Handler HealthReport
-smtpConnect = do
+dispatchHealthCheckSMTPConnect = HealthSMTPConnect <$> do
   smtpPool <- getsYesod appSmtpPool
   for smtpPool . flip withResource $ \smtpConn -> do
     response@(rCode, _) <- liftIO $ SMTP.sendCommand smtpConn SMTP.NOOP
@@ -121,8 +116,8 @@ smtpConnect = do
         return False
 
 
-widgetMemcached :: Handler (Maybe Bool)
+dispatchHealthCheckWidgetMemcached :: Handler HealthReport
-widgetMemcached = do
+dispatchHealthCheckWidgetMemcached = HealthWidgetMemcached <$> do
   memcachedConn <- getsYesod appWidgetMemcached
   for memcachedConn $ \_memcachedConn' -> do
     let ext = "bin"

src/Jobs/Types.hs

@@ -69,7 +69,7 @@ data JobCtl = JobCtlFlush
             | JobCtlPerform QueuedJobId
             | JobCtlDetermineCrontab
             | JobCtlQueue Job
-            | JobCtlGenerateHealthReport
+            | JobCtlGenerateHealthReport HealthCheck
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 instance Hashable JobCtl

src/Mail.hs

@@ -35,7 +35,9 @@ module Mail
   , _partType, _partEncoding, _partFilename, _partHeaders, _partContent
   ) where
 
-import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender)
+import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON)
+
+import Model.Types.TH.JSON
 
 import Network.Mail.Mime hiding (addPart, addAttachment)
 import qualified Network.Mail.Mime as Mime (addPart)
@@ -159,6 +161,7 @@ instance Default MailLanguages where
 
 instance Hashable MailLanguages
 
+
 data MailContext = MailContext
   { mcLanguages :: MailLanguages
   , mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat
@@ -506,3 +509,6 @@ setMailSmtpData = do
         in tell $ mempty { smtpEnvelopeFrom = Last $ Just verp }
     | otherwise
     -> tell $ mempty { smtpEnvelopeFrom = Last $ Just from }
+
+
+derivePersistFieldJSON ''MailLanguages

src/Model.hs

@@ -6,7 +6,7 @@ module Model
   , module Cron.Types
   ) where
 
-import ClassyPrelude.Yesod
+import Import.NoModel
 import Database.Persist.Quasi
 import Database.Persist.TH.Directory
 -- import Data.Time
@@ -23,8 +23,6 @@ import Utils.Message (MessageStatus)
 
 import Settings.Cluster (ClusterSettingsKey)
 
-import Data.Binary (Binary)
-
 -- You can define all of your database entities in the entities file.
 -- You can find more information on persistent and how to declare entities
 -- at:
@@ -38,9 +36,5 @@ deriving instance Eq (Unique Sheet)     -- instance Eq CourseSheet
 deriving instance Eq (Unique Material)  -- instance Eq UniqueMaterial
 deriving instance Eq (Unique Tutorial)  -- instance Eq Tutorial
 
--- Primary keys mentioned in dbtable row-keys must be Binary
--- Automatically generated (i.e. numeric) ids are already taken care of
-deriving instance Binary (Key Term)
-
 submissionRatingDone :: Submission -> Bool
 submissionRatingDone Submission{..} = isJust submissionRatingTime

src/Model/Migration/Types.hs

@@ -7,7 +7,7 @@ import Data.Aeson.TH (deriveJSON, defaultOptions)
 import Utils.PathPiece
 
 import qualified Model as Current
-import qualified Model.Types.JSON as Current
+import qualified Model.Types.TH.JSON as Current
 
 import Data.Universe
 

src/Model/Types.hs

@@ -1,72 +1,14 @@
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
-
-
-
 module Model.Types
-  ( module Model.Types
+  ( module Types
-  , module Model.Types.Sheet
-  , module Model.Types.DateTime
-  , module Model.Types.Security
-  , module Model.Types.Misc
-  , module Numeric.Natural
-  , module Mail
-  , module Utils.DateTime
-  , module Data.UUID.Types
   ) where
 
-import ClassyPrelude
+import Model.Types.Common as Types
-import Data.UUID.Types (UUID)
+import Model.Types.Course as Types
-import qualified Data.UUID.Types as UUID
+import Model.Types.DateTime as Types
-import Data.NonNull.Instances ()
+import Model.Types.Exam as Types
-
+import Model.Types.Health as Types
-import Data.Text (Text)
+import Model.Types.Mail as Types
-import qualified Data.Text as Text
+import Model.Types.Security as Types
-import Data.CaseInsensitive (CI)
+import Model.Types.Sheet as Types
-import Data.CaseInsensitive.Instances ()
+import Model.Types.Submission as Types
-
+import Model.Types.Misc as Types
-import Data.Universe.Instances.Reverse ()
-
-import Yesod.Core.Dispatch (PathPiece(..))
-import qualified Yesod.Auth.Util.PasswordStore as PWStore
-import Web.PathPieces
-
-import Mail (MailLanguages(..))
-import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..))
-import Numeric.Natural
-
-import Model.Types.Sheet
-import Model.Types.DateTime
-import Model.Types.Security
-import Model.Types.Misc
-
-----
--- Just bringing together the different Model.Types submodules.
-
-instance PathPiece UUID where
-  fromPathPiece = UUID.fromString . unpack
-  toPathPiece = pack . UUID.toString
-
-instance {-# OVERLAPS #-} PathMultiPiece FilePath where
-  fromPathMultiPiece = Just . unpack . intercalate "/"
-  toPathMultiPiece = Text.splitOn "/" . pack
-
-
--- Type synonyms
-
-type Email           = Text
-
-type SchoolName      = CI Text
-type SchoolShorthand = CI Text
-type CourseName      = CI Text
-type CourseShorthand = CI Text
-type SheetName       = CI Text
-type MaterialName    = CI Text
-type UserEmail       = CI Email
-type TutorialName    = CI Text
-
-type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
-type InstanceId      = UUID
-type ClusterId       = UUID
-type TokenId         = UUID
-type TermCandidateIncidence = UUID

src/Model/Types/Common.hs

@@ -0,0 +1,35 @@
+{-|
+Module: Model.Types.Common
+Description: Common types used by most @Model.Types.*@-Modules
+
+Types used by multiple other @Model.Types.*@-Modules
+-}
+module Model.Types.Common
+  ( module Model.Types.Common
+  ) where
+
+import Import.NoModel
+
+import qualified Yesod.Auth.Util.PasswordStore as PWStore
+  
+
+type Count  = Sum Integer
+type Points = Centi
+
+
+type Email           = Text
+
+type SchoolName      = CI Text
+type SchoolShorthand = CI Text
+type CourseName      = CI Text
+type CourseShorthand = CI Text
+type SheetName       = CI Text
+type MaterialName    = CI Text
+type UserEmail       = CI Email
+type TutorialName    = CI Text
+
+type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
+type InstanceId      = UUID
+type ClusterId       = UUID
+type TokenId         = UUID
+type TermCandidateIncidence = UUID

src/Model/Types/Course.hs

@@ -0,0 +1,26 @@
+{-|
+Module: Model.Types.Course
+Description: Types for modeling Courses
+
+Also see `Model.Types.Sheet`
+-}
+module Model.Types.Course
+  ( module Model.Types.Course
+  ) where
+
+import Import.NoModel
+
+
+data LecturerType = CourseLecturer | CourseAssistant
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+
+instance Universe LecturerType
+instance Finite LecturerType
+
+nullaryPathPiece ''LecturerType $ camelToPathPiece' 1
+deriveJSON  defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  } ''LecturerType
+derivePersistFieldJSON ''LecturerType
+
+instance Hashable LecturerType

src/Model/Types/DateTime.hs

@@ -1,34 +1,28 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving
+{-|
-           , UndecidableInstances
+Module: Model.Types.DateTime
-  #-}
+Description: Time related types
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
 
-module Model.Types.DateTime where
+Terms, Seasons, and Occurence schedules
+-}
+module Model.Types.DateTime
+  ( module Model.Types.DateTime
+  ) where
 
-
+import Import.NoModel
-import ClassyPrelude
-import GHC.Generics (Generic)
-import Utils
 import Control.Lens
-import Data.NonNull.Instances ()
-import Data.Typeable (Typeable)
-import Data.Universe.Instances.Reverse ()
-import Data.Binary (Binary)
 
-import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.CaseInsensitive as CI
-import Data.CaseInsensitive.Instances ()
 import Text.Read (readMaybe)
 
-import Database.Persist.Class
 import Database.Persist.Sql
 
 import Web.HttpApiData
 
-import Yesod.Core.Dispatch (PathPiece(..))
+import Data.Aeson.Types as Aeson
-import qualified Data.Aeson as Aeson
+
-import Data.Aeson (FromJSON(..), ToJSON(..), withText)
+import Time.Types (WeekDay(..))
+import Data.Time.LocalTime (LocalTime, TimeOfDay)
 
 
 ----
@@ -70,6 +64,7 @@ instance Enum TermIdentifier where
 -- from_TermIdentifier_to_TermId = TermKey
 
 shortened :: Iso' Integer Integer
+-- ^ Year numbers shortened to two digits
 shortened = iso shorten expand
   where
     century = ($currentYear `div` 100) * 100
@@ -156,3 +151,44 @@ time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
     timeYear = fst3 $ toGregorian time
     termYear = year term
 
+
+data OccurenceSchedule = ScheduleWeekly
+                         { scheduleDayOfWeek :: WeekDay
+                         , scheduleStart     :: TimeOfDay
+                         , scheduleEnd       :: TimeOfDay
+                         }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  , constructorTagModifier = camelToPathPiece' 1
+  , tagSingleConstructors = True
+  , sumEncoding = TaggedObject "repeat" "schedule"
+  } ''OccurenceSchedule
+
+data OccurenceException = ExceptOccur
+                          { exceptDay   :: Day
+                          , exceptStart :: TimeOfDay
+                          , exceptEnd   :: TimeOfDay
+                          }
+                        | ExceptNoOccur
+                          { exceptTime  :: LocalTime
+                          }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  , constructorTagModifier = camelToPathPiece' 1
+  , sumEncoding = TaggedObject "exception" "for"
+  } ''OccurenceException
+
+data Occurences = Occurences
+  { occurencesScheduled  :: Set OccurenceSchedule
+  , occurencesExceptions :: Set OccurenceException
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''Occurences
+derivePersistFieldJSON ''Occurences
+

src/Model/Types/Exam.hs

@@ -0,0 +1,16 @@
+{-|
+Module: Model.Types.Exam
+Description: Types for modeling Exams
+-}
+module Model.Types.Exam
+  ( module Model.Types.Exam
+  ) where
+
+import Import.NoModel
+
+import Database.Persist.TH (derivePersistField)
+
+
+data ExamStatus = Attended | NoShow | Voided
+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
+derivePersistField "ExamStatus"

src/Model/Types/Health.hs

@@ -0,0 +1,87 @@
+{-|
+Module: Model.Types.Health
+Description: Types for running self-tests
+-}
+module Model.Types.Health
+  ( module Model.Types.Health
+  ) where
+
+import Import.NoModel
+
+
+data HealthCheck
+  = HealthCheckMatchingClusterConfig
+  | HealthCheckHTTPReachable
+  | HealthCheckLDAPAdmins
+  | HealthCheckSMTPConnect
+  | HealthCheckWidgetMemcached
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe HealthCheck
+instance Finite HealthCheck
+instance Hashable HealthCheck
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 2
+  } ''HealthCheck
+nullaryPathPiece ''HealthCheck $ camelToPathPiece' 2
+pathPieceJSONKey ''HealthCheck
+  
+data HealthReport
+  = HealthMatchingClusterConfig { healthMatchingClusterConfig :: Bool }
+    -- ^ Is the database-stored configuration we're running under still up to date?
+    --
+    -- Also tests database connection as a side effect
+  | HealthHTTPReachable { healthHTTPReachable :: Maybe Bool }
+    -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP?
+  | HealthLDAPAdmins { healthLDAPAdmins :: Maybe Rational }
+    -- ^ Proportion of school admins that could be found in LDAP
+  | HealthSMTPConnect { healthSMTPConnect :: Maybe Bool }
+    -- ^ Can we connect to the SMTP server and say @NOOP@?
+  | HealthWidgetMemcached { healthWidgetMemcached :: Maybe Bool }
+    -- ^ Can we store values in memcached and retrieve them via HTTP?
+  deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
+
+instance NFData HealthReport
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , fieldLabelModifier = camelToPathPiece' 1
+  , omitNothingFields  = True
+  , sumEncoding = TaggedObject "test" "result"
+  , tagSingleConstructors = True
+  } ''HealthReport
+
+classifyHealthReport :: HealthReport -> HealthCheck
+classifyHealthReport HealthMatchingClusterConfig{} = HealthCheckMatchingClusterConfig
+classifyHealthReport HealthLDAPAdmins{}            = HealthCheckLDAPAdmins
+classifyHealthReport HealthHTTPReachable{}         = HealthCheckHTTPReachable
+classifyHealthReport HealthSMTPConnect{}           = HealthCheckSMTPConnect
+classifyHealthReport HealthWidgetMemcached{}       = HealthCheckWidgetMemcached
+
+-- | `HealthReport` classified (`classifyHealthReport`) by badness
+--
+-- > a < b = a `worseThan` b
+--
+-- Currently all consumers of this type check for @(== HealthSuccess)@; this
+-- needs to be adjusted on a case-by-case basis if new constructors are added
+data HealthStatus = HealthFailure | HealthSuccess
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+
+instance Universe HealthStatus
+instance Finite HealthStatus
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  } ''HealthStatus
+nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1
+
+healthReportStatus :: HealthReport -> HealthStatus
+-- ^ Classify `HealthReport` by badness
+healthReportStatus = \case
+  HealthMatchingClusterConfig       False  -> HealthFailure
+  HealthHTTPReachable         (Just False) -> HealthFailure
+  HealthLDAPAdmins            (Just prop )
+    | prop <= 0                            -> HealthFailure
+  HealthSMTPConnect           (Just False) -> HealthFailure 
+  HealthWidgetMemcached       (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully?
+  _other                                   -> maxBound -- Minimum badness

src/Model/Types/Mail.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-|
+Module: Model.Types.Mail
+Description: Types related to Notifications
+-}
+
+module Model.Types.Mail
+  ( module Model.Types.Mail
+  ) where
+
+import Import.NoModel
+
+import qualified Data.Aeson.Types as Aeson
+
+import qualified Data.HashMap.Strict as HashMap
+
+
+-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
+--
+-- Could maybe be replaced with `Structure Notification` in the long term
+data NotificationTrigger
+  = NTSubmissionRatedGraded
+  | NTSubmissionRated
+  | NTSheetActive
+  | NTSheetSoonInactive
+  | NTSheetInactive
+  | NTCorrectionsAssigned
+  | NTCorrectionsNotDistributed
+  | NTUserRightsUpdate
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+
+instance Universe NotificationTrigger
+instance Finite NotificationTrigger
+
+instance Hashable NotificationTrigger
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  } ''NotificationTrigger
+
+instance ToJSONKey NotificationTrigger where
+  toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
+
+instance FromJSONKey NotificationTrigger where
+  fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
+
+
+newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool }
+  deriving (Generic, Typeable)
+  deriving newtype (Eq, Ord, Read, Show)
+
+instance Default NotificationSettings where
+  def = NotificationSettings $ \case
+    NTSubmissionRatedGraded -> True
+    NTSubmissionRated -> False
+    NTSheetActive -> True
+    NTSheetSoonInactive -> False
+    NTSheetInactive -> True
+    NTCorrectionsAssigned -> True
+    NTCorrectionsNotDistributed -> True
+    NTUserRightsUpdate -> True
+
+instance ToJSON NotificationSettings where
+  toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
+
+instance FromJSON NotificationSettings where
+  parseJSON = Aeson.withObject "NotificationSettings" $ \o -> do
+    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool)
+    return . NotificationSettings $ \n -> case HashMap.lookup n o' of
+      Nothing -> notificationAllowed def n
+      Just b  -> b
+
+derivePersistFieldJSON ''NotificationSettings

src/Model/Types/Misc.hs

@@ -1,50 +1,25 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving
+{-|
-           , UndecidableInstances
+Module: Model.Types.Misc
-  #-}
+Description: Additional uncategorized types
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
+-}
 
-module Model.Types.Misc where
+module Model.Types.Misc
+  ( module Model.Types.Misc
+  ) where
 
-
+import Import.NoModel
-import ClassyPrelude
-import Utils
 import Control.Lens
 
-import Data.NonNull.Instances ()
-import Data.Set (Set)
 import Data.Maybe (fromJust)
-import Data.Universe
-import Data.Universe.Helpers
 
 import qualified Data.Text as Text
 import qualified Data.Text.Lens as Text
-import Data.CaseInsensitive.Instances ()
 
-import Database.Persist.TH hiding (derivePersistFieldJSON)
-import Model.Types.JSON
-
-import Data.Aeson (Value())
-import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
-
-import GHC.Generics (Generic)
-import Data.Typeable (Typeable)
-
-import Data.Universe.Instances.Reverse ()
-
-import Data.Time.LocalTime (LocalTime, TimeOfDay)
-import Time.Types (WeekDay(..))
-
-
------
--- Miscellaneous Model.Types
-
-derivePersistFieldJSON ''Value
 
 data StudyFieldType = FieldPrimary | FieldSecondary
   deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic)
 derivePersistField "StudyFieldType"
 
--- instance DisplayAble StudyFieldType
 
 data Theme
   = ThemeDefault
@@ -59,89 +34,11 @@ deriveJSON defaultOptions
   { constructorTagModifier = fromJust . stripPrefix "Theme"
   } ''Theme
 
-instance Universe Theme where universe = universeDef
+instance Universe Theme
 instance Finite Theme
 
-nullaryPathPiece ''Theme (camelToPathPiece' 1)
+nullaryPathPiece ''Theme $ camelToPathPiece' 1
 
 $(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
 
 derivePersistField "Theme"
-
-
-data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
-
-deriveJSON defaultOptions
-  { constructorTagModifier = fromJust . stripPrefix "Corrector"
-  } ''CorrectorState
-
-instance Universe CorrectorState
-instance Finite CorrectorState
-
-instance Hashable CorrectorState
-
-nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
-
-derivePersistField "CorrectorState"
-
-
-data LecturerType = CourseLecturer | CourseAssistant
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-
-instance Universe LecturerType
-instance Finite LecturerType
-
-nullaryPathPiece ''LecturerType $ camelToPathPiece' 1
-deriveJSON  defaultOptions
-  { constructorTagModifier = camelToPathPiece' 1
-  } ''LecturerType
-derivePersistFieldJSON ''LecturerType
-
-instance Hashable LecturerType
-
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece
-  } ''WeekDay
-
-data OccurenceSchedule = ScheduleWeekly
-                         { scheduleDayOfWeek :: WeekDay
-                         , scheduleStart     :: TimeOfDay
-                         , scheduleEnd       :: TimeOfDay
-                         }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  , constructorTagModifier = camelToPathPiece' 1
-  , tagSingleConstructors = True
-  , sumEncoding = TaggedObject "repeat" "schedule"
-  } ''OccurenceSchedule
-
-data OccurenceException = ExceptOccur
-                          { exceptDay   :: Day
-                          , exceptStart :: TimeOfDay
-                          , exceptEnd   :: TimeOfDay
-                          }
-                        | ExceptNoOccur
-                          { exceptTime  :: LocalTime
-                          }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  , constructorTagModifier = camelToPathPiece' 1
-  , sumEncoding = TaggedObject "exception" "for"
-  } ''OccurenceException
-
-data Occurences = Occurences
-  { occurencesScheduled  :: Set OccurenceSchedule
-  , occurencesExceptions :: Set OccurenceException
-  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  } ''Occurences
-derivePersistFieldJSON ''Occurences
-

src/Model/Types/Security.hs

@@ -1,83 +1,26 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-           , UndecidableInstances
-  #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
 
-module Model.Types.Security where
+{-|
+Module: Model.Types.Security
+Description: Types for authentication and authorisation
+-}
 
+module Model.Types.Security
+  ( module Model.Types.Security
+  ) where
 
-import ClassyPrelude
+import Import.NoModel
-import Utils
-import Control.Lens hiding (universe)
 
 import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Universe
-import Data.UUID.Types (UUID)
-import qualified Data.UUID.Types as UUID
 
-import Data.NonNull.Instances ()
-
-import Data.Default
-
-import Model.Types.JSON
-import Database.Persist.Class
-import Database.Persist.Sql
-
-import Data.Text (Text)
 import qualified Data.Text as Text
 
 import qualified Data.HashMap.Strict as HashMap
 
-import Data.CaseInsensitive (CI)
-import qualified Data.CaseInsensitive as CI
-import Data.CaseInsensitive.Instances ()
-
-import Yesod.Core.Dispatch (PathPiece(..))
-import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
-import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withObject)
-import Data.Aeson.Types (toJSONKeyText)
-import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON)
 
-import GHC.Generics (Generic)
-import Data.Typeable (Typeable)
-
-import Data.Universe.Instances.Reverse ()
-
-import Mail (MailLanguages(..))
-
-import Data.Word.Word24 (Word24)
-import Data.Bits
-import Data.Ix
-import Data.List (genericIndex, elemIndex)
-import System.Random (Random(..))
-import Data.Data (Data)
-
-import Model.Types.Wordlist
-import Data.Text.Metrics (damerauLevenshtein)
-
-import Data.Binary (Binary)
 import qualified Data.Binary as Binary
 
-import Data.Semigroup (Min(..))
-import Control.Monad.Trans.Writer (execWriter)
-import Control.Monad.Writer.Class (MonadWriter(..))
-
-
-----
--- Security, Authentification, Notification Stuff
-
-instance PersistField UUID where
-  toPersistValue = PersistDbSpecific . UUID.toASCIIBytes
-  fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t
-  fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
-  fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
-  fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x
-
-instance PersistFieldSql UUID where
-  sqlType _ = SqlOther "uuid"
-
 
 data AuthenticationMode = AuthLDAP
                         | AuthPWHash { authPWHash :: Text }
@@ -92,167 +35,6 @@ deriveJSON defaultOptions
 derivePersistFieldJSON ''AuthenticationMode
 
 
-
--- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
---
--- Could maybe be replaced with `Structure Notification` in the long term
-data NotificationTrigger = NTSubmissionRatedGraded
-                         | NTSubmissionRated
-                         | NTSheetActive
-                         | NTSheetSoonInactive
-                         | NTSheetInactive
-                         | NTCorrectionsAssigned
-                         | NTCorrectionsNotDistributed
-                         | NTUserRightsUpdate
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-
-instance Universe NotificationTrigger
-instance Finite NotificationTrigger
-
-instance Hashable NotificationTrigger
-
-deriveJSON defaultOptions
-  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  } ''NotificationTrigger
-
-instance ToJSONKey NotificationTrigger where
-  toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
-
-instance FromJSONKey NotificationTrigger where
-  fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
-
-
-newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool }
-  deriving (Generic, Typeable)
-  deriving newtype (Eq, Ord, Read, Show)
-
-instance Default NotificationSettings where
-  def = NotificationSettings $ \case
-    NTSubmissionRatedGraded -> True
-    NTSubmissionRated -> False
-    NTSheetActive -> True
-    NTSheetSoonInactive -> False
-    NTSheetInactive -> True
-    NTCorrectionsAssigned -> True
-    NTCorrectionsNotDistributed -> True
-    NTUserRightsUpdate -> True
-
-instance ToJSON NotificationSettings where
-  toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
-
-instance FromJSON NotificationSettings where
-  parseJSON = withObject "NotificationSettings" $ \o -> do
-    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool)
-    return . NotificationSettings $ \n -> case HashMap.lookup n o' of
-      Nothing -> notificationAllowed def n
-      Just b  -> b
-
-derivePersistFieldJSON ''NotificationSettings
-
-
-instance ToBackendKey SqlBackend record => Hashable (Key record) where
-  hashWithSalt s key = s `hashWithSalt` fromSqlKey key
-
-derivePersistFieldJSON ''MailLanguages
-
-
-type PseudonymWord   = CI Text
-
-newtype Pseudonym = Pseudonym Word24
-  deriving (Eq, Ord, Read, Show, Generic, Data)
-  deriving newtype (Bounded, Enum, Integral, Num, Real, Ix)
-
-
-instance PersistField Pseudonym where
-  toPersistValue p = toPersistValue (fromIntegral p :: Word32)
-  fromPersistValue v = do
-    w <- fromPersistValue v :: Either Text Word32
-    if
-      | 0 <= w
-      , w <= fromIntegral (maxBound :: Pseudonym)
-        -> return $ fromIntegral w
-      | otherwise
-        -> Left "Pseudonym out of range"
-
-instance PersistFieldSql Pseudonym where
-  sqlType _ = SqlInt32
-
-instance Random Pseudonym where
-  randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen
-  random = randomR (minBound, maxBound)
-
-instance FromJSON Pseudonym where
-  parseJSON v@(Aeson.Number _) = do
-    w <- parseJSON v :: Aeson.Parser Word32
-    if
-      | 0 <= w
-      , w <= fromIntegral (maxBound :: Pseudonym)
-        -> return $ fromIntegral w
-      | otherwise
-        -> fail "Pseudonym out auf range"
-  parseJSON (Aeson.String t)
-    = case t ^? _PseudonymText of
-        Just p -> return p
-        Nothing -> fail "Could not parse pseudonym"
-  parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do
-    ws' <- toList . map CI.mk <$> mapM parseJSON ws
-    case ws' ^? _PseudonymWords of
-      Just p -> return p
-      Nothing -> fail "Could not parse pseudonym words"
-
-instance ToJSON Pseudonym where
-  toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord])
-
-pseudonymWordlist :: [PseudonymWord]
-pseudonymCharacters :: Set (CI Char)
-(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt")
-
-_PseudonymWords :: Prism' [PseudonymWord] Pseudonym
-_PseudonymWords = prism' pToWords pFromWords
-  where
-    pFromWords :: [PseudonymWord] -> Maybe Pseudonym
-    pFromWords [w1, w2]
-      | Just i1 <- elemIndex w1 pseudonymWordlist
-      , Just i2 <- elemIndex w2 pseudonymWordlist
-      , i1 <= maxWord, i2 <= maxWord
-      = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2
-    pFromWords _ = Nothing
-
-    pToWords :: Pseudonym -> [PseudonymWord]
-    pToWords (Pseudonym p)
-      = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord
-        , genericIndex pseudonymWordlist $ p .&. maxWord
-        ]
-
-    maxWord :: Num a => a
-    maxWord = 0b111111111111
-
-_PseudonymText :: Prism' Text Pseudonym
-_PseudonymText = prism' tToWords tFromWords . _PseudonymWords
-  where
-    tFromWords :: Text -> Maybe [PseudonymWord]
-    tFromWords input
-      | [result] <- input ^.. pseudonymFragments
-      = Just result
-      | otherwise
-      = Nothing
-
-    tToWords :: [PseudonymWord] -> Text
-    tToWords = Text.unwords . map CI.original
-
-pseudonymWords :: Fold Text PseudonymWord
-pseudonymWords = folding
-  $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
-  where
-    distance = damerauLevenshtein `on` CI.foldedCase
-    -- | Arbitrary cutoff point, for reference: ispell cuts off at 1
-    distanceCutoff = 2
-
-pseudonymFragments :: Fold Text [PseudonymWord]
-pseudonymFragments = folding
-  $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters)
-
-
 data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
   = AuthAdmin
   | AuthLecturer
@@ -313,7 +95,7 @@ instance ToJSON AuthTagActive where
   toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF
 
 instance FromJSON AuthTagActive where
-  parseJSON = withObject "AuthTagActive" $ \o -> do
+  parseJSON = Aeson.withObject "AuthTagActive" $ \o -> do
     o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool)
     return . AuthTagActive $ \n -> case HashMap.lookup n o' of
       Nothing -> authTagIsActive def n
@@ -359,53 +141,3 @@ instance (Ord a, Binary a) => Binary (PredDNF a) where
 type AuthLiteral = PredLiteral AuthTag
 
 type AuthDNF = PredDNF AuthTag
-
-
-data HealthReport = HealthReport
-  { healthMatchingClusterConfig :: Bool
-    -- ^ Is the database-stored configuration we're running under still up to date?
-  , healthHTTPReachable :: Maybe Bool
-    -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP?
-    --
-    -- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings
-  , healthLDAPAdmins :: Maybe Rational
-    -- ^ Proportion of school admins that could be found in LDAP
-    --
-    -- Is `Nothing` if LDAP is not configured or no users are school admins
-  , healthSMTPConnect :: Maybe Bool
-    -- ^ Can we connect to the SMTP server and say @NOOP@?
-  , healthWidgetMemcached :: Maybe Bool
-    -- ^ Can we store values in memcached and retrieve them via HTTP?
-  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  , omitNothingFields  = True
-  } ''HealthReport
-
--- | `HealthReport` classified (`classifyHealthReport`) by badness
---
--- > a < b = a `worseThan` b
---
--- Currently all consumers of this type check for @(== HealthSuccess)@; this
--- needs to be adjusted on a case-by-case basis if new constructors are added
-data HealthStatus = HealthFailure | HealthSuccess
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-
-instance Universe HealthStatus
-instance Finite HealthStatus
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 1
-  } ''HealthStatus
-nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1
-
-classifyHealthReport :: HealthReport -> HealthStatus
--- ^ Classify `HealthReport` by badness
-classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction with `Writer (Min HealthStatus) a` returns worst `HealthStatus` passed to `tell` at any point
-  unless healthMatchingClusterConfig . tell $ Min HealthFailure
-  unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure
-  unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure
-  unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure
-  unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure
-

src/Model/Types/Sheet.hs

@@ -1,62 +1,31 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving
+{-|
-           , UndecidableInstances
+Module: Model.Types.Sheet
-  #-}
+Description: Types for modeling sheets
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
+-}
 
-module Model.Types.Sheet where
+module Model.Types.Sheet
+  ( module Model.Types.Sheet
+  ) where
 
-import ClassyPrelude
+import Import.NoModel
-import Utils
+import Model.Types.Common
-import Numeric.Natural
+import Utils.Lens.TH
 
 import Control.Lens
-import Utils.Lens.TH
-import GHC.Generics (Generic)
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
-import Data.Typeable (Typeable)
-import Data.Universe
-import Data.Universe.Helpers
-import Data.Universe.Instances.Reverse ()
 
-import Data.NonNull.Instances ()
 import Data.Set (Set)
 import qualified Data.Set as Set
 import qualified Data.Map as Map
-import Data.Fixed
-import Data.Monoid (Sum(..))
 import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
 
-import Data.CaseInsensitive.Instances ()
 import Text.Blaze (Markup)
 
-import Database.Persist.TH hiding (derivePersistFieldJSON)
-import Model.Types.JSON
 import Yesod.Core.Dispatch (PathPiece(..))
 
-import Network.Mime
+import Data.Maybe (fromJust)
 
 
-
-----
--- Sheet and Submission realted Model.Types
-
-type Count  = Sum Integer
-type Points = Centi
-
-toPoints :: Integral a => a -> Points -- deprecated
-toPoints = fromIntegral
-
-pToI :: Points -> Integer -- deprecated
-pToI = fromPoints
-
-fromPoints :: Integral a => Points -> a -- deprecated
-fromPoints = round
-
-instance DisplayAble Points
-
-instance DisplayAble a => DisplayAble (Sum a) where
-   display (Sum x) = display x
-
 data SheetGrading
   = Points     { maxPoints :: Points }
   | PassPoints { maxPoints, passingPoints :: Points }
@@ -179,7 +148,7 @@ data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
 derivePersistField "SheetFileType"
 
-instance Universe SheetFileType where universe = universeDef
+instance Universe SheetFileType
 instance Finite SheetFileType
 
 instance PathPiece SheetFileType where
@@ -208,22 +177,6 @@ sheetFile2markup SheetMarking  = iconMarking
 partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a
 partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs
 
-data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
-  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
-
-instance Universe SubmissionFileType
-instance Finite SubmissionFileType
-
-nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1
-
-submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
-submissionFileTypeIsUpdate SubmissionOriginal  = False
-submissionFileTypeIsUpdate SubmissionCorrected = True
-
-isUpdateSubmissionFileType :: Bool -> SubmissionFileType
-isUpdateSubmissionFileType False = SubmissionOriginal
-isUpdateSubmissionFileType True  = SubmissionCorrected
-
 
 data UploadSpecificFile = UploadSpecificFile
   { specificFileLabel :: Text
@@ -306,10 +259,6 @@ classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser
 classifySubmissionMode (SubmissionMode True  (Just _)) = SubmissionModeBoth
 
 
-data ExamStatus = Attended | NoShow | Voided
-  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
-derivePersistField "ExamStatus"
-
 -- | Specify a corrector's workload
 data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational }
     = Load { byTutorial :: Maybe Bool  -- ^ @Just@ all from Tutorial, @True@ if counting towards overall workload
@@ -340,3 +289,19 @@ instance Monoid Load where
   isByTutorial (ByTutorial {}) = True
   isByTutorial _               = False
 -}
+
+data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = fromJust . stripPrefix "Corrector"
+  } ''CorrectorState
+
+instance Universe CorrectorState
+instance Finite CorrectorState
+
+instance Hashable CorrectorState
+
+nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
+
+derivePersistField "CorrectorState"

src/Model/Types/Submission.hs

@@ -0,0 +1,151 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+{-|
+Module: Model.Types.Submission
+Description: Types to support sheet submissions
+-}
+
+module Model.Types.Submission
+  ( module Model.Types.Submission
+  ) where
+
+import Import.NoModel
+
+import Data.Aeson.Types (ToJSON(..), FromJSON(..))
+import qualified Data.Aeson.Types as Aeson
+
+import Database.Persist.Sql
+
+import Data.Word.Word24
+
+import qualified Data.CaseInsensitive as CI
+
+import Control.Lens
+
+import qualified Data.Text as Text
+import qualified Data.Set as Set
+
+
+import Data.List (elemIndex, genericIndex)
+import Data.Bits
+import Data.Text.Metrics (damerauLevenshtein)
+  
+-------------------------
+-- Submission Download --
+-------------------------
+
+data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
+
+instance Universe SubmissionFileType
+instance Finite SubmissionFileType
+
+nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1
+
+submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
+submissionFileTypeIsUpdate SubmissionOriginal  = False
+submissionFileTypeIsUpdate SubmissionCorrected = True
+
+isUpdateSubmissionFileType :: Bool -> SubmissionFileType
+isUpdateSubmissionFileType False = SubmissionOriginal
+isUpdateSubmissionFileType True  = SubmissionCorrected
+
+---------------------------
+-- Submission Pseudonyms --
+---------------------------
+  
+type PseudonymWord = CI Text
+
+newtype Pseudonym = Pseudonym Word24
+  deriving (Eq, Ord, Read, Show, Generic, Data)
+  deriving newtype (Bounded, Enum, Integral, Num, Real, Ix)
+
+
+instance PersistField Pseudonym where
+  toPersistValue p = toPersistValue (fromIntegral p :: Word32)
+  fromPersistValue v = do
+    w <- fromPersistValue v :: Either Text Word32
+    if
+      | 0 <= w
+      , w <= fromIntegral (maxBound :: Pseudonym)
+        -> return $ fromIntegral w
+      | otherwise
+        -> Left "Pseudonym out of range"
+
+instance PersistFieldSql Pseudonym where
+  sqlType _ = SqlInt32
+
+instance Random Pseudonym where
+  randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen
+  random = randomR (minBound, maxBound)
+
+instance FromJSON Pseudonym where
+  parseJSON v@(Aeson.Number _) = do
+    w <- parseJSON v :: Aeson.Parser Word32
+    if
+      | 0 <= w
+      , w <= fromIntegral (maxBound :: Pseudonym)
+        -> return $ fromIntegral w
+      | otherwise
+        -> fail "Pseudonym out auf range"
+  parseJSON (Aeson.String t)
+    = case t ^? _PseudonymText of
+        Just p -> return p
+        Nothing -> fail "Could not parse pseudonym"
+  parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do
+    ws' <- toList . map CI.mk <$> mapM parseJSON ws
+    case ws' ^? _PseudonymWords of
+      Just p -> return p
+      Nothing -> fail "Could not parse pseudonym words"
+
+instance ToJSON Pseudonym where
+  toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord])
+
+pseudonymWordlist :: [PseudonymWord]
+pseudonymCharacters :: Set (CI Char)
+(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt")
+
+_PseudonymWords :: Prism' [PseudonymWord] Pseudonym
+_PseudonymWords = prism' pToWords pFromWords
+  where
+    pFromWords :: [PseudonymWord] -> Maybe Pseudonym
+    pFromWords [w1, w2]
+      | Just i1 <- elemIndex w1 pseudonymWordlist
+      , Just i2 <- elemIndex w2 pseudonymWordlist
+      , i1 <= maxWord, i2 <= maxWord
+      = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2
+    pFromWords _ = Nothing
+
+    pToWords :: Pseudonym -> [PseudonymWord]
+    pToWords (Pseudonym p)
+      = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord
+        , genericIndex pseudonymWordlist $ p .&. maxWord
+        ]
+
+    maxWord :: Num a => a
+    maxWord = 0b111111111111
+
+_PseudonymText :: Prism' Text Pseudonym
+_PseudonymText = prism' tToWords tFromWords . _PseudonymWords
+  where
+    tFromWords :: Text -> Maybe [PseudonymWord]
+    tFromWords input
+      | [result] <- input ^.. pseudonymFragments
+      = Just result
+      | otherwise
+      = Nothing
+
+    tToWords :: [PseudonymWord] -> Text
+    tToWords = Text.unwords . map CI.original
+
+pseudonymWords :: Fold Text PseudonymWord
+pseudonymWords = folding
+  $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
+  where
+    distance = damerauLevenshtein `on` CI.foldedCase
+    -- | Arbitrary cutoff point, for reference: ispell cuts off at 1
+    distanceCutoff = 2
+
+pseudonymFragments :: Fold Text [PseudonymWord]
+pseudonymFragments = folding
+  $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters)

src/Model/Types/TH/JSON.hs

@@ -1,4 +1,4 @@
-module Model.Types.JSON
+module Model.Types.TH.JSON
   ( derivePersistFieldJSON
   , predNFAesonOptions
   ) where

src/Model/Types/TH/Wordlist.hs

@@ -1,4 +1,6 @@
-module Model.Types.Wordlist (wordlist) where
+module Model.Types.TH.Wordlist
+  ( wordlist
+  ) where
 
 import ClassyPrelude hiding (lift)
 

src/Settings.hs

@@ -10,14 +10,13 @@ module Settings
   , module Settings.Cluster
   ) where
 
-import           ClassyPrelude.Yesod
+import           Import.NoModel
 import Data.UUID (UUID)
 import qualified Control.Exception           as Exception
-import           Data.Aeson                  (Result (..), fromJSON, withObject
+import           Data.Aeson                  (fromJSON, withObject
                                              ,(.!=), (.:?), withScientific
                                              )
 import qualified Data.Aeson.Types as Aeson
-import           Data.Aeson.TH
 import           Data.FileEmbed              (embedFile)
 import           Data.Yaml                   (decodeEither')
 import           Database.Persist.Postgresql (PostgresConf)
@@ -45,7 +44,6 @@ import qualified Data.Text.Encoding as Text
 
 import qualified Ldap.Client as Ldap
 
-import Utils hiding (MessageStatus(..))
 import Control.Lens
 
 import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
@@ -70,7 +68,6 @@ import Jose.Jwt (JwtEncoding(..))
 
 import System.FilePath.Glob
 import Handler.Utils.Submission.TH
-import Network.Mime
 import Network.Mime.TH
 
 import qualified Data.Map as Map
@@ -118,9 +115,9 @@ data AppSettings = AppSettings
     , appJwtExpiration          :: Maybe NominalDiffTime
     , appJwtEncoding            :: JwtEncoding
     
-    , appHealthCheckInterval    :: NominalDiffTime
+    , appHealthCheckInterval    :: HealthCheck -> Maybe NominalDiffTime
-    , appHealthCheckHTTP        :: Bool
     , appHealthCheckDelayNotify :: Bool
+    , appHealthCheckHTTP        :: Bool
 
     , appInitialLogSettings     :: LogSettings
 
@@ -389,9 +386,9 @@ instance FromJSON AppSettings where
         appJwtExpiration          <- o .:? "jwt-expiration"
         appJwtEncoding            <- o .: "jwt-encoding"
 
-        appHealthCheckInterval    <- o .:  "health-check-interval"
+        appHealthCheckInterval    <- (assertM' (> 0) . ) <$> o .: "health-check-interval"
-        appHealthCheckHTTP        <- o .:  "health-check-http"
         appHealthCheckDelayNotify <- o .:  "health-check-delay-notify"
+        appHealthCheckHTTP        <- o .:  "health-check-http"
 
         appSessionTimeout         <- o .: "session-timeout"
 
@@ -483,5 +480,5 @@ configSettingsYmlValue = either Exception.throw id
 compileTimeAppSettings :: AppSettings
 compileTimeAppSettings =
     case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
-        Error e -> error e
+        Aeson.Error e -> error e
-        Success settings -> settings
+        Aeson.Success settings -> settings

src/System/FilePath/Instances.hs

@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module System.FilePath.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import qualified Data.Text as Text
+
+import Web.PathPieces
+
+
+instance {-# OVERLAPS #-} PathMultiPiece FilePath where
+  fromPathMultiPiece = Just . unpack . intercalate "/"
+  toPathMultiPiece = Text.splitOn "/" . pack

src/Time/Types/Instances.hs

@@ -12,8 +12,14 @@ import Data.Universe
 
 import Utils.PathPiece
 
+import Data.Aeson.TH
+
 
 instance Universe WeekDay
 instance Finite WeekDay
 
 nullaryPathPiece ''WeekDay camelToPathPiece
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece
+  } ''WeekDay

src/Utils.hs

@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult
-
 module Utils
   ( module Utils
   ) where
@@ -68,9 +66,10 @@ import qualified Crypto.Saltine.Core.SecretBox as SecretBox
 import qualified Crypto.Saltine.Class as Saltine
 import qualified Crypto.Data.PKCS7 as PKCS7
 
-import Data.Fixed (Centi)
+import Data.Fixed
 import Data.Ratio ((%))
 
+import Data.Binary (Binary)
 import qualified Data.Binary as Binary
 
 import Network.Wai (requestMethod)
@@ -79,6 +78,8 @@ import Data.Time.Clock
 
 import Data.List.NonEmpty (NonEmpty, nonEmpty)
 
+import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, BoundedMeetSemiLattice)
+
 {-# ANN choice ("HLint: ignore Use asum" :: String) #-}
 
 
@@ -275,6 +276,12 @@ instance DisplayAble a => DisplayAble (E.Value a) where
 instance DisplayAble a => DisplayAble (CI a) where
   display = display . CI.original
 
+instance HasResolution a => DisplayAble (Fixed a) where
+  display = pack . showFixed True
+
+instance DisplayAble a => DisplayAble (Sum a) where
+  display = display . getSum
+
 {- We do not want DisplayAble for every Show-Class:
    We want to explicitly verify that the resulting text can be displayed to the User!
    For example: UTCTime values were shown without proper format rendering!
@@ -908,10 +915,18 @@ encodedSecretBoxOpen ciphertext = do
 -- Caching --
 -------------
 
+cachedByBinary :: (Binary a, Typeable b, MonadHandler m) => a -> m b -> m b
+cachedByBinary k = cachedBy (toStrict $ Binary.encode k)
+
 cachedHere :: Q Exp
 cachedHere = do
   loc <- location
-  [e| cachedBy (toStrict $ Binary.encode loc) |]
+  [e| cachedByBinary loc |]
+
+cachedHereBinary :: Q Exp
+cachedHereBinary = do
+  loc <- location
+  [e| \k -> cachedByBinary (loc, k) |]
 
 hashToText :: Hashable a => a -> Text
 hashToText = decodeUtf8 . Base64.encode . toStrict . Binary.encode . hash
@@ -936,3 +951,13 @@ setLastModified lastModified = do
     precision = 1
 
     safeMethods = [ methodGet, methodHead, methodOptions ]
+
+--------------
+-- Lattices --
+--------------
+
+foldJoin :: (MonoFoldable mono, BoundedJoinSemiLattice (Element mono)) => mono -> Element mono
+foldJoin = foldr (\/) bottom
+
+foldMeet :: (MonoFoldable mono, BoundedMeetSemiLattice (Element mono)) => mono -> Element mono
+foldMeet = foldr (/\) top

src/Utils/DateTime.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Utils.DateTime
   ( timeLocaleMap
@@ -14,10 +13,9 @@ module Utils.DateTime
 import ClassyPrelude.Yesod hiding (lift)
 import System.Locale.Read
 
-import Data.Time (TimeZone(..), TimeLocale(..))
+import Data.Time (TimeLocale(..))
 import Data.Time.Zones (TZ)
 import Data.Time.Zones.TH (includeSystemTZ)
-import Data.Time.Clock.POSIX
 
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax (Lift(..))
@@ -35,11 +33,8 @@ import Data.Aeson.TH
 
 import Utils.PathPiece
 
-deriving instance Lift TimeZone
+import Data.Time.Format.Instances ()
-deriving instance Lift TimeLocale
+  
-
-instance Hashable UTCTime where
-  hashWithSalt s = hashWithSalt s . toRational . utcTimeToPOSIXSeconds
 
 -- $(timeLocaleMap _) :: [Lang] -> TimeLocale
 timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default
@@ -91,7 +86,7 @@ instance Finite SelDateTimeFormat
 instance Hashable SelDateTimeFormat
 
 deriveJSON defaultOptions
-  { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel
+  { constructorTagModifier = camelToPathPiece' 2
   } ''SelDateTimeFormat
 
 instance ToJSONKey SelDateTimeFormat where

src/Utils/PathPiece.hs

@@ -5,6 +5,7 @@ module Utils.PathPiece
   , splitCamel
   , camelToPathPiece, camelToPathPiece'
   , tuplePathPiece
+  , pathPieceJSONKey
   ) where
 
 import ClassyPrelude.Yesod
@@ -22,6 +23,8 @@ import qualified Data.Map as Map
 import Numeric.Natural
 
 import Data.List (foldl)
+
+import Data.Aeson.Types
   
 
 finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a
@@ -109,3 +112,13 @@ tuplePathPiece tupleDim = do
                          ]) []
       ]
     ]
+
+
+pathPieceJSONKey :: Name -> DecsQ
+-- ^ Derive `ToJSONKey`- and `FromJSONKey`-Instances from a `PathPiece`-Instance
+pathPieceJSONKey tName
+  = [d| instance ToJSONKey $(conT tName) where
+          toJSONKey = toJSONKeyText toPathPiece
+        instance FromJSONKey $(conT tName) where
+          fromJSONKey = FromJSONKeyTextParser $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> "via PathPiece") return $ fromPathPiece t
+      |]

src/Yesod/Core/Types/Instances.hs

@@ -2,7 +2,8 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
 
 module Yesod.Core.Types.Instances
-  ( CachedMemoT(..)
+  ( CachedMemoT
+  , runCachedMemoT
   ) where
 
 import ClassyPrelude.Yesod
@@ -13,9 +14,15 @@ import Control.Monad.Fix
 import Control.Monad.Memo
 
 import Data.Binary (Binary)
-import qualified Data.Binary as Binary
 
 import Control.Monad.Logger (MonadLoggerIO)
+
+import Utils
+
+import Language.Haskell.TH
+
+import Control.Monad.Reader (MonadReader(..))
+import Control.Monad.Trans.Reader (ReaderT, mapReaderT, runReaderT)
   
 
 instance MonadFix m => MonadFix (HandlerT site m) where
@@ -26,23 +33,31 @@ instance MonadFix m => MonadFix (WidgetT site m) where
 
 
 -- | Type-level tags for compatability of Yesod `cached`-System with `MonadMemo`
-newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT :: m a }
+newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT' :: ReaderT Loc m a }
   deriving newtype ( Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix
                    , MonadIO
                    , MonadThrow, MonadCatch, MonadMask, MonadLogger, MonadLoggerIO
                    , MonadResource, MonadHandler, MonadWidget
-                   , IsString, Semigroup, Monoid
                    )
 
 deriving newtype instance MonadBase b m => MonadBase b (CachedMemoT k v m)
 deriving newtype instance MonadBaseControl b m => MonadBaseControl b (CachedMemoT k v m)
 
-deriving newtype instance MonadReader r m => MonadReader r (CachedMemoT k v m)
+instance MonadReader r m => MonadReader r (CachedMemoT k v m) where
+  reader = CachedMemoT . lift . reader
+  local f (CachedMemoT act) = CachedMemoT $ mapReaderT (local f) act
 
 instance MonadTrans (CachedMemoT k v) where
-  lift = CachedMemoT
+  lift = CachedMemoT . lift
 
 
 -- | Uses `cachedBy` with a `Binary`-encoded @k@
 instance (Typeable v, Binary k, MonadHandler m) => MonadMemo k v (CachedMemoT k v m) where
-  memo act key = cachedBy (toStrict $ Binary.encode key) $ act key
+  memo act key = do
+    loc <- CachedMemoT ask
+    cachedByBinary (loc, key) $ act key
+
+runCachedMemoT :: Q Exp
+runCachedMemoT = do
+  loc <- location
+  [e| flip runReaderT loc . runCachedMemoT' |]

templates/material-show.hamlet

@@ -10,11 +10,11 @@ $maybe descr <- materialDescription
     $maybe matKind <- materialType
       <dt .deflist__dt>_{MsgMaterialType}
       <dd .deflist__dd>#{matKind}
-    $maybe matVisible <- materialVisibleFrom
+    $maybe matVisibleFromWgt <- matVisibleFromMB
       <dt .deflist__dt>_{MsgVisibleFrom}
-      <dd .deflist__dd>#{matVisible}
+      <dd .deflist__dd>^{matVisibleFromWgt}
     <dt .deflist__dt>_{MsgFileModified}
-    <dd .deflist__dd>#{materialLastEdit}
+    <dd .deflist__dd>^{matLastEdit}
 
 $if hasFiles
   <section>

test/MailSpec.hs

@@ -27,7 +27,7 @@ spec = do
     lawsCheckHspec (Proxy @MailSmtpData)
       [ eqLaws, ordLaws, showReadLaws, monoidLaws ]
     lawsCheckHspec (Proxy @MailLanguages)
-      [ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws ]
+      [ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @MailContext)
       [ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ]
     lawsCheckHspec (Proxy @VerpMode)

test/Model/TypesSpec.hs

@@ -267,8 +267,6 @@ spec = do
       [ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]
     lawsCheckHspec (Proxy @NotificationSettings)
       [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-    lawsCheckHspec (Proxy @MailLanguages)
-      [ persistFieldLaws ]
     lawsCheckHspec (Proxy @Pseudonym)
       [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, integralLaws, jsonLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @AuthTag)

test/TestImport.hs

@@ -32,6 +32,7 @@ import Data.Proxy as X
 import Data.UUID as X (UUID)
 import System.IO as X (hPrint, hPutStrLn, stderr)
 import Jobs (handleJobs, stopJobCtl)
+import Numeric.Natural as X
 
 import Control.Lens as X hiding ((<.), elements)
 

test/Utils/DateTimeSpec.hs

@@ -2,6 +2,9 @@ module Utils.DateTimeSpec where
 
 import TestImport
 
+import Utils.DateTime
+
+
 instance Arbitrary DateTimeFormat where
   arbitrary = DateTimeFormat <$> arbitrary
   shrink = genericShrink