fix: hopefully improve workflow auth performance

config/settings.yml

@@ -87,6 +87,7 @@ auth-pw-hash:
 # reload-templates: false
 # mutable-static: false
 # skip-combining: false
+# clear-cache: false
 
 database:
   user:     "_env:PGUSER:uniworx"
@@ -259,3 +260,5 @@ token-buckets:
 fallback-personalised-sheet-files-keys-expire: 2419200
 
 download-token-expire: 604801
+
+memcache-auth: true

messages/uniworx/de-de-formal.msg

@@ -457,6 +457,7 @@ Unauthorized: Sie haben hierfür keine explizite Berechtigung.
 UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
 UnauthorizedOr  l@Text r@Text: (#{l} ODER #{r})
 UnauthorizedNot r@Text: #{r}
+UnauthorizedI18nMismatch: Es wurden unterschiedliche Authorisierungs-Ergebnisse für verschiedene Sprachen berechnet
 UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt.
 UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen.
 UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.

messages/uniworx/en-eu.msg

@@ -454,6 +454,7 @@ Unauthorized: You do not have explicit authorisation.
 UnauthorizedAnd l r: (#{l} AND #{r})
 UnauthorizedOr l r: (#{l} OR #{r})
 UnauthorizedNot r: (NOT #{r})
+UnauthorizedI18nMismatch: Different authentication results were calculated for different languages
 UnauthorizedNoToken: No authorisation-token was provided with your request.
 UnauthorizedTokenExpired: Your authorisation-token is expired.
 UnauthorizedTokenNotStarted: Your authorisation-token is not yet valid.

src/Application.hs

@@ -257,6 +257,9 @@ makeFoundation appSettings''@AppSettings{..} = do
         $logDebugS "setup" "Memcached"
         memcachedKey <- clusterSetting (Proxy :: Proxy 'ClusterMemcachedKey) `runSqlPool` sqlPool
         memcached <- createMemcached memcachedConf
+        when appClearCache $ do
+          $logWarnS "setup" "Clearing memcached"
+          liftIO $ Memcached.flushAll memcached
         return (memcachedKey, memcached)
 
       appSessionStore <- mkSessionStore appSettings'' sqlPool `runSqlPool` sqlPool

src/Foundation/Authorization.hs

@@ -18,6 +18,7 @@ module Foundation.Authorization
   , hasWorkflowRole
   , mayViewWorkflowAction, mayViewWorkflowAction'
   , authoritiveApproot
+  , AuthorizationCacheKey(..)
   ) where
 
 import Import.NoFoundation hiding (Last(..))
@@ -31,6 +32,8 @@ import Foundation.DB
 import Handler.Utils.ExamOffice.Exam
 import Handler.Utils.ExamOffice.ExternalExam
 import Handler.Utils.Workflow.CanonicalRoute
+import Handler.Utils.Memcached
+import Handler.Utils.I18n
 import Utils.Course (courseIsVisible)
 import Utils.Workflow
   
@@ -53,6 +56,8 @@ import Data.Aeson.Lens hiding (_Value, key)
 
 import qualified Data.Conduit.Combinators as C
 
+import qualified Data.Binary as Binary
+
 
 type BearerAuthSite site
   = ( MonadCrypto (HandlerFor site)
@@ -87,22 +92,22 @@ type AuthTagsEval m = AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool
 data AccessPredicate
   = APPure     (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
   | APHandler  (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult)
-  | APDB       ((forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)
+  | APDB       (ByteString -> (forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)
 
 class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where
-  evalAccessPred :: AccessPredicate -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
+  evalAccessPred :: AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
 
 instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where
-  evalAccessPred aPred cont aid r w = liftHandler $ case aPred of
+  evalAccessPred aPred contCtx cont aid r w = liftHandler $ case aPred of
     (APPure    p) -> runReader (p aid r w) <$> getMsgRenderer
     (APHandler p) -> p aid r w
-    (APDB      p) -> runDBRead $ p cont aid r w
+    (APDB      p) -> runDBRead $ p contCtx cont aid r w
 
 instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX) => MonadAP (ReaderT backend m) where
-  evalAccessPred aPred cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of
+  evalAccessPred aPred contCtx cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of
     (APPure    p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
     (APHandler p) -> lift $ p aid r w
-    (APDB      p) -> p cont aid r w
+    (APDB      p) -> p contCtx cont aid r w
 
 
 orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
@@ -118,6 +123,21 @@ andAR _  _ reason@(Unauthorized _) = reason
 andAR _  Authorized          other = other
 andAR _  AuthenticationRequired  _ = AuthenticationRequired
 
+_orARI18n, _andARI18n :: MsgRenderer -> I18nAuthResult -> I18nAuthResult -> I18nAuthResult
+_orARI18n _  AuthorizedI18n _ = AuthorizedI18n
+_orARI18n _  _ AuthorizedI18n = AuthorizedI18n
+_orARI18n _  AuthenticationRequiredI18n _  = AuthenticationRequiredI18n
+_orARI18n _  _ AuthenticationRequiredI18n  = AuthenticationRequiredI18n
+_orARI18n mr (UnauthorizedI18n x) (UnauthorizedI18n y) = fmap (Unauthorized . render mr) . MsgUnauthorizedOr <$> x <*> y
+_orARI18n mr _ _ = UnauthorizedI18n . opoint $ render mr MsgUnauthorizedI18nMismatch
+-- and
+_andARI18n mr (UnauthorizedI18n x) (UnauthorizedI18n y) = fmap (Unauthorized . render mr) . MsgUnauthorizedAnd <$> x <*> y
+_andARI18n _ reason@(UnauthorizedI18n _) _ = reason
+_andARI18n _ _ reason@(UnauthorizedI18n _) = reason
+_andARI18n _ AuthorizedI18n other = other
+_andARI18n _  AuthenticationRequiredI18n  _ = AuthenticationRequiredI18n
+_andARI18n mr _ _ = UnauthorizedI18n . opoint $ render mr MsgUnauthorizedI18nMismatch
+
 notAR :: RenderMessage UniWorX msg => MsgRenderer -> msg -> AuthResult -> AuthResult
 notAR _  _   (Unauthorized _)        = Authorized
 notAR _  _    AuthenticationRequired = AuthenticationRequired
@@ -315,10 +335,16 @@ maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do
   route <- MaybeT getCurrentRoute
   hoistMaybe $ bearer ^? _bearerRestrictionIx route
 
+data AuthorizationCacheKey
+  = AuthCacheWorkflowWorkflowEdgeActors CryptoFileNameWorkflowWorkflow
+  | AuthCacheWorkflowWorkflowViewers CryptoFileNameWorkflowWorkflow
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Binary)
+
 tagAccessPredicate :: BearerAuthSite UniWorX
                    => AuthTag -> AccessPredicate
 tagAccessPredicate AuthFree = trueAP
-tagAccessPredicate AuthAdmin = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthAdmin = APDB $ \_ _ mAuthId route _ -> case route of
   -- Courses: access only to school admins
   CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
@@ -355,17 +381,17 @@ tagAccessPredicate AuthAdmin = APDB $ \_ mAuthId route _ -> case route of
     adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
     guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
     return Authorized
-tagAccessPredicate AuthSystemExamOffice = APDB $ \_ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
+tagAccessPredicate AuthSystemExamOffice = APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
   authId <- maybeExceptT AuthenticationRequired $ return mAuthId
   isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False]
   guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice
   return Authorized
-tagAccessPredicate AuthStudent = APDB $ \_ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
+tagAccessPredicate AuthStudent = APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
   authId <- maybeExceptT AuthenticationRequired $ return mAuthId
   isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemStudent, UserSystemFunctionIsOptOut ==. False]
   guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedStudent
   return Authorized
-tagAccessPredicate AuthExamOffice = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthExamOffice = APDB $ \_ _ mAuthId route _ -> case route of
   CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
@@ -408,7 +434,7 @@ tagAccessPredicate AuthExamOffice = APDB $ \_ mAuthId route _ -> case route of
     isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice]
     guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice)
     return Authorized
-tagAccessPredicate AuthEvaluation = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthEvaluation = APDB $ \_ _ mAuthId route _ -> case route of
   ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
@@ -424,7 +450,7 @@ tagAccessPredicate AuthEvaluation = APDB $ \_ mAuthId route _ -> case route of
     isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation]
     guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
     return Authorized
-tagAccessPredicate AuthAllocationAdmin = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthAllocationAdmin = APDB $ \_ _ mAuthId route _ -> case route of
   AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
@@ -440,9 +466,9 @@ tagAccessPredicate AuthAllocationAdmin = APDB $ \_ mAuthId route _ -> case route
     isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation]
     guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
     return Authorized
-tagAccessPredicate AuthToken = APDB $ \_ mAuthId route isWrite -> exceptT return return $
+tagAccessPredicate AuthToken = APDB $ \_ _ mAuthId route isWrite -> exceptT return return $
   lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe
-tagAccessPredicate AuthNoEscalation = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthNoEscalation = APDB $ \_ _ mAuthId route _ -> case route of
   AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
     myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
     uid <- decrypt cID
@@ -463,7 +489,7 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
 #else
   return $ Unauthorized "Route under development"
 #endif
-tagAccessPredicate AuthLecturer = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthLecturer = APDB $ \_ _ mAuthId route _ -> case route of
   CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
      isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do
@@ -502,7 +528,7 @@ tagAccessPredicate AuthLecturer = APDB $ \_ mAuthId route _ -> case route of
      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
      void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] []
      return Authorized
-tagAccessPredicate AuthCorrector = APDB $ \_ mAuthId route _ -> exceptT return return $ do
+tagAccessPredicate AuthCorrector = APDB $ \_ _ mAuthId route _ -> exceptT return return $ do
   authId <- maybeExceptT AuthenticationRequired $ return mAuthId
   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
@@ -530,7 +556,7 @@ tagAccessPredicate AuthCorrector = APDB $ \_ mAuthId route _ -> exceptT return r
     _ -> do
       guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
       return Authorized
-tagAccessPredicate AuthExamCorrector = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthExamCorrector = APDB $ \_ _ mAuthId route _ -> case route of
   CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
@@ -555,7 +581,7 @@ tagAccessPredicate AuthExamCorrector = APDB $ \_ mAuthId route _ -> case route o
     guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
     return Authorized
   r -> $unsupportedAuthPredicate AuthExamCorrector r
-tagAccessPredicate AuthTutor = APDB $ \_ mAuthId route _ -> exceptT return return $ do
+tagAccessPredicate AuthTutor = APDB $ \_ _ mAuthId route _ -> exceptT return return $ do
   authId <- maybeExceptT AuthenticationRequired $ return mAuthId
   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
@@ -578,14 +604,14 @@ tagAccessPredicate AuthTutor = APDB $ \_ mAuthId route _ -> exceptT return retur
     _ -> do
       guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
       return Authorized
-tagAccessPredicate AuthTutorControl = APDB $ \_ _ route _ -> case route of
+tagAccessPredicate AuthTutorControl = APDB $ \_ _ _ route _ -> case route of
   CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do
     Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
     guard tutorialTutorControlled
     return Authorized
   r -> $unsupportedAuthPredicate AuthTutorControl r
-tagAccessPredicate AuthSubmissionGroup = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthSubmissionGroup = APDB $ \_ _ mAuthId route _ -> case route of
   CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do
     course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
     Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn
@@ -610,7 +636,7 @@ tagAccessPredicate AuthSubmissionGroup = APDB $ \_ mAuthId route _ -> case route
 
     return Authorized
   r -> $unsupportedAuthPredicate AuthSubmissionGroup r
-tagAccessPredicate AuthTime = APDB $ \(runTACont -> cont) mAuthId route isWrite -> case route of
+tagAccessPredicate AuthTime = APDB $ \_ (runTACont -> cont) mAuthId route isWrite -> case route of
   CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
     course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
     Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
@@ -790,7 +816,7 @@ tagAccessPredicate AuthTime = APDB $ \(runTACont -> cont) mAuthId route isWrite
     return Authorized
 
   r -> $unsupportedAuthPredicate AuthTime r
-tagAccessPredicate AuthStaffTime = APDB $ \_ _ route isWrite -> case route of
+tagAccessPredicate AuthStaffTime = APDB $ \_ _ _ route isWrite -> case route of
   CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
     course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
     allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
@@ -815,7 +841,7 @@ tagAccessPredicate AuthStaffTime = APDB $ \_ _ route isWrite -> case route of
     return Authorized
 
   r -> $unsupportedAuthPredicate AuthStaffTime r
-tagAccessPredicate AuthAllocationTime = APDB $ \(runTACont -> cont) mAuthId route isWrite -> case route of
+tagAccessPredicate AuthAllocationTime = APDB $ \_ (runTACont -> cont) mAuthId route isWrite -> case route of
   CourseR tid ssh csh CRegisterR -> do
     now <- liftIO getCurrentTime
     mba <- mbAllocation tid ssh csh
@@ -859,7 +885,7 @@ tagAccessPredicate AuthAllocationTime = APDB $ \(runTACont -> cont) mAuthId rout
       cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
       Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid
       (cid,) <$> MaybeT (get allocationCourseAllocation)
-tagAccessPredicate AuthCourseTime = APDB $ \_ _mAuthId route _ -> case route of
+tagAccessPredicate AuthCourseTime = APDB $ \_ _ _mAuthId route _ -> case route of
   CourseR tid ssh csh _ -> exceptT return return $ do
     now <- liftIO getCurrentTime
     courseVisible <- $cachedHereBinary (tid, ssh, csh) . lift . E.selectExists . E.from $ \course -> do
@@ -870,7 +896,7 @@ tagAccessPredicate AuthCourseTime = APDB $ \_ _mAuthId route _ -> case route of
     guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime)
     return Authorized
   r -> $unsupportedAuthPredicate AuthCourseTime r
-tagAccessPredicate AuthCourseRegistered = 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
     isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
@@ -883,7 +909,7 @@ tagAccessPredicate AuthCourseRegistered = APDB $ \_ mAuthId route _ -> case rout
     guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
     return Authorized
   r -> $unsupportedAuthPredicate AuthCourseRegistered r
-tagAccessPredicate AuthTutorialRegistered = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthTutorialRegistered = APDB $ \_ _ mAuthId route _ -> case route of
   CTutorialR tid ssh csh tutn _ -> exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     isRegistered <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
@@ -908,7 +934,7 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \_ mAuthId route _ -> case ro
     guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
     return Authorized
   r -> $unsupportedAuthPredicate AuthTutorialRegistered r
-tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ _ route _ -> case route of
+tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ _ _ route _ -> case route of
   CExamR tid ssh csh examn _ -> exceptT return return $ do
     isOccurrenceRegistration <- $cachedHereBinary (tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam) -> do
       E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
@@ -920,7 +946,7 @@ tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ _ route _ -> case
     guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration)
     return Authorized
   r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistration r
-tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \_ _ mAuthId route _ -> case route of
   CExamR tid ssh csh examn (ERegisterOccR occn) -> exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn, occn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration `E.InnerJoin` examOccurrence) -> do
@@ -961,7 +987,7 @@ tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \_ mAuthId route _ -> c
     guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
     return Authorized
   r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistered r
-tagAccessPredicate AuthExamRegistered = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthExamRegistered = APDB $ \_ _ mAuthId route _ -> case route of
   CExamR tid ssh csh examn _ -> exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
@@ -1002,7 +1028,7 @@ tagAccessPredicate AuthExamRegistered = APDB $ \_ mAuthId route _ -> case route
     guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredAnyExam
     return Authorized
   r -> $unsupportedAuthPredicate AuthExamRegistered r
-tagAccessPredicate AuthExamResult = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthExamResult = APDB $ \_ _ mAuthId route _ -> case route of
   CExamR tid ssh csh examn _ -> exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     hasResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
@@ -1055,14 +1081,14 @@ tagAccessPredicate AuthExamResult = APDB $ \_ mAuthId route _ -> case route of
     guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult)
     return Authorized
   r -> $unsupportedAuthPredicate AuthExamRegistered r
-tagAccessPredicate AuthAllocationRegistered = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthAllocationRegistered = APDB $ \_ _ mAuthId route _ -> case route of
   AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegistered) $ do
     uid <- hoistMaybe mAuthId
     aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash
     void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid
     return Authorized
   r -> $unsupportedAuthPredicate AuthAllocationRegistered r
-tagAccessPredicate AuthParticipant = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthParticipant = APDB $ \_ _ mAuthId route _ -> case route of
   CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedParticipantSelf) $ do
     nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
     CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId
@@ -1170,7 +1196,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ mAuthId route _ -> case route of
                E.&&. course E.^. CourseTerm      E.==. E.val tid
                E.&&. course E.^. CourseSchool    E.==. E.val ssh
                E.&&. course E.^. CourseShorthand E.==. E.val csh
-tagAccessPredicate AuthApplicant = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthApplicant = APDB $ \_ _ mAuthId route _ -> case route of
   CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do
     uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
     isApplicant <- isCourseApplicant tid ssh csh uid
@@ -1191,7 +1217,7 @@ tagAccessPredicate AuthApplicant = APDB $ \_ mAuthId route _ -> case route of
            E.&&. course E.^. CourseTerm      E.==. E.val tid
            E.&&. course E.^. CourseSchool    E.==. E.val ssh
            E.&&. course E.^. CourseShorthand E.==. E.val csh
-tagAccessPredicate AuthCapacity = APDB $ \_ _ route _ -> case route of
+tagAccessPredicate AuthCapacity = APDB $ \_ _ _ route _ -> case route of
   CExamR tid ssh csh examn (ERegisterOccR occn) -> maybeT (unauthorizedI MsgExamOccurrenceNoCapacity) $ do
     cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
     eid <- $cachedHereBinary (cid, examn) . MaybeT . getKeyBy $ UniqueExam cid examn
@@ -1211,7 +1237,7 @@ tagAccessPredicate AuthCapacity = APDB $ \_ _ route _ -> case route of
     guard $ NTop courseCapacity > NTop (Just registered)
     return Authorized
   r -> $unsupportedAuthPredicate AuthCapacity r
-tagAccessPredicate AuthRegisterGroup = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthRegisterGroup = APDB $ \_ _ mAuthId route _ -> case route of
   CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do
     cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
     Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
@@ -1227,8 +1253,8 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \_ mAuthId route _ -> case route o
         guard $ not hasOther
         return Authorized
   r -> $unsupportedAuthPredicate AuthRegisterGroup r
-tagAccessPredicate AuthEmpty = APDB $ \_ mAuthId route _
+tagAccessPredicate AuthEmpty = APDB $ \_ _ mAuthId route _
-  -> let workflowInstanceWorkflowsEmpty rScope win = maybeT (unauthorizedI MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
+  -> let workflowInstanceWorkflowsEmpty rScope win = selectLanguageI18n <=< $memcacheAuthHere' (Right diffDay) (mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
            scope <- fromRouteWorkflowScope rScope
            let dbScope = scope ^. _DBWorkflowScope
                getWorkflowWorkflows = E.selectSource . E.from $ \(workflowWorkflow `E.InnerJoin` workflowInstance) -> do
@@ -1244,7 +1270,7 @@ tagAccessPredicate AuthEmpty = APDB $ \_ mAuthId route _
                  guardM . fmap (is _Authorized) . flip (evalAccessFor mAuthId) False $ _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
                  return True
            guardM . fmap not . lift . runConduit $ getWorkflowWorkflows .| C.mapM checkAccess .| C.or
-           return Authorized
+           return AuthorizedI18n
       in case route of
            r | Just (rScope, WorkflowInstanceR win WIWorkflowsR) <- r ^? _WorkflowScopeRoute
                -> workflowInstanceWorkflowsEmpty rScope win
@@ -1268,20 +1294,20 @@ tagAccessPredicate AuthEmpty = APDB $ \_ mAuthId route _
                E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
              return Authorized
            r -> $unsupportedAuthPredicate AuthEmpty r
-tagAccessPredicate AuthMaterials = APDB $ \_ _ route _ -> case route of
+tagAccessPredicate AuthMaterials = APDB $ \_ _ _ route _ -> case route of
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
     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
+tagAccessPredicate AuthOwner = APDB $ \_ _ mAuthId route _ -> case route of
   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 AuthPersonalisedSheetFiles = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \_ _ mAuthId route _ -> case route of
   CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . exceptT return return $ do
     Entity shId Sheet{..} <- maybeTMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) $ do
       cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh
@@ -1296,28 +1322,28 @@ tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \_ mAuthId route _ -> cas
                     E.&&. E.not_ (E.isNothing $ psFile E.^. PersonalisedSheetFileContent) -- directories don't count
            return Authorized
   r -> $unsupportedAuthPredicate AuthPersonalisedSheetFiles r
-tagAccessPredicate AuthRated = APDB $ \_ _ route _ -> case route of
+tagAccessPredicate AuthRated = APDB $ \_ _ _ route _ -> case route of
   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
+tagAccessPredicate AuthUserSubmissions = APDB $ \_ _ _ route _ -> case route of
   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
     return Authorized
   r -> $unsupportedAuthPredicate AuthUserSubmissions r
-tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ _ route _ -> case route of
+tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ _ _ route _ -> case route of
   CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
     Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
     guard submissionModeCorrector
     return Authorized
   r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
-tagAccessPredicate AuthSelf = APDB $ \_ mAuthId route _ -> exceptT return return $ do
+tagAccessPredicate AuthSelf = APDB $ \_ _ mAuthId route _ -> exceptT return return $ do
   referencedUser' <- case route of
     AdminUserR cID -> return $ Left cID
     AdminUserDeleteR cID -> return $ Left cID
@@ -1338,7 +1364,7 @@ tagAccessPredicate AuthSelf = APDB $ \_ mAuthId route _ -> exceptT return return
       | uid == referencedUser -> return Authorized
     Nothing -> return AuthenticationRequired
     _other  -> unauthorizedI MsgUnauthorizedSelf
-tagAccessPredicate AuthIsLDAP = APDB $ \_ _ route _ -> exceptT return return $ do
+tagAccessPredicate AuthIsLDAP = APDB $ \_ _ _ route _ -> exceptT return return $ do
   referencedUser <- case route of
     AdminUserR cID -> return cID
     AdminUserDeleteR cID -> return cID
@@ -1352,7 +1378,7 @@ tagAccessPredicate AuthIsLDAP = APDB $ \_ _ route _ -> exceptT return return $ d
     User{..} <- MaybeT $ get referencedUser'
     guard $ userAuthentication == AuthLDAP
   return Authorized
-tagAccessPredicate AuthIsPWHash = APDB $ \_ _ route _ -> exceptT return return $ do
+tagAccessPredicate AuthIsPWHash = APDB $ \_ _ _ route _ -> exceptT return return $ do
   referencedUser <- case route of
     AdminUserR cID -> return cID
     AdminUserDeleteR cID -> return cID
@@ -1366,7 +1392,7 @@ tagAccessPredicate AuthIsPWHash = APDB $ \_ _ route _ -> exceptT return return $
     User{..} <- MaybeT $ get referencedUser'
     guard $ is _AuthPWHash userAuthentication
   return Authorized
-tagAccessPredicate AuthAuthentication = APDB $ \_ mAuthId route _ -> case route of
+tagAccessPredicate AuthAuthentication = APDB $ \_ _ mAuthId route _ -> case route of
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
     smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
     SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
@@ -1380,13 +1406,14 @@ tagAccessPredicate AuthAuthentication = APDB $ \_ mAuthId route _ -> case route
     guard $ not systemMessageAuthenticatedOnly || isAuthenticated
     return Authorized
   r -> $unsupportedAuthPredicate AuthAuthentication r
-tagAccessPredicate AuthWorkflow = APDB $ \eval' mAuthId route isWrite -> do
+tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite -> do
   mr <- getMsgRenderer
   let orAR', _andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
       orAR' = shortCircuitM (is _Authorized) (orAR mr)
       _andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
 
-      wInitiate win rScope = maybeT (unauthorizedI MsgUnauthorizedWorkflowInitiate) $ do
+    
+      wInitiate win rScope = selectLanguageI18n <=< $memcacheAuthHere' (Right diffDay) (evalCtx, route, mAuthId) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowInitiate) $ do -- @isWrite@ not included since it should make no difference regarding initiation (in the end that will always be a write)
         scope <- MaybeT . $cachedHereBinary rScope . runMaybeT $ fromRouteWorkflowScope rScope
         Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
         let
@@ -1400,52 +1427,57 @@ tagAccessPredicate AuthWorkflow = APDB $ \eval' mAuthId route isWrite -> do
           evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId Nothing role route isWrite
           checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors)
         guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges)
-        return Authorized
+        return AuthorizedI18n
 
       wWorkflow isWrite' cID
         | isWrite' = maybeT (unauthorizedI MsgUnauthorizedWorkflowWrite) $ do
-            wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+            (wwId, edges) <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowWorkflowEdgeActors cID) $ do
-            WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
+              wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+              WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
 
-            let
+              let
-              wwGraph :: IdWorkflowGraph
+                wwGraph :: IdWorkflowGraph
-              wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
+                wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
 
-              wwNode = wpTo $ last workflowWorkflowState
+                wwNode = wpTo $ last workflowWorkflowState
 
-              edges = do
+              return . (wwId, ) . (Set.fromList :: _ -> Set (WorkflowRole UserId)) . foldMap toNullable $ do
                 WGN{..} <- wwGraph ^.. _wgNodes . folded
                 WorkflowGraphEdgeManual{..} <- wgnEdges ^.. folded
                 guard $ wgeSource == wwNode
                 hoistMaybe . fromNullable $ wgeActors ^.. folded
 
+            let
               evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route isWrite
-              checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors)
+            guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList edges)
-            guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges)
             return Authorized
         | otherwise = flip orAR' (wWorkflow True cID) . maybeT (unauthorizedI MsgUnauthorizedWorkflowRead) $ do
-            wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+            (wwId, roles) <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowWorkflowViewers cID) $ do
-            WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
+              wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+              WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
+
+              let
+                wwGraph :: IdWorkflowGraph
+                wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
+
+                nodeViewers = do
+                  WorkflowAction{..} <- otoList workflowWorkflowState
+                  (node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph
+                  guard $ node == wpTo
+                  WorkflowNodeView{..} <- hoistMaybe wgnViewers
+                  return $ toNullable wnvViewers
+                payloadViewers = do
+                  (prevActs, act) <- zip (inits $ otoList workflowWorkflowState) $ otoList workflowWorkflowState
+                  prevAct <- hoistMaybe $ prevActs ^? _last
+                  payload <- Map.keys $ wpPayload act
+                  guard $ Map.lookup payload (workflowStateCurrentPayloads prevActs) /= Map.lookup payload (wpPayload act)
+                  fmap (toNullable . wpvViewers) . hoistMaybe $ Map.lookup payload . wgnPayloadView =<< Map.lookup (wpTo prevAct) (wgNodes wwGraph)
+
+              return (wwId, fold nodeViewers <> fold payloadViewers :: (Set (WorkflowRole UserId)))
               
             let
-              wwGraph :: IdWorkflowGraph
-              wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
-
-              nodeViewers = do
-                WorkflowAction{..} <- otoList workflowWorkflowState
-                (node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph
-                guard $ node == wpTo
-                WorkflowNodeView{..} <- hoistMaybe wgnViewers
-                return $ toNullable wnvViewers
-              payloadViewers = do
-                (prevActs, act) <- zip (inits $ otoList workflowWorkflowState) $ otoList workflowWorkflowState
-                prevAct <- hoistMaybe $ prevActs ^? _last
-                payload <- Map.keys $ wpPayload act
-                guard $ Map.lookup payload (workflowStateCurrentPayloads prevActs) /= Map.lookup payload (wpPayload act)
-                fmap (toNullable . wpvViewers) . hoistMaybe $ Map.lookup payload . wgnPayloadView =<< Map.lookup (wpTo prevAct) (wgNodes wwGraph)
-              
               evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route isWrite
-            guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable . otoList $ fold nodeViewers <> fold payloadViewers)
+            guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList roles)
             return Authorized
       wFiles wwCID wpl stCID = maybeT (unauthorizedI MsgUnauthorizedWorkflowFiles) $ do
         wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt wwCID
@@ -1510,10 +1542,11 @@ routeAuthTags = fmap predDNFEntail . ofoldM parse defaultAuthDNF . routeAttrs
 
 evalAuthTags :: forall ctx m. (Binary ctx, MonadAP m) => ctx -> AuthTagActive -> (forall m'. MonadAP m' => AuthTagsEval m') -> AuthTagsEval m
 -- ^ `tell`s disabled predicates, identified as pivots
-evalAuthTags ctx AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite
+evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite
   = do
       mr <- getMsgRenderer
       let
+        contCtx = toStrict $ Binary.encode (ctx, authActive)
         authVarSpecificity = authTagSpecificity `on` plVar
         authDNF = sortBy (authVarSpecificity `on` maximumBy authVarSpecificity . impureNonNull) $ map (sortBy authVarSpecificity) authDNF'
 
@@ -1524,7 +1557,7 @@ evalAuthTags ctx AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toL
           where
             evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
               $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
-              evalAccessPred (tagAccessPredicate authTag') cont mAuthId' route' isWrite'
+              evalAccessPred (tagAccessPredicate authTag') contCtx cont mAuthId' route' isWrite'
 
         evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
         evalAuthLiteral PLVariable{..} = evalAuthTag plVar

src/Foundation/Navigation.hs

@@ -523,6 +523,7 @@ navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M`
   
 defaultLinks :: ( MonadHandler m
                 , HandlerSite m ~ UniWorX
+                , MonadThrow m
                 , BearerAuthSite UniWorX
                 , BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
                 ) => m [Nav]
@@ -708,7 +709,8 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
         }
       }
   , do
-      (haveInstances, haveWorkflows) <- liftHandler . runDB $ (,)
+      authCtx <- getAuthContext
+      (haveInstances, haveWorkflows) <- $memcachedByHere (Just $ Right diffDay) authCtx . liftHandler . runDB $ (,) -- We don't expect haveTopWorkflowWorkflows to be relevant and haveTopWorkflowInstances shouldn't change often
         <$> haveTopWorkflowInstances
         <*> haveTopWorkflowWorkflows
 

src/Foundation/SiteLayout.hs

@@ -38,7 +38,7 @@ import Data.FileEmbed (embedFile)
 
 
 data MemcachedKeyFavourites
-  = MemcachedKeyFavouriteQuickActions CourseId AuthContext (NonEmpty Lang)
+  = MemcachedKeyFavouriteQuickActions (TermId, SchoolId, CourseShorthand) AuthContext (NonEmpty Lang)
   deriving (Generic, Typeable)
 
 deriving instance Eq AuthContext => Eq MemcachedKeyFavourites
@@ -157,12 +157,19 @@ siteLayout' overrideHeading widget = do
 
         E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent
 
-        return (course, reason, courseVisible)
+        return ( ( course E.^. CourseName
+                 , course E.^. CourseTerm
+                 , course E.^. CourseSchool
+                 , course E.^. CourseShorthand
+                 )
+               , reason
+               , courseVisible
+               )
 
-      favCourses' <- forM favCourses'' $ \(course@(Entity _ Course{..}), reason, E.Value courseVisible) -> do
+      favCourses' <- forM favCourses'' $ \((E.Value cName, E.Value tid, E.Value ssh, E.Value csh), reason, E.Value courseVisible) -> do
-        mayView <- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CShowR
+        mayView <- hasReadAccessTo $ CourseR tid ssh csh CShowR
-        mayEdit <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
+        mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR
-        return (course, reason, courseVisible, mayView, mayEdit)
+        return ((cName, tid, ssh, csh), reason, courseVisible, mayView, mayEdit)
 
       let favCourses = favCourses' & filter (\(_, _, _, mayView, _) -> mayView)
 
@@ -172,16 +179,16 @@ siteLayout' overrideHeading widget = do
              )
 
   let favouriteTerms :: [TermIdentifier]
-      favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites'
+      favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\((_, tid, _, _), _, _, _, _) -> Set.singleton $ unTermKey tid) favourites'
   
-  favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite, courseVisible, mayView, mayEdit)
+  favourites <- fmap catMaybes . forM favourites' $ \(c@(_, tid, ssh, csh), E.Value mFavourite, courseVisible, mayView, mayEdit)
-      -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
+      -> let courseRoute = CourseR tid ssh csh CShowR
              favouriteReason = fromMaybe FavouriteCurrent mFavourite
-         in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do
+         in runMaybeT . guardOnM (unTermKey tid `elem` favouriteTerms) . lift $ do
               ctx <- getAuthContext
               MsgRenderer mr <- getMsgRenderer
               langs <- selectLanguages appLanguages <$> languages
-              let cK = MemcachedKeyFavouriteQuickActions cId ctx langs
+              let cK = MemcachedKeyFavouriteQuickActions (tid, ssh, csh) ctx langs
               $logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..."
               items <- memcachedLimitedKeyTimeoutBy
                 MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1
@@ -228,10 +235,10 @@ siteLayout' overrideHeading widget = do
               navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to navBaseRoute) nav
               highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
       highlightNav = (||) <$> navForceActive <*> (highlight . navBaseRoute)
-      favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool, Bool)]
+      favouriteTermReason :: TermIdentifier -> FavouriteReason -> [((CourseName, TermId, SchoolId, CourseShorthand), Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool, Bool)]
       favouriteTermReason tid favReason' = favourites
-        & filter (\(Course{..}, _, _, favReason, _, _, _) -> unTermKey courseTerm == tid && favReason == favReason')
+        & filter (\((_, tid', _, _), _, _, favReason, _, _, _) -> unTermKey tid' == tid && favReason == favReason')
-        & sortOn (\(Course{..}, _, _, _, _, _, _) -> courseName)
+        & sortOn (\((cName, _, _, _), _, _, _, _, _, _) -> cName)
 
       -- We break up the default layout into two components:
       -- default-layout is the contents of the body tag, and

src/Handler/Utils/I18n.hs

@@ -2,6 +2,9 @@ module Handler.Utils.I18n
   ( i18nWidgetFile
   , i18nWidgetFiles
   , i18nMessage
+  , authorizedI18n, authenticationRequiredI18n, unauthorizedI18n
+  , _AuthorizedI18n, _AuthenticationRequiredI18n, _UnauthorizedI18n
+  , pattern UnauthorizedI18n, pattern AuthorizedI18n, pattern AuthenticationRequiredI18n
   , module Utils.I18n
   ) where
 
@@ -70,3 +73,35 @@ i18nMessage :: ( MonadHandler m
                )
             => msg -> m I18nText
 i18nMessage = i18nMessageFor $ toList appLanguages
+
+unauthorizedI18n :: ( MonadHandler m
+                    , HandlerSite m ~ UniWorX
+                    , RenderMessage UniWorX msg
+                    )
+                 => msg -> m I18nAuthResult
+unauthorizedI18n = fmap (fmap Unauthorized) . i18nMessage
+
+_UnauthorizedI18n :: Prism' I18nAuthResult I18nText
+_UnauthorizedI18n = prism' (fmap Unauthorized) . traverse $ preview _Unauthorized
+
+_AuthorizedI18n :: Prism' I18nAuthResult ()
+_AuthorizedI18n = prism' (\() -> authorizedI18n) . traverse_ $ preview _Authorized
+  
+_AuthenticationRequiredI18n :: Prism' I18nAuthResult ()
+_AuthenticationRequiredI18n = prism' (\() -> authenticationRequiredI18n) . traverse_ $ preview _AuthenticationRequired
+
+authorizedI18n, authenticationRequiredI18n :: I18nAuthResult
+authorizedI18n = opoint Authorized
+authenticationRequiredI18n = opoint Authorized
+
+pattern UnauthorizedI18n :: I18nText -> I18nAuthResult
+pattern UnauthorizedI18n x <- (preview _UnauthorizedI18n -> Just x) where
+  UnauthorizedI18n = review _UnauthorizedI18n
+
+pattern AuthorizedI18n :: I18nAuthResult
+pattern AuthorizedI18n <- (preview _AuthorizedI18n -> Just ()) where
+  AuthorizedI18n = authorizedI18n
+
+pattern AuthenticationRequiredI18n :: I18nAuthResult
+pattern AuthenticationRequiredI18n <- (preview _AuthenticationRequiredI18n -> Just ()) where
+  AuthenticationRequiredI18n = authenticationRequiredI18n

src/Handler/Utils/Memcached.hs

@@ -11,6 +11,9 @@ module Handler.Utils.Memcached
   , memcachedLimitedHere, memcachedLimitedKeyHere, memcachedLimitedByHere, memcachedLimitedKeyByHere
   , memcachedLimitedTimeout, memcachedLimitedKeyTimeout, memcachedLimitedTimeoutBy, memcachedLimitedKeyTimeoutBy
   , memcachedLimitedTimeoutHere, memcachedLimitedKeyTimeoutHere, memcachedLimitedTimeoutByHere, memcachedLimitedKeyTimeoutByHere
+  , memcacheAuth, memcacheAuthHere
+  , memcacheAuth', memcacheAuthHere'
+  , memcacheAuthMax, memcacheAuthHereMax
   , Expiry
   , MemcachedException(..), AsyncTimeoutException(..)
   ) where
@@ -22,9 +25,11 @@ import Foundation.Type
 import qualified Database.Memcached.Binary.IO as Memcached
 import Data.Bits (Bits(zeroBits), toIntegralSized)
 
-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime, getPOSIXTime, POSIXTime)
 
 import qualified Data.Binary as Binary
+import qualified Data.Binary.Put as Binary
+import qualified Data.Binary.Get as Binary
 
 import Crypto.Hash.Algorithms (SHAKE256)
 
@@ -74,6 +79,55 @@ _MemcachedExpiry = prism' fromExpiry toExpiry
           | otherwise
           = Left . posixSecondsToUTCTime $ fromIntegral n
 
+data MemcachedValue = MemcachedValue
+  { mNonce :: AEAD.Nonce
+  , mExpiry :: Maybe POSIXTime
+  , mCiphertext :: ByteString
+  } deriving (Generic, Typeable)
+
+putExpiry :: Maybe POSIXTime -> Binary.Put
+putExpiry mExp = Binary.put $ fromMaybe 0 expEnc
+  where
+    expEnc :: Maybe Word64
+    expEnc = mExp <&> \exp ->
+      let expEnc' :: Integer
+          expEnc' = ceiling exp
+       in if | 0 < expEnc', expEnc' < fromIntegral (maxBound :: Word64)
+               -> fromIntegral expEnc'
+             | otherwise
+               -> error "Expiry cannot be represented in 64 unsigned bits"
+
+getExpiry :: Binary.Get (Maybe POSIXTime)
+getExpiry = Binary.label "expiry" $ do
+  mExpiry' <- Binary.get :: Binary.Get Word64
+  return $ if
+    | mExpiry' == 0 -> Nothing
+    | otherwise     -> Just $ fromIntegral mExpiry'
+
+putMemcachedValue :: MemcachedValue -> Binary.Put
+putMemcachedValue MemcachedValue{..} = do
+  Binary.putByteString $ Saltine.encode mNonce
+  putExpiry mExpiry
+  Binary.putByteString mCiphertext
+
+getMemcachedValue :: Binary.Get MemcachedValue
+getMemcachedValue = do
+  Binary.lookAhead . Binary.label "length check" $ do
+    void . Binary.getByteString $ Saltine.secretBoxNonce + 4 + Saltine.secretBoxMac
+  mNonce <- Binary.label "nonce" $ Binary.getByteString Saltine.secretBoxNonce >>= hoistMaybe . Saltine.decode
+  mExpiry <- getExpiry
+  mCiphertext <- Binary.label "ciphertext" $ toStrict <$> Binary.getRemainingLazyByteString
+  return MemcachedValue{..}
+
+getMemcachedValueNoExpiry :: Binary.Get MemcachedValue
+getMemcachedValueNoExpiry = do
+  Binary.lookAhead . Binary.label "length check" $ do
+    void . Binary.getByteString $ Saltine.secretBoxNonce + 4 + Saltine.secretBoxMac
+  mNonce <- Binary.label "nonce" $ Binary.getByteString Saltine.secretBoxNonce >>= hoistMaybe . Saltine.decode
+  let mExpiry = Nothing
+  mCiphertext <- Binary.label "ciphertext" $ toStrict <$> Binary.getRemainingLazyByteString
+  return MemcachedValue{..}
+
 
 memcachedAvailable :: ( MonadHandler m, HandlerSite m ~ UniWorX
                       )
@@ -95,6 +149,11 @@ memcachedKey (Saltine.encode -> kmacKey) p k = Binary.encode k
   & kmaclazy @(SHAKE256 256) (encodeUtf8 . tshow $ typeRep p) kmacKey
   & BA.convert
 
+memcachedAAD :: ByteString -> Maybe POSIXTime -> ByteString
+memcachedAAD cKey mExpiry = toStrict . Binary.runPut $ do
+  Binary.putByteString cKey
+  putExpiry mExpiry
+
 memcachedByGet :: forall a k m.
                   ( MonadHandler m, HandlerSite m ~ UniWorX
                   , Typeable a, Binary a
@@ -109,19 +168,27 @@ memcachedByGet k = runMaybeT $ do
 
   $logDebugS "memcached" "Cache hit"
 
-  guard $ length encVal >= Saltine.secretBoxNonce + Saltine.secretBoxMac
+  let withExp doExp = do
-  let (nonceBS, encrypted) = splitAt Saltine.secretBoxNonce encVal
+        MemcachedValue{..} <- hoistMaybe . flip runGetMaybe encVal $ bool getMemcachedValueNoExpiry getMemcachedValue doExp
-  nonce <- hoistMaybe $ Saltine.decode nonceBS
+        $logDebugS "memcached" "Decode valid"
-  decrypted <- hoistMaybe $ AEAD.aeadOpen aeadKey nonce encrypted cKey
+        for_ mExpiry $ \expiry -> do
+          now <- liftIO getPOSIXTime
+          guard $ expiry > now + clockLeniency
+        $logDebugS "memcached" $ "Expiry valid: " <> tshow mExpiry
+        let aad = memcachedAAD cKey mExpiry
+        decrypted <- hoistMaybe $ AEAD.aeadOpen aeadKey mNonce mCiphertext aad
 
-  $logDebugS "memcached" "Decryption valid"
+        $logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration"
 
-  case Binary.decodeOrFail $ fromStrict decrypted of
+        hoistMaybe $ runGetMaybe Binary.get decrypted
-    Right (unconsumed, _, v)
+
-      | null unconsumed -> do
+  withExp True <|> withExp False
-          $logDebugS "memcached" "Deserialization valid"
+  where
-          return v
+    runGetMaybe p (fromStrict -> bs) = case Binary.runGetOrFail p bs of
-    _other -> mzero
+      Right (bs', _, x) | null bs' -> Just x
+      _other -> Nothing
+    clockLeniency :: NominalDiffTime
+    clockLeniency = 2
 
 memcachedBySet :: forall a k m.
                   ( MonadHandler m, HandlerSite m ~ UniWorX
@@ -134,11 +201,15 @@ memcachedBySet mExp k v = do
   mExp' <- for mExp $ \exp -> maybe (throwM $ MemcachedInvalidExpiry exp) return $ exp ^? _MemcachedExpiry
   mConn <- getsYesod appMemcached
   for_ mConn $ \(aeadKey, conn) -> do
-    nonce <- liftIO AEAD.newNonce
+    mNonce <- liftIO AEAD.newNonce
+    mExpiry <- for mExp $ \case
+      Left uTime -> return $ utcTimeToPOSIXSeconds uTime
+      Right diff -> liftIO $ (+ realToFrac diff) <$> getPOSIXTime
     let cKey = memcachedKey aeadKey (Proxy @a) k
-        encVal = Saltine.encode nonce <> AEAD.aead aeadKey nonce (toStrict $ Binary.encode v) cKey
+        aad = memcachedAAD cKey mExpiry
-    liftIO $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (fromStrict encVal) conn
+        mCiphertext = AEAD.aead aeadKey mNonce (toStrict $ Binary.encode v) aad
-    $logDebugS "memcached" "Cache store"
+    liftIO $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (Binary.runPut $ putMemcachedValue MemcachedValue{..}) conn
+    $logDebugS "memcached" $ "Cache store: " <> tshow mExpiry
 
 memcachedByInvalidate :: forall a k m p.
                          ( MonadHandler m, HandlerSite m ~ UniWorX
@@ -178,20 +249,19 @@ memcachedInvalidate _ = memcachedByInvalidate () $ Proxy @(MemcachedUnkeyed a)
 
 
 memcachedWith :: Monad m
-              => (m (Maybe a), a -> m ()) -> m a -> m a
+              => (m (Maybe b), a -> m b) -> m a -> m b
 memcachedWith (doGet, doSet) act = do
   pRes <- doGet
   maybe id (const . return) pRes $ do
     res <- act
     doSet res
-    return res
 
 memcached :: ( MonadHandler m, HandlerSite m ~ UniWorX
              , MonadThrow m
              , Typeable a, Binary a
              )
           => Maybe Expiry -> m a -> m a
-memcached mExp = memcachedWith (memcachedGet, memcachedSet mExp)
+memcached mExp = memcachedWith (memcachedGet, \x -> x <$ memcachedSet mExp x)
 
 memcachedBy :: ( MonadHandler m, HandlerSite m ~ UniWorX
                , MonadThrow m
@@ -199,7 +269,7 @@ memcachedBy :: ( MonadHandler m, HandlerSite m ~ UniWorX
                , Binary k
                )
             => Maybe Expiry -> k -> m a -> m a
-memcachedBy mExp k = memcachedWith (memcachedByGet k, memcachedBySet mExp k)
+memcachedBy mExp k = memcachedWith (memcachedByGet k, \x -> x <$ memcachedBySet mExp k x)
 
 
 newtype MemcachedUnkeyedLoc a = MemcachedUnkeyedLoc { unMemcachedUnkeyedLoc :: a }
@@ -354,6 +424,68 @@ memcachedLimitedKeyByHere = do
   [e| \lK burst rate tokens mExp k -> fmap (fmap unMemcachedKeyedLoc) . memcachedLimitedKeyBy lK burst rate tokens mExp (loc, k) . fmap MemcachedKeyedLoc |]
 
 
+memcacheAuth :: forall m k a.
+                ( MonadHandler m, HandlerSite m ~ UniWorX
+                , MonadThrow m
+                , Typeable a, Binary a
+                , Binary k
+                )
+             => k
+             -> WriterT (Maybe (Min Expiry)) m a
+             -> m a
+memcacheAuth k mx = cachedByBinary k $ do
+  mayCache <- getsYesod $ view _appMemcacheAuth
+  if | mayCache
+       -> memcachedWith
+            ( memcachedByGet k
+            , \(x, mExp) -> x <$ case mExp of
+                Nothing        -> return ()
+                Just (Min exp) -> memcachedBySet (Just exp) k x
+            ) $ runWriterT mx
+     | otherwise
+       -> evalWriterT mx
+
+memcacheAuth' :: forall m k a.
+                 ( MonadHandler m, HandlerSite m ~ UniWorX
+                 , MonadThrow m
+                 , Typeable a, Binary a
+                 , Binary k
+                 )
+              => Expiry
+              -> k
+              -> m a
+              -> m a
+memcacheAuth' exp k = memcacheAuth k . (<* tell (Just $ Min exp)) . lift
+  
+memcacheAuthMax :: forall m k a.
+                   ( MonadHandler m, HandlerSite m ~ UniWorX
+                   , MonadThrow m
+                   , Typeable a, Binary a
+                   , Binary k
+                   )
+                => Expiry
+                -> k
+                -> WriterT (Maybe (Min Expiry)) m a
+                -> m a
+memcacheAuthMax exp k = memcacheAuth k . (tell (Just $ Min exp) *>)
+
+memcacheAuthHere :: Q Exp
+memcacheAuthHere = do
+  loc <- location
+  [e| \k -> fmap unMemcachedKeyedLoc . memcacheAuth (loc, k) . fmap MemcachedKeyedLoc |]
+
+memcacheAuthHere' :: Q Exp
+memcacheAuthHere' = do
+  loc <- location
+  [e| \exp k -> fmap unMemcachedKeyedLoc . memcacheAuth' exp (loc, k) . fmap MemcachedKeyedLoc |]
+  
+memcacheAuthHereMax :: Q Exp
+memcacheAuthHereMax = do
+  loc <- location
+  [e| \exp k -> fmap unMemcachedKeyedLoc . memcacheAuthMax exp (loc, k) . fmap MemcachedKeyedLoc |]
+
+
+
 data AsyncTimeoutException = AsyncTimeoutReturnTypeDoesNotMatchComputationKey
   deriving (Show, Typeable)
   deriving anyclass (Exception)

src/Handler/Utils/Workflow/Workflow.hs

@@ -31,6 +31,7 @@ followEdge :: ( MonadHandler m
               , MonadThrow m
               )
            => IdWorkflowGraph -> WorkflowEdgeForm -> Maybe IdWorkflowState -> m IdWorkflowState
+-- | Remember to invalidate auth cache
 followEdge graph edgeRes cState = do
   act <- workflowEdgeFormToAction edgeRes
   followAutomaticEdges graph $ maybe id (<>) cState (act `ncons` mempty)

src/Handler/Workflow/Workflow/Workflow.hs

@@ -91,6 +91,9 @@ workflowR rScope cID = do
       edgeAct <- formResultMaybe edgeRes $ \edgeRes' -> do
         nState <- followEdge wGraph edgeRes' . Just $ _DBWorkflowState # workflowWorkflowState
 
+        memcachedByInvalidate (AuthCacheWorkflowWorkflowEdgeActors cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId))
+        memcachedByInvalidate (AuthCacheWorkflowWorkflowViewers cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId))
+
         update wwId [ WorkflowWorkflowState =. view _DBWorkflowState nState ]
 
         return . Just $ do

src/Settings.hs

@@ -171,6 +171,7 @@ data AppSettings = AppSettings
     , appAllowDeprecated        :: Bool
     -- ^ Indicate if deprecated routes are accessible for everyone
     , appEncryptErrors          :: Bool
+    , appClearCache             :: Bool
 
     , appUserDefaults           :: UserDefaultConf
     , appAuthPWHash             :: PWHashConf
@@ -201,6 +202,8 @@ data AppSettings = AppSettings
 
     , appInitialInstanceID      :: Maybe (Either FilePath UUID)
     , appRibbon                 :: Maybe Text
+
+    , appMemcacheAuth           :: Bool
     } deriving Show
 
 data ApprootScope = ApprootUserGenerated | ApprootDefault
@@ -534,6 +537,7 @@ instance FromJSON AppSettings where
         appAllowDeprecated        <- o .:? "allow-deprecated" .!= defaultDev
         appEncryptErrors          <- o .:? "encrypt-errors"   .!= not defaultDev
         appServerSessionAcidFallback <- o .:? "server-session-acid-fallback" .!= defaultDev
+        appClearCache             <- o .:? "clear-cache"      .!= defaultDev
 
         appInitialLogSettings     <- o .:  "log-settings"
 
@@ -580,6 +584,8 @@ instance FromJSON AppSettings where
 
         appDownloadTokenExpire <- o .: "download-token-expire"
 
+        appMemcacheAuth <- o .:? "memcache-auth" .!= False
+
         return AppSettings{..}
 
 makeClassy_ ''AppSettings

src/Utils/DateTime.hs

@@ -11,6 +11,7 @@ module Utils.DateTime
   , mkDateTimeFormatter
   , nominalHour, nominalMinute
   , minNominalYear, avgNominalYear
+  , diffMinute, diffHour, diffDay
   , module Zones
   , day
   ) where
@@ -18,7 +19,7 @@ module Utils.DateTime
 import ClassyPrelude.Yesod hiding (lift)
 import System.Locale.Read
 
-import Data.Time (NominalDiffTime, nominalDay, LocalTime(..), TimeOfDay, midnight, ZonedTime(..))
+import Data.Time (NominalDiffTime, nominalDay, LocalTime(..), TimeOfDay, midnight, ZonedTime(..), DiffTime)
 import Data.Time.Zones as Zones (TZ)
 import Data.Time.Zones.TH as Zones (includeSystemTZ)
 import Data.Time.Zones (localTimeToUTCTZ, timeZoneForUTCTime)
@@ -148,6 +149,15 @@ minNominalYear, avgNominalYear :: NominalDiffTime
 minNominalYear = 365 * nominalDay
 avgNominalYear = fromRational $ 365.2425 * toRational nominalDay
 
+--------------
+-- DiffTime --
+--------------
+
+diffMinute, diffHour, diffDay :: DiffTime
+diffMinute = 60
+diffHour = 3600
+diffDay = 86400
+
 ---------
 -- Day --
 ---------

src/Utils/I18n.hs

@@ -2,7 +2,7 @@
 
 module Utils.I18n
   ( I18n(..)
-  , I18nText, I18nHtml
+  , I18nText, I18nHtml, I18nAuthResult
   , renderMessageI18n
   , i18nMessageFor
   , LanguageSelectI18n(..), getLanguageSelectI18n
@@ -46,6 +46,8 @@ import Control.Lens.Extras (is)
 
 import Control.Monad.Fail (fail)
 
+import Data.Binary (Binary)
+
 
 {-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
 
@@ -55,11 +57,12 @@ data I18n a = I18n
   , i18nFallbackLang :: Maybe Lang
   , i18nTranslations :: Map Lang a
   } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data, Generic, Typeable)
-    deriving anyclass (MonoFunctor, MonoFoldable, MonoTraversable)
+    deriving anyclass (MonoFunctor, MonoFoldable, MonoTraversable, Binary)
 type instance Element (I18n a) = a
 
 type I18nText = I18n Text
 type I18nHtml = I18n Html
+type I18nAuthResult = I18n AuthResult
 
 
 instance MonoPointed (I18n a) where
@@ -102,6 +105,36 @@ instance FromJSON a => FromJSON (I18n a) where
 derivePersistFieldJSON ''I18n
 
 
+unI18n :: [Lang] -> I18n a -> a
+unI18n langs I18n{..} = case i18nFallbackLang of
+  Just fL -> let translations' = Map.insert fL i18nFallback i18nTranslations
+                 avLangs = fL :| filter (/= fL) (Map.keys i18nTranslations)
+              in Map.findWithDefault i18nFallback (selectLanguage' avLangs langs) translations'
+  Nothing -> let fakeLang = go Nothing
+                   where go  Nothing | fake `Map.member` i18nTranslations = go $ Just 1
+                                     | otherwise = fake
+                           where fake = "fake"
+                         go (Just n) | fake `Map.member` i18nTranslations = go . Just $ succ n
+                                     | otherwise = fake
+                           where fake = "fake-" <> tshow n
+              in Map.findWithDefault i18nFallback (selectLanguage' (fakeLang :| Map.keys i18nTranslations) langs) i18nTranslations
+
+
+instance Applicative I18n where
+  pure = opoint
+  f <*> x = I18n
+    { i18nFallback = i18nFallback f $ unI18n (maybeToList $ i18nFallbackLang f) x
+    , i18nFallbackLang = if
+        | i18nFallbackLang f == i18nFallbackLang x -> i18nFallbackLang f
+        | otherwise -> Nothing
+    , i18nTranslations = Map.fromList $ do
+        let fLangs = Map.keysSet $ i18nTranslations f
+            xLangs = Map.keysSet $ i18nTranslations x
+        lang <- Set.toList $ fLangs <> xLangs
+        return (lang, unI18n [lang] f $ unI18n [lang] x)
+    }
+
+
 renderMessageI18n :: RenderMessage site msg
                   => [Lang] -> site -> msg -> I18nText
 renderMessageI18n ls app msg = I18n{..}
@@ -123,22 +156,7 @@ data LanguageSelectI18n = LanguageSelectI18n { slI18n :: forall a. I18n a -> a }
 
 getLanguageSelectI18n :: MonadHandler m
                       => m LanguageSelectI18n
-getLanguageSelectI18n = do
+getLanguageSelectI18n = languages <&> \langs -> LanguageSelectI18n (unI18n langs)
-  langs <- languages
-  return $ LanguageSelectI18n
-    ( \I18n{..} -> case i18nFallbackLang of
-         Just fL -> let translations' = Map.insert fL i18nFallback i18nTranslations
-                        avLangs = fL :| filter (/= fL) (Map.keys i18nTranslations)
-                     in Map.findWithDefault i18nFallback (selectLanguage' avLangs langs) translations'
-         Nothing -> let fakeLang = go Nothing
-                          where go  Nothing | fake `Map.member` i18nTranslations = go $ Just 1
-                                            | otherwise = fake
-                                  where fake = "fake"
-                                go (Just n) | fake `Map.member` i18nTranslations = go . Just $ succ n
-                                            | otherwise = fake
-                                  where fake = "fake-" <> tshow n
-                     in Map.findWithDefault i18nFallback (selectLanguage' (fakeLang :| Map.keys i18nTranslations) langs) i18nTranslations
-    )
 
 selectLanguageI18n :: MonadHandler m
                    => I18n a -> m a

src/Yesod/Core/Types/Instances.hs

@@ -77,3 +77,7 @@ runCachedMemoT = do
 
 instance site ~ site' => ToWidget site (SomeMessage site') where
   toWidget msg = toWidget =<< (getMessageRender <*> pure msg)
+
+
+deriving instance Generic AuthResult
+instance Binary AuthResult

templates/widgets/asidenav/asidenav.hamlet

@@ -21,12 +21,12 @@ $newline never
             <h3 .asidenav__box-subtitle>
               _{favReason}
             <ul .asidenav__list.list--iconless>
-              $forall (Course{courseShorthand, courseName}, courseRoute, mPageActions, _, courseVisible, _, mayEdit) <- favouriteTermReason tid favReason
+              $forall ((cName, _, _, csh), courseRoute, mPageActions, _, courseVisible, _, mayEdit) <- favouriteTermReason tid favReason
                 <li .asidenav__list-item :highlight courseRoute:.asidenav__list-item--active>
                   <a .asidenav__link-wrapper href=@{courseRoute}>
-                    <div .asidenav__link-shorthand>#{courseShorthand}
+                    <div .asidenav__link-shorthand>#{csh}
                     <div .asidenav__link-label>
-                      #{courseName}
+                      #{cName}
                       $if mayEdit && not courseVisible
                         \ #{iconInvisible}
                   <div .asidenav__nested-list-wrapper>