From 710b591b4ac1ba3be6685415c7de65ef8df7eba2 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Wed, 3 Apr 2019 22:07:30 +0200
Subject: [PATCH 01/13] Improve AuthPred memoisation

---
 src/Foundation.hs                 | 126 +++++++++++++++++-------------
 src/Import/NoFoundation.hs        |   2 +-
 src/Model/Types.hs                |   2 +
 src/Yesod/Core/Instances.hs       |  65 ++++++++++-----
 src/Yesod/Core/Types/Instances.hs |  36 ++++++++-
 start.sh                          |  11 ++-
 6 files changed, 156 insertions(+), 86 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index 0d8e5d909..0aca60110 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -60,7 +60,7 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Trans.Reader (runReader, mapReaderT)
 import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
 import Control.Monad.Writer.Class (MonadWriter(..))
-import Control.Monad.Memo (MemoT, startEvalMemoT, MonadMemo(..))
+import Control.Monad.Memo.Class (MonadMemo(..), for4)
 import qualified Control.Monad.Catch as C
 
 import Handler.Utils.StudyFeatures
@@ -137,6 +137,8 @@ type SMTPPool = Pool SMTPConnection
 -- type Widget    = WidgetT  UniWorX IO ()
 mkYesodData "UniWorX" $(parseRoutesFile "routes")
 
+deriving instance Generic (Route UniWorX)
+
 -- | Convenient Type Synonyms:
 type DB a = YesodDB UniWorX a
 type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
@@ -385,24 +387,24 @@ appLanguagesOpts = do
 
 -- Access Control
 data AccessPredicate
-  = APPure     (Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
-  | APHandler  (Route UniWorX -> Bool -> Handler AuthResult)
-  | APDB       (Route UniWorX -> Bool -> DB AuthResult)
+  = APPure     (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
+  | APHandler  (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Handler AuthResult)
+  | APDB       (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> DB AuthResult)
 
 class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
-  evalAccessPred :: AccessPredicate -> Route UniWorX -> Bool -> m AuthResult
+  evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
 
 instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
-  evalAccessPred aPred r w = liftHandlerT $ case aPred of
-    (APPure    p) -> runReader (p r w) <$> getMsgRenderer
-    (APHandler p) -> p r w
-    (APDB      p) -> runDB $ p r w
+  evalAccessPred aPred aid r w = liftHandlerT $ case aPred of
+    (APPure    p) -> runReader (p aid r w) <$> getMsgRenderer
+    (APHandler p) -> p aid r w
+    (APDB      p) -> runDB $ p aid r w
 
 instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where
-  evalAccessPred aPred r w = mapReaderT liftHandlerT $ case aPred of
-    (APPure    p) -> lift $ runReader (p r w) <$> getMsgRenderer
-    (APHandler p) -> lift $ p r w
-    (APDB      p) -> p r w
+  evalAccessPred aPred aid r w = mapReaderT liftHandlerT $ case aPred of
+    (APPure    p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
+    (APHandler p) -> lift $ p aid r w
+    (APDB      p) -> p aid r w
 
 
 orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
@@ -423,16 +425,16 @@ trueAR = const Authorized
 falseAR = Unauthorized . ($ MsgUnauthorized) . render
 
 trueAP, falseAP :: AccessPredicate
-trueAP  = APPure . const . const $ trueAR <$> ask
-falseAP = APPure . const . const $ falseAR <$> ask -- included for completeness
+trueAP  = APPure . const . const . const $ trueAR <$> ask
+falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
 
 
 tagAccessPredicate :: AuthTag -> AccessPredicate
 tagAccessPredicate AuthFree = trueAP
-tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
+tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
   -- Courses: access only to school admins
   CourseR tid ssh csh _ -> exceptT return return $ do
-    authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+    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
       E.where_  $ userAdmin E.^. UserAdminUser E.==. E.val authId
@@ -444,13 +446,13 @@ tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
     return Authorized
   -- other routes: access to any admin is granted here
   _other -> exceptT return return $ do
-    authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
     guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
     return Authorized
-tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of
+tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
   AdminHijackUserR cID -> exceptT return return $ do
-    myUid <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+    myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
     uid <- decrypt cID
     otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
     otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
@@ -458,21 +460,21 @@ tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of
     guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
     return Authorized
   r -> $unsupportedAuthPredicate AuthNoEscalation r
-tagAccessPredicate AuthDeprecated = APHandler $ \r _ -> do
+tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do
   $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
   addMessageI Error MsgDeprecatedRoute
   allow <- appAllowDeprecated . appSettings <$> getYesod
   return $ bool (Unauthorized "Deprecated Route") Authorized allow
-tagAccessPredicate AuthDevelopment = APHandler $ \r _ -> do
+tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
   $logWarnS "AccessControl" ("route in development: " <> tshow r)
 #ifdef DEVELOPMENT
   return Authorized
 #else
   return $ Unauthorized "Route under development"
 #endif
-tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of
+tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
   CourseR tid ssh csh _ -> exceptT return return $ do
-     authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+     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
        E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
@@ -484,11 +486,11 @@ tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of
      return Authorized
   -- lecturer for any school will do
   _ -> exceptT return return $ do
-     authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
      void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
      return Authorized
-tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do
-  authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+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
     E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
     E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
@@ -515,7 +517,7 @@ tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do
     _ -> do
       guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
       return Authorized
-tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
+tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
   CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
     Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
@@ -541,8 +543,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
   CourseR tid ssh csh CRegisterR -> do
     now <- liftIO getCurrentTime
     mbc <- getBy $ TermSchoolCourseShort tid ssh csh
-    mAid <- lift maybeAuthId
-    registered <- case (mbc,mAid) of
+    registered <- case (mbc,mAuthId) of
       (Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid)
       _ -> return False
     case mbc of
@@ -564,9 +565,9 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
     return Authorized
 
   r -> $unsupportedAuthPredicate AuthTime r
-tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
+tagAccessPredicate AuthRegistered = APDB $ \mAuthId route _ -> case route of
   CourseR tid ssh csh _ -> exceptT return return $ do
-    authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     [E.Value c] <- 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
@@ -577,7 +578,7 @@ tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
     guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
     return Authorized
   r -> $unsupportedAuthPredicate AuthRegistered r
-tagAccessPredicate AuthParticipant = APDB $ \route _ -> case route of
+tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
   CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
     let authorizedIfExists f = do
           [E.Value ok] <- lift . E.select . return . E.exists $ E.from f
@@ -639,14 +640,14 @@ tagAccessPredicate AuthParticipant = APDB $ \route _ -> case route of
            E.&&. course E.^. CourseShorthand E.==. E.val csh
     unauthorizedI MsgUnauthorizedParticipant
   r -> $unsupportedAuthPredicate AuthParticipant r
-tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of
+tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
     Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
     guard $ NTop courseCapacity > NTop (Just registered)
     return Authorized
   r -> $unsupportedAuthPredicate AuthCapacity r
-tagAccessPredicate AuthEmpty = APDB $ \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
@@ -657,50 +658,50 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
       return E.countRows
     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{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     guard courseMaterialFree
     return Authorized
   r -> $unsupportedAuthPredicate AuthMaterials r
-tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of
+tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of
   CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
     sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
-    authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+    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
+tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of
   CSubmissionR _ _ _ _ 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 _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
     Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
     guard $ sheetSubmissionMode == UserSubmissions
     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 _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
     guard $ sheetSubmissionMode == CorrectorSubmissions
     return Authorized
   r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
-tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
+tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
     smId <- decrypt cID
     SystemMessage{..} <- MaybeT $ get smId
-    isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
+    let isAuthenticated = isJust mAuthId
     guard $ not systemMessageAuthenticatedOnly || isAuthenticated
     return Authorized
   r -> $unsupportedAuthPredicate AuthAuthentication r
-tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
-tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
+tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
+tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
 
 
 newtype InvalidAuthTag = InvalidAuthTag Text
@@ -734,25 +735,29 @@ routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM p
       | otherwise
         = Left $ InvalidAuthTag t
 
-evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
+evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> 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 . toNullable -> authDNF) route isWrite
-  = startEvalMemoT $ do
-      mr <- lift getMsgRenderer
+evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) mAuthId route isWrite
+  = do
+      mr <- getMsgRenderer
       let
         authTagIsInactive = not . authTagIsActive
 
-        evalAuthTag :: AuthTag -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
-        evalAuthTag = memo $ \authTag -> lift . lift $ evalAccessPred (tagAccessPredicate authTag) route isWrite
+        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
+          where
+            evalAccessPred' authTag' mAuthId' route' isWrite' = CachedMemoT $ do
+              $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
+              evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite'
 
         orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
         orAR' = shortCircuitM (is _Authorized) (orAR mr)
         andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
 
-        evalDNF :: [[AuthTag]] -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
+        evalDNF :: [[AuthTag]] -> WriterT (Set AuthTag) m AuthResult
         evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthTag aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
 
-      lift . $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF
+      $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF
 
       result <- evalDNF $ filter (all authTagIsActive) authDNF
 
@@ -760,16 +765,25 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toN
         whenM (allM conj (\aTag -> (return . not $ authTagIsActive aTag) `or2M` (not . is _Unauthorized <$> evalAuthTag aTag))) $ do
           let pivots = filter authTagIsInactive conj
           whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do
-            lift $ $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|]
-            lift . tell $ Set.fromList pivots
+            $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|]
+            tell $ Set.fromList pivots
 
       return result
 
+evalAccessFor :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
+evalAccessFor mAuthId route isWrite = do
+  dnf <- either throwM return $ routeAuthTags route
+  fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite
+
+evalAccessForDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
+evalAccessForDB = evalAccessFor
+
 evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
 evalAccess route isWrite = do
+  mAuthId <- liftHandlerT maybeAuthId
   tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
   dnf <- either throwM return $ routeAuthTags route
-  (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf route isWrite
+  (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf mAuthId route isWrite
   result <$ tellSessionJson SessionInactiveAuthTags deactivated
 
 evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index 457682087..21e0b5de5 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -17,7 +17,7 @@ import Yesod.Default.Config2  as Import
 import Utils                  as Import
 import Utils.Modal            as Import
 import Yesod.Core.Json        as Import (provideJson)
-import Yesod.Core.Types.Instances as Import ()
+import Yesod.Core.Types.Instances as Import (CachedMemoT(..))
 
 
 import Data.Fixed             as Import
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 775900850..7cf317d0c 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -749,6 +749,8 @@ instance ToJSONKey AuthTag where
 instance FromJSONKey AuthTag where
   fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
 
+instance Binary AuthTag
+
 
 newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool }
   deriving (Read, Show, Generic)
diff --git a/src/Yesod/Core/Instances.hs b/src/Yesod/Core/Instances.hs
index 6512c936a..b8c6fed80 100644
--- a/src/Yesod/Core/Instances.hs
+++ b/src/Yesod/Core/Instances.hs
@@ -15,37 +15,58 @@ import Data.ByteString.Builder (toLazyByteString)
 import System.FilePath ((</>))
 
 import Data.Aeson
+import Data.Aeson.Types
 
 import Control.Monad.Fix
 import Control.Monad.Fail (MonadFail)
 import qualified Control.Monad.Fail as MonadFail
 import Control.Monad.Except (MonadError(..))
 import Data.Functor.Extend
-  
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+
+routeFromPathPiece :: ParseRoute site => Text -> Maybe (Route site)
+routeFromPathPiece
+  = parseRoute
+  . over (_2.traverse._2) (fromMaybe "")
+  . over _2 queryToQueryText
+  . decodePath
+  . encodeUtf8
+
+routeToPathPiece :: RenderRoute site => Route site -> Text
+routeToPathPiece
+  = pack
+  . ("/" </>)
+  . unpack
+  . decodeUtf8
+  . toLazyByteString
+  . uncurry encodePath
+  . over _2 queryTextToQuery
+  . over (_2.traverse._2) (assertM' $ not . null)
+  . renderRoute
+
 
 instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
-  fromPathPiece
-    = parseRoute
-    . over (_2.traverse._2) (fromMaybe "")
-    . over _2 queryToQueryText
-    . decodePath
-    . encodeUtf8
-  toPathPiece
-    = pack
-    . ("/" </>)
-    . unpack
-    . decodeUtf8
-    . toLazyByteString
-    . uncurry encodePath
-    . over _2 queryTextToQuery
-    . over (_2.traverse._2) (assertM' $ not . null)
-    . renderRoute
+  fromPathPiece = routeFromPathPiece
+  toPathPiece = routeToPathPiece
     
-instance (RenderRoute site, ParseRoute site) => FromJSON (Route site) where
-  parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . fromPathPiece
+instance ParseRoute site => FromJSON (Route site) where
+  parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . routeFromPathPiece
 
-instance (RenderRoute site, ParseRoute site) => ToJSON (Route site) where
-  toJSON = String . toPathPiece
+instance RenderRoute site => ToJSON (Route site) where
+  toJSON = String . routeToPathPiece
+
+instance ParseRoute site => FromJSONKey (Route site) where
+  fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Coulde not parse route") return . routeFromPathPiece
+
+instance RenderRoute site => ToJSONKey (Route site) where
+  toJSONKey = toJSONKeyText routeToPathPiece
+
+instance (RenderRoute site, ParseRoute site) => Binary (Route site) where
+  put = Binary.put . toPathPiece
+  get = Binary.get >>= maybe (fail "Could not parse route") return . fromPathPiece
 
 
 instance Monad FormResult where
@@ -77,3 +98,5 @@ instance Extend FormResult where
   duplicated (FormSuccess x)    = FormSuccess $ FormSuccess x
   duplicated  FormMissing       = FormMissing
   duplicated (FormFailure errs) = FormFailure errs
+
+
diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs
index e296d0c52..5402ce3ba 100644
--- a/src/Yesod/Core/Types/Instances.hs
+++ b/src/Yesod/Core/Types/Instances.hs
@@ -1,16 +1,48 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
 
 module Yesod.Core.Types.Instances
-  (
+  ( CachedMemoT(..)
   ) where
 
-import ClassyPrelude
+import ClassyPrelude.Yesod
 import Yesod.Core.Types
 
 import Control.Monad.Fix
 
+import Control.Monad.Memo
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+import Control.Monad.Logger (MonadLoggerIO)
+  
+
 instance MonadFix m => MonadFix (HandlerT site m) where
   mfix f = HandlerT $ \r -> mfix $ \a -> unHandlerT (f a) r
   
 instance MonadFix m => MonadFix (WidgetT site m) where
   mfix f = WidgetT $ \r -> mfix $ \ ~(a, _) -> unWidgetT (f a) r
+
+
+-- | Type-level tags for compatability of Yesod `cached`-System with `MonadMemo`
+newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT :: 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 MonadTrans (CachedMemoT k v) where
+  lift = CachedMemoT
+
+
+-- | 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
diff --git a/start.sh b/start.sh
index b72d043c2..cdad4b731 100755
--- a/start.sh
+++ b/start.sh
@@ -1,12 +1,11 @@
 #!/usr/bin/env bash
 
 unset HOST
-export DETAILED_LOGGING=true
-export LOG_ALL=false
-export LOGLEVEL=info
-export DUMMY_LOGIN=true
-export ALLOW_DEPRECATED=true
-export PWFILE=users.yml
+export DETAILED_LOGGING=${DETAILED_LOGGIN:-true}
+export LOG_ALL=${LOG_ALL:-false}
+export LOGLEVEL=${LOGLEVEL:-info}
+export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
+export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
 
 move-back() {
     mv -v .stack-work .stack-work-run

From 680b674b09c474db22dae9135ddaf60435a5a302 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Thu, 4 Apr 2019 19:33:39 +0200
Subject: [PATCH 02/13] Solidify design of BearerToken

---
 config/settings.yml               |   1 +
 package.yaml                      |   2 +
 src/Application.hs                |  18 ++--
 src/Auth/LDAP.hs                  |   2 +-
 src/CryptoID.hs                   |   5 +
 src/Data/Aeson/Types/Instances.hs |  14 +++
 src/Data/NonNull/Instances.hs     |  20 ++++
 src/Foundation.hs                 |  45 +++++----
 src/Handler/Utils.hs              |   4 +-
 src/Handler/Utils/DateTime.hs     |   6 +-
 src/Import/NoFoundation.hs        |   4 +
 src/Jobs.hs                       |  17 ++--
 src/Jobs/Crontab.hs               |   2 +-
 src/Jobs/Handler/HelpRequest.hs   |   2 +-
 src/Jose/Jwt/Instances.hs         |  18 ++++
 src/Model/Migration/Types.hs      |   1 -
 src/Model/Token.hs                | 158 ++++++++++++++++++++++++++++++
 src/Model/Types.hs                |  43 +++++++-
 src/Model/Types/JSON.hs           |  23 ++++-
 src/Settings.hs                   |   4 +
 src/Settings/Cluster.hs           |  14 +++
 src/Utils/Lens.hs                 |   8 ++
 22 files changed, 363 insertions(+), 48 deletions(-)
 create mode 100644 src/Data/Aeson/Types/Instances.hs
 create mode 100644 src/Data/NonNull/Instances.hs
 create mode 100644 src/Jose/Jwt/Instances.hs
 create mode 100644 src/Model/Token.hs

diff --git a/config/settings.yml b/config/settings.yml
index 3211d42db..9479d002a 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -27,6 +27,7 @@ notification-rate-limit: 3600
 notification-collate-delay: 300
 notification-expiration: 259201
 session-timeout: 7200
+jwt-expiration: 604800
 maximum-content-length: 52428800
 
 log-settings:
diff --git a/package.yaml b/package.yaml
index 339ecff3e..c856a6e95 100644
--- a/package.yaml
+++ b/package.yaml
@@ -117,6 +117,8 @@ dependencies:
   - lattices
   - hsass
   - semigroupoids
+  - jose-jwt
+  - mono-traversable
 
 other-extensions:
   - GeneralizedNewtypeDeriving
diff --git a/src/Application.hs b/src/Application.hs
index 20824d216..5b130dd50 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -101,7 +101,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
 -- the place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
 makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX
-makeFoundation appSettings@AppSettings{..} = do
+makeFoundation appSettings'@AppSettings{..} = do
     -- Some basic initializations: HTTP connection manager, logger, and static
     -- subsite.
     appHttpManager <- newManager
@@ -141,7 +141,7 @@ makeFoundation appSettings@AppSettings{..} = do
     -- logging function. To get out of this loop, we initially create a
     -- temporary foundation without a real connection pool, get a log function
     -- from there, and then create the real foundation.
-    let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..}
+    let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet = UniWorX {..}
         -- The UniWorX {..} syntax is an example of record wild cards. For more
         -- information, see:
         -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
@@ -153,13 +153,14 @@ makeFoundation appSettings@AppSettings{..} = do
           (error "sessionKey forced in tempFoundation")
           (error "secretBoxKey forced in tempFoundation")
           (error "widgetMemcached forced in tempFoundation")
+          (error "JSONWebKeySet forced in tempFoundation")
         logFunc loc src lvl str = do
           f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger)
           f loc src lvl str
 
     flip runLoggingT logFunc $ do
       $logDebugS "InstanceID" $ UUID.toText appInstanceID
-      -- logDebugS "Configuration" $ tshow appSettings
+      -- logDebugS "Configuration" $ tshow appSettings'
 
       smtpPool <- traverse createSmtpPool appSmtpConf
 
@@ -177,8 +178,9 @@ makeFoundation appSettings@AppSettings{..} = do
       appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
       appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
       appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
+      appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool
 
-      let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached
+      let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet
 
       handleJobs foundation
 
@@ -265,7 +267,7 @@ makeLogWare app = do
       logger <- readTVarIO . snd $ appLogger app
       logWare <- mkRequestLogger def
         { outputFormat = bool
-            (Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app)
+            (Apache . bool FromSocket FromHeader $ app ^. _appIpFromHeader)
             (Detailed True)
             logDetailed
         , destination = Logger $ loggerSet logger
@@ -287,8 +289,8 @@ makeLogWare app = do
 -- | Warp settings for the given foundation value.
 warpSettings :: UniWorX -> Settings
 warpSettings foundation = defaultSettings
-    & setPort (appPort $ appSettings foundation)
-    & setHost (appHost $ appSettings foundation)
+    & setPort (foundation ^. _appPort)
+    & setHost (foundation ^. _appHost)
     & setOnException (\_req e ->
         when (defaultShouldDisplayException e) $ do
           logger <- readTVarIO . snd $ appLogger foundation
@@ -384,6 +386,6 @@ addPWEntry :: User
            -> Text {-^ Password -}
            -> IO ()
 addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db $ do
-  PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings
+  PWHashConf{..} <- getsYesod $ view _appAuthPWHash
   (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
   void $ insert User{..}
diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs
index 5233faaf3..d65c1ee9b 100644
--- a/src/Auth/LDAP.hs
+++ b/src/Auth/LDAP.hs
@@ -159,7 +159,7 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
                   ]
 
 -- ldapConfig :: UniWorX -> LDAPConfig
--- ldapConfig _app@(appSettings -> settings) = LDAPConfig
+-- ldapConfig _app@(appSettings' -> settings) = LDAPConfig
 --   { usernameFilter = \u -> principalName <> "=" <> u
 --   , identifierModifier
 --   , ldapUri = appLDAPURI settings
diff --git a/src/CryptoID.hs b/src/CryptoID.hs
index 899047c3b..22266fc3a 100644
--- a/src/CryptoID.hs
+++ b/src/CryptoID.hs
@@ -29,6 +29,11 @@ import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..), FromJSON(..
 import Data.Aeson.Encoding (text)
 
 
+instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where
+  type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey
+  cryptoIDKey f = ask >>= f
+
+
 -- Generates CryptoUUID... and CryptoFileName... Datatypes
 decCryptoIDs [ ''SubmissionId
              , ''FileId
diff --git a/src/Data/Aeson/Types/Instances.hs b/src/Data/Aeson/Types/Instances.hs
new file mode 100644
index 000000000..f785576f2
--- /dev/null
+++ b/src/Data/Aeson/Types/Instances.hs
@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Aeson.Types.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Aeson.Types (Parser)
+import Control.Monad.Catch
+
+
+instance MonadThrow Parser where
+  throwM = fail . show
diff --git a/src/Data/NonNull/Instances.hs b/src/Data/NonNull/Instances.hs
new file mode 100644
index 000000000..1a11a66d9
--- /dev/null
+++ b/src/Data/NonNull/Instances.hs
@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.NonNull.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Aeson
+
+
+instance ToJSON a => ToJSON (NonNull a) where
+  toJSON = toJSON . toNullable
+
+instance (FromJSON a, MonoFoldable a) => FromJSON (NonNull a) where
+  parseJSON = parseJSON >=> maybe (fail "Expected non-empty structure") return . fromNullable
+
+
+instance Hashable a => Hashable (NonNull a) where
+  hashWithSalt s = hashWithSalt s . toNullable
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 0aca60110..09755de7d 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -77,6 +77,7 @@ import qualified Yesod.Auth.Message as Auth
 import qualified Data.Conduit.List as C
 
 import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import qualified Jose.Jwk as Jose
 
 import qualified Database.Memcached.Binary.IO as Memcached
 import Data.Bits (Bits(zeroBits))
@@ -96,6 +97,8 @@ instance DisplayAble TermId where
 instance DisplayAble SchoolId where
   display = CI.original . unSchoolKey
 
+type SMTPPool = Pool SMTPConnection
+
 -- infixl 9 :$:
 -- pattern a :$: b = a b
 
@@ -104,7 +107,7 @@ instance DisplayAble SchoolId where
 -- starts running, such as database connections. Every handler will have
 -- access to the data present here.
 data UniWorX = UniWorX
-    { appSettings        :: AppSettings
+    { appSettings'       :: AppSettings
     , appStatic          :: EmbeddedStatic -- ^ Settings for static file serving.
     , appConnPool        :: ConnectionPool -- ^ Database connection pool.
     , appSmtpPool        :: Maybe SMTPPool
@@ -119,9 +122,16 @@ data UniWorX = UniWorX
     , appCronThread      :: TMVar (ReleaseKey, ThreadId)
     , appSessionKey      :: ClientSession.Key
     , appSecretBoxKey    :: SecretBox.Key
+    , appJSONWebKeySet   :: Jose.JwkSet
     }
 
-type SMTPPool = Pool SMTPConnection
+makeLenses_ ''UniWorX
+instance HasInstanceID UniWorX InstanceId where
+  instanceID = _appInstanceID
+instance HasJSONWebKeySet UniWorX Jose.JwkSet where
+  jsonWebKeySet = _appJSONWebKeySet
+instance HasAppSettings UniWorX where
+  appSettings = _appSettings'
 
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
@@ -463,7 +473,7 @@ tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
 tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do
   $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
   addMessageI Error MsgDeprecatedRoute
-  allow <- appAllowDeprecated . appSettings <$> getYesod
+  allow <- view _appAllowDeprecated
   return $ bool (Unauthorized "Deprecated Route") Authorized allow
 tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
   $logWarnS "AccessControl" ("route in development: " <> tshow r)
@@ -809,17 +819,17 @@ instance Yesod UniWorX where
     -- Controls the base of generated URLs. For more information on modifying,
     -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
     approot = ApprootRequest $ \app req ->
-        case appRoot $ appSettings app of
+        case app ^. _appRoot of
             Nothing -> getApprootText guessApproot app req
             Just root -> root
 
     -- Store session data on the client in encrypted cookies,
     -- default session idle timeout is 120 minutes
-    makeSessionBackend UniWorX{appSessionKey,appSettings=AppSettings{appSessionTimeout}} = do
-      (getCachedDate, _) <- clientSessionDateCacher appSessionTimeout
-      return . Just $ clientSessionBackend appSessionKey getCachedDate
+    makeSessionBackend app = do
+      (getCachedDate, _) <- clientSessionDateCacher (app ^. _appSessionTimeout)
+      return . Just $ clientSessionBackend (app ^. _appSessionKey) getCachedDate
 
-    maximumContentLength UniWorX{appSettings=AppSettings{appMaximumContentLength}} _ = appMaximumContentLength
+    maximumContentLength app _ = app ^. _appMaximumContentLength
 
     -- Yesod Middleware allows you to run code before and after each handler function.
     -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
@@ -878,7 +888,7 @@ instance Yesod UniWorX where
         encrypted :: ToJSON a => a -> Widget -> Widget
         encrypted plaintextJson plaintext = do
           canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
-          shouldEncrypt <- getsYesod $ appEncryptErrors . appSettings
+          shouldEncrypt <- view _appEncryptErrors
           if
             | shouldEncrypt
             , not canDecrypt -> do
@@ -919,8 +929,8 @@ instance Yesod UniWorX where
     isAuthorized = evalAccess
 
     addStaticContent ext _mime content = do
-      UniWorX{appWidgetMemcached, appSettings} <- getYesod
-      for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
+      UniWorX{appWidgetMemcached, appSettings'} <- getYesod
+      for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
         let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
             touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
             add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
@@ -971,8 +981,7 @@ siteLayout = siteLayout' . Just
 siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading`
            -> Widget -> Handler Html
 siteLayout' headingOverride widget = do
-  master <- getYesod
-  let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master
+  AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- view appSettings
 
   isModal <- hasCustomHeader HeaderIsModal
 
@@ -2081,7 +2090,7 @@ instance YesodAuth UniWorX where
             _other -> return res
 
       $logDebugS "auth" $ tshow Creds{..}
-      UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
+      UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
 
       flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of
         Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do
@@ -2200,7 +2209,7 @@ instance YesodAuth UniWorX where
       where
         insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
 
-    authPlugins (UniWorX{ appSettings = AppSettings{..}, appLdapPool }) = catMaybes
+    authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
       [ campusLogin <$> appLdapConf <*> appLdapPool
       , Just . hashLogin $ pwHashAlgorithm appAuthPWHash
       , dummyLogin <$ guard appAuthDummyLogin
@@ -2225,9 +2234,9 @@ unsafeHandler f h = do
 
 
 instance YesodMail UniWorX where
-  defaultFromAddress = getsYesod $ appMailFrom . appSettings
-  mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings
-  mailVerp = getsYesod $ appMailVerp . appSettings
+  defaultFromAddress = getsYesod $ view _appMailFrom
+  mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
+  mailVerp = getsYesod $ view _appMailVerp
   mailDateTZ = return appTZ
   mailSmtp act = do
     pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs
index 46abeddd5..6e250cfd9 100644
--- a/src/Handler/Utils.hs
+++ b/src/Handler/Utils.hs
@@ -4,6 +4,8 @@ module Handler.Utils
 
 import Import
 
+import Utils.Lens
+
 import qualified Data.Text as T
 -- import qualified Data.Set (Set)
 import qualified Data.Set as Set
@@ -40,7 +42,7 @@ downloadFiles = do
   case mauth of
     Just (Entity _ User{..}) -> return userDownloadFiles
     Nothing -> do
-      AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
+      UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
       return userDefaultDownloadFiles
 
 tidFromText :: Text -> Maybe TermId
diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs
index de2b0705a..15ecfc780 100644
--- a/src/Handler/Utils/DateTime.hs
+++ b/src/Handler/Utils/DateTime.hs
@@ -13,6 +13,8 @@ module Handler.Utils.DateTime
 
 import Import
 
+import Utils.Lens
+
 import Data.Time.Zones
 import qualified Data.Time.Zones as TZ
 
@@ -83,7 +85,7 @@ getTimeLocale = getTimeLocale' <$> languages
 getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat
 getDateTimeFormat sel = do
   mauth <- liftHandlerT maybeAuth
-  AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
+  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
   let
     fmt
       | Just (Entity _ User{..}) <- mauth
@@ -182,4 +184,4 @@ weeksToAdd old new = loop 0 old
   where
     loop n t
       | t > new   = n
-      | otherwise = loop (succ n) (addOneWeek t)
\ No newline at end of file
+      | otherwise = loop (succ n) (addOneWeek t)
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index 21e0b5de5..fd37d73bc 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -43,6 +43,7 @@ import GHC.Exts               as Import (IsList)
 import Data.Hashable          as Import
 import Data.List.NonEmpty     as Import (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(..))
@@ -56,6 +57,7 @@ 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
 
@@ -67,6 +69,8 @@ import Numeric.Natural.Instances as Import ()
 import System.Random as Import (Random)
 import Control.Monad.Random.Class as Import (MonadRandom(..))
 
+import Jose.Jwt.Instances as Import ()
+
 
 import Control.Monad.Trans.RWS (RWST)
 
diff --git a/src/Jobs.hs b/src/Jobs.hs
index 2a9a42556..04df2686c 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -6,6 +6,7 @@ module Jobs
   ) where
 
 import Import
+import Utils.Lens
 
 import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
 import Jobs.Types (JobCtl(JobCtlQueue))
@@ -77,7 +78,7 @@ handleJobs :: ( MonadResource m
 -- Uses `unsafeHandler`, as per documentation all HTTP-related fields of state/environment are meaningless placeholders.
 -- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ...
 handleJobs foundation@UniWorX{..} = do
-  let num = appJobWorkers appSettings
+  let num = foundation ^. _appJobWorkers
 
   jobCrontab <- liftIO $ newTMVarIO HashMap.empty
   jobConfirm <- liftIO $ newTVarIO HashMap.empty
@@ -135,7 +136,7 @@ execCrontab = evalStateT go HashMap.empty
         runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
 
       refT <- liftIO getCurrentTime
-      settings <- getsYesod appSettings
+      settings <- getsYesod appSettings'
       currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
         crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
         case crontab' of
@@ -157,7 +158,7 @@ execCrontab = evalStateT go HashMap.empty
                     | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
                       -> do
                         now <- liftIO $ getCurrentTime
-                        instanceID <- getsYesod appInstanceID
+                        instanceID' <- getsYesod appInstanceID
                         State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
                         case jobCtl of
                           JobCtlQueue job -> do
@@ -166,7 +167,7 @@ execCrontab = evalStateT go HashMap.empty
                               CronLastExec
                                 { cronLastExecJob = toJSON job
                                 , cronLastExecTime = now
-                                , cronLastExecInstance = instanceID
+                                , cronLastExecInstance = instanceID'
                                 }
                               [ CronLastExecTime =. now ]
                             lift . lift $ queueDBJob job
@@ -285,21 +286,21 @@ jLocked jId act = do
   let
     lock = runDB . setSerializable $ do
       qj@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId
-      instanceID <- getsYesod appInstanceID
-      threshold <- getsYesod $ appJobStaleThreshold . appSettings
+      instanceID' <- getsYesod $ view instanceID
+      threshold <- getsYesod $ view _appJobStaleThreshold
       now <- liftIO getCurrentTime
       hadStale <- maybeT (return False) $ do
         lockTime <- MaybeT $ return queuedJobLockTime
         lockInstance <- MaybeT $ return queuedJobLockInstance
         if
-          | lockInstance == instanceID
+          | lockInstance == instanceID'
           , diffUTCTime now lockTime >= threshold
             -> return True
           | otherwise
             -> throwM $ JLocked jId lockInstance lockTime
       when hadStale .
         $logWarnS "Jobs" $ "Ignored stale lock: " <> tshow qj
-      val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID
+      val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID'
                            , QueuedJobLockTime =. Just now
                            ]
       liftIO . atomically $ writeTVar hasLock True
diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs
index 41b3441c6..af83ef1c5 100644
--- a/src/Jobs/Crontab.hs
+++ b/src/Jobs/Crontab.hs
@@ -23,7 +23,7 @@ import qualified Data.Conduit.List as C
 determineCrontab :: DB (Crontab JobCtl)
 -- ^ Extract all future jobs from the database (sheet deadlines, ...)
 determineCrontab = execWriterT $ do
-  AppSettings{..} <- getsYesod appSettings
+  AppSettings{..} <- getsYesod appSettings'
 
   case appJobFlushInterval of
     Just interval -> tell $ HashMap.singleton
diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs
index 1ec904e2b..5623be772 100644
--- a/src/Jobs/Handler/HelpRequest.hs
+++ b/src/Jobs/Handler/HelpRequest.hs
@@ -20,7 +20,7 @@ dispatchJobHelpRequest :: Either (Maybe Address) UserId
                        -> Maybe Text -- ^ Referer
                        -> Handler ()
 dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do
-  supportAddress <- getsYesod $ appMailSupport . appSettings
+  supportAddress <- view _appMailSupport
   userInfo <- bitraverse return (runDB . getEntity) jSender
   let userAddress = either
         id
diff --git a/src/Jose/Jwt/Instances.hs b/src/Jose/Jwt/Instances.hs
new file mode 100644
index 000000000..f7607168c
--- /dev/null
+++ b/src/Jose/Jwt/Instances.hs
@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Jose.Jwt.Instances
+  (
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Jose.Jwt
+
+
+instance PathPiece Jwt where
+  toPathPiece (Jwt bytes) = decodeUtf8 bytes
+  fromPathPiece = Just . Jwt . encodeUtf8
+
+deriving instance Typeable JwtError
+
+instance Exception JwtError
diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs
index 0aed744b0..5ec81cd81 100644
--- a/src/Model/Migration/Types.hs
+++ b/src/Model/Migration/Types.hs
@@ -2,7 +2,6 @@ module Model.Migration.Types where
 
 import ClassyPrelude.Yesod
 import Data.Aeson.TH (deriveJSON, defaultOptions)
-import Database.Persist.Sql
 
 import qualified Model as Current
 import qualified Model.Types.JSON as Current
diff --git a/src/Model/Token.hs b/src/Model/Token.hs
new file mode 100644
index 000000000..a57b5244b
--- /dev/null
+++ b/src/Model/Token.hs
@@ -0,0 +1,158 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Model.Token
+  ( BearerToken(..)
+  , bearerToken
+  , encodeToken, decodeToken
+  , tokenToJSON, tokenParseJSON
+  ) where
+
+import ClassyPrelude.Yesod
+import Model
+import Settings
+import Utils.Lens hiding ((.=))
+
+import Yesod.Auth (AuthId)
+
+-- import qualified Jose.Jwa as Jose
+import Jose.Jwk (JwkSet)
+-- import qualified Jose.Jwk as Jose
+import Jose.Jwt (Jwt, JwtError, IntDate(..))
+import qualified Jose.Jwt as Jose
+
+import Jose.Jwt.Instances ()
+import Data.Aeson.Types.Instances ()
+
+import qualified Crypto.Random as Crypto (MonadRandom)
+
+import Data.HashSet (HashSet)
+
+import qualified Data.HashMap.Strict as HashMap
+
+import Data.Aeson.Types (Parser, (.:?), (.:))
+import qualified Data.Aeson as JSON
+import qualified Data.Aeson.Types as JSON
+
+import CryptoID
+
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
+
+import Control.Monad.Random (MonadRandom(..))
+
+
+data BearerToken site = BearerToken
+  { tokenIdentifier :: TokenId
+  , tokenAuthority  :: AuthId site
+  , tokenRoutes     :: Maybe (HashSet (Route site))
+  , tokenAddAuth    :: AuthCNF
+  , tokenIssuedAt   :: UTCTime
+  , tokenIssuedBy   :: InstanceId
+  , tokenExpiresAt
+  , tokenStartsAt   :: Maybe UTCTime
+  } deriving (Generic, Typeable)
+
+deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
+deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site)) => Read (BearerToken site)
+deriving instance (Show (AuthId site), Show (Route site)) => Show (BearerToken site)
+
+tokenToJSON :: forall m.
+               ( MonadHandler m
+               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               , RenderRoute (HandlerSite m)
+               ) => BearerToken (HandlerSite m) -> m Value
+tokenToJSON BearerToken{..} = do
+  cID <- encrypt tokenAuthority :: m (CryptoUUID (AuthId (HandlerSite m)))
+  let stdPayload = Jose.JwtClaims
+        { jwtIss = Just $ toPathPiece tokenIssuedBy
+        , jwtSub = Nothing
+        , jwtAud = Nothing
+        , jwtExp = IntDate . utcTimeToPOSIXSeconds <$> tokenExpiresAt
+        , jwtNbf = IntDate . utcTimeToPOSIXSeconds <$> tokenStartsAt
+        , jwtIat = Just . IntDate $ utcTimeToPOSIXSeconds tokenIssuedAt
+        , jwtJti = Just $ toPathPiece tokenIdentifier
+        }
+  return . JSON.object $
+    [ "authority" .= cID
+    , "routes"    .= tokenRoutes
+    , "add-auth"  .= tokenAddAuth
+    ] ++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
+
+tokenParseJSON :: forall site.
+                  ( HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
+                  , ParseRoute site
+                  , Hashable (Route site)
+                  )
+               => Value
+               -> ReaderT CryptoIDKey Parser (BearerToken site)
+tokenParseJSON v@(Object o) = do
+  tokenAuthority' <- lift (o .: "authority") :: ReaderT CryptoIDKey Parser (CryptoUUID (AuthId site))
+  tokenAuthority <- decrypt tokenAuthority'
+
+  tokenRoutes    <- lift $ o .:? "routes"
+  tokenAddAuth   <- lift $ o .:  "add-auth"
+  Jose.JwtClaims{..} <- lift $ parseJSON v
+
+  let unIntDate (IntDate posix) = posixSecondsToUTCTime posix
+
+  Just tokenIssuedBy <- return $ jwtIss >>= fromPathPiece
+  Just tokenIdentifier <- return $ jwtJti >>= fromPathPiece
+  Just tokenIssuedAt <- return $ unIntDate <$> jwtIat
+  let tokenExpiresAt = unIntDate <$> jwtExp
+      tokenStartsAt = unIntDate <$> jwtNbf
+
+  return BearerToken{..}
+tokenParseJSON v = lift $ JSON.typeMismatch "BearerToken" v
+
+
+bearerToken :: forall m.
+               ( MonadHandler m
+               , HasInstanceID (HandlerSite m) InstanceId
+               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               , HasAppSettings (HandlerSite m)
+               )
+            => AuthId (HandlerSite m)
+            -> Maybe (HashSet (Route (HandlerSite m)))
+            -> AuthCNF
+            -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
+            -> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
+            -> m (BearerToken (HandlerSite m))
+bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do
+  tokenIdentifier <- liftIO $ getRandom
+  tokenIssuedAt <- liftIO $ getCurrentTime
+  tokenIssuedBy <- getsYesod $ view instanceID
+
+  defaultExpiration <- getsYesod $ view _appJWTExpiration
+  
+  let tokenExpiresAt
+        | Just t <- mTokenExpiresAt
+        = t
+        | Just tDiff <- defaultExpiration
+        = Just $ tDiff `addUTCTime` fromMaybe tokenIssuedAt tokenStartsAt
+        | otherwise
+        = Nothing
+
+  return BearerToken{..}
+
+
+encodeToken :: forall m.
+               ( Crypto.MonadRandom m
+               , MonadHandler m
+               , HasJSONWebKeySet (HandlerSite m) JwkSet
+               , HasInstanceID (HandlerSite m) InstanceId
+               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               , RenderRoute (HandlerSite m)
+               )
+            => BearerToken (HandlerSite m) -> m Jwt
+encodeToken token = do
+  _payload <- tokenToJSON token
+  error "Not implemented"
+
+decodeToken :: forall m.
+               ( Crypto.MonadRandom m
+               , MonadHandler m
+               , HasJSONWebKeySet (HandlerSite m) JwkSet
+               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               )
+            => Jwt -> m (Either JwtError (BearerToken (HandlerSite m)))
+decodeToken = error "Not implemented"
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 7cf317d0c..5c292d146 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -27,6 +27,8 @@ import Data.Universe.Helpers
 import Data.UUID.Types (UUID)
 import qualified Data.UUID.Types as UUID
 
+import Data.NonNull.Instances ()
+
 import Data.Default
 
 import Text.Read (readMaybe)
@@ -54,7 +56,7 @@ import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
 import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value())
 import Data.Aeson.Types (toJSONKeyText)
-import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
+import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON)
 
 import GHC.Generics (Generic)
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
@@ -79,7 +81,7 @@ import Model.Types.Wordlist
 import Data.Text.Metrics (damerauLevenshtein)
 
 import Data.Binary (Binary)
-
+  
 
 instance PathPiece UUID where
   fromPathPiece = UUID.fromString . unpack
@@ -731,7 +733,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthDeprecated
   | AuthDevelopment
   | AuthFree
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 instance Universe AuthTag
 instance Finite AuthTag
@@ -774,6 +776,40 @@ instance FromJSON AuthTagActive where
 derivePersistFieldJSON ''AuthTagActive
 
 
+data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Hashable a => Hashable (PredLiteral a)
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , sumEncoding = ObjectWithSingleField
+  , unwrapUnaryRecords = True
+  } ''PredLiteral
+
+
+newtype PredCNF a = PredCNF (Set (NonNull (Set (PredLiteral a))))
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving newtype (Semigroup, Monoid)
+
+newtype PredDNF a = PredDNF (Set (NonNull (Set (PredLiteral a))))
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving newtype (Semigroup, Monoid)
+
+$(return [])
+
+instance (Ord a, ToJSON a) => ToJSON (PredCNF a) where
+  toJSON = $(mkToJSON predNFAesonOptions ''PredCNF)
+instance (Ord a, FromJSON a) => FromJSON (PredCNF a) where
+  parseJSON = $(mkParseJSON predNFAesonOptions ''PredCNF)
+ 
+instance (Ord a, ToJSON a) => ToJSON (PredDNF a) where
+  toJSON = $(mkToJSON predNFAesonOptions ''PredDNF)
+instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
+  parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
+
+type AuthCNF = PredCNF AuthTag
+type AuthDNF = PredDNF AuthTag
+
 
 data LecturerType = CourseLecturer | CourseAssistant
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
@@ -801,4 +837,5 @@ type UserEmail       = CI Email
 
 type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
 type InstanceId      = UUID
+type TokenId         = UUID
 type TermCandidateIncidence = UUID
diff --git a/src/Model/Types/JSON.hs b/src/Model/Types/JSON.hs
index e69f8f1b2..66ed78163 100644
--- a/src/Model/Types/JSON.hs
+++ b/src/Model/Types/JSON.hs
@@ -1,5 +1,6 @@
 module Model.Types.JSON
   ( derivePersistFieldJSON
+  , predNFAesonOptions
   ) where
 
 import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
@@ -9,11 +10,13 @@ import Database.Persist.Sql
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text.Encoding as Text
 
-import qualified Data.Aeson as JSON
+import Data.Aeson as JSON
 
 import Language.Haskell.TH
 import Language.Haskell.TH.Datatype
 
+import Utils.PathPiece
+
 
 derivePersistFieldJSON :: Name -> DecsQ
 derivePersistFieldJSON tName = do
@@ -28,10 +31,10 @@ derivePersistFieldJSON tName = do
         | otherwise = cxt [[t|PersistField|] `appT` t]
   sequence
     [ instanceD iCxt ([t|PersistField|] `appT` t)
-      [ funD (mkName "toPersistValue")
+      [ funD 'toPersistValue
         [ clause [] (normalB [e|PersistDbSpecific . LBS.toStrict . JSON.encode|]) []
         ]
-      , funD (mkName "fromPersistValue")
+      , funD 'fromPersistValue
         [ do
             bs <- newName "bs"
             clause [[p|PersistDbSpecific $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) []
@@ -45,8 +48,20 @@ derivePersistFieldJSON tName = do
         ]
       ]
     , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
-      [ funD (mkName "sqlType")
+      [ funD 'sqlType
         [ clause [wildP] (normalB [e|SqlOther "jsonb"|]) []
         ]
       ]
     ]
+
+
+predNFAesonOptions :: Options
+-- ^ Needed for JSON instances of `predCNF` and `predDNF`
+--
+-- Moved to this module due to stage restriction
+predNFAesonOptions = defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , sumEncoding = ObjectWithSingleField
+  , tagSingleConstructors = True
+  }
+  
diff --git a/src/Settings.hs b/src/Settings.hs
index f717ee378..ae2ce4b30 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -100,6 +100,7 @@ data AppSettings = AppSettings
     , appNotificationExpiration :: NominalDiffTime
     , appSessionTimeout         :: NominalDiffTime
     , appMaximumContentLength   :: Maybe Word64
+    , appJWTExpiration          :: Maybe NominalDiffTime
 
     , appInitialLogSettings     :: LogSettings
 
@@ -352,6 +353,7 @@ instance FromJSON AppSettings where
         appNotificationRateLimit  <- o .:  "notification-rate-limit"
         appNotificationCollateDelay <- o .: "notification-collate-delay"
         appNotificationExpiration <- o .: "notification-expiration"
+        appJWTExpiration          <- o .:? "jwt-expiration"
 
         appSessionTimeout         <- o .: "session-timeout"
 
@@ -379,6 +381,8 @@ instance FromJSON AppSettings where
 
         return AppSettings {..}
 
+makeClassy_ ''AppSettings
+
 -- | Settings for 'widgetFile', such as which template languages to support and
 -- default Hamlet settings.
 --
diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs
index a6fb11799..872d901b7 100644
--- a/src/Settings/Cluster.hs
+++ b/src/Settings/Cluster.hs
@@ -32,11 +32,16 @@ import qualified Data.Binary as Binary
 import qualified Data.Serialize as Serialize
 import qualified Data.ByteString.Base64.URL as Base64
 
+import qualified Jose.Jwa as Jose
+import qualified Jose.Jwk as Jose
+import qualified Jose.Jwt as Jose
+
 
 data ClusterSettingsKey
   = ClusterCryptoIDKey
   | ClusterClientSessionKey
   | ClusterSecretBoxKey
+  | ClusterJSONWebKeySet
   deriving (Eq, Ord, Enum, Bounded, Show, Read)
 
 instance Universe ClusterSettingsKey
@@ -120,3 +125,12 @@ instance FromJSON SecretBox.Key where
   parseJSON = Aeson.withText "Key" $ \t -> do
     bytes <- either fail return . Base64.decode $ encodeUtf8 t
     maybe (fail "Could not parse key") return $ Saltine.decode bytes
+
+
+instance ClusterSetting 'ClusterJSONWebKeySet where
+  type ClusterSettingValue 'ClusterJSONWebKeySet = Jose.JwkSet
+  initClusterSetting _ = liftIO $ do
+    now <- getCurrentTime
+    jwkSig <- Jose.generateSymmetricKey 32 (Jose.UTCKeyId now) Jose.Sig (Just $ Jose.Signed Jose.HS256)
+    return $ Jose.JwkSet [jwkSig]
+  knownClusterSetting _ = ClusterJSONWebKeySet
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 0abc9a8ee..b6a09e3c3 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -93,4 +93,12 @@ makeLenses_ ''StudyTermCandidate
 
 -- makeClassy_ ''Load
 
+--------------------------
+-- Fields for `UniWorX` --
+--------------------------
 
+class HasInstanceID s a | s -> a where
+  instanceID :: Lens' s a
+  
+class HasJSONWebKeySet s a | s -> a where
+  jsonWebKeySet :: Lens' s a

From cc8823c7cabc4cdee6c920f413ff08c995918063 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Fri, 5 Apr 2019 00:05:56 +0200
Subject: [PATCH 03/13] Prototype of !token

---
 haddock.sh                  |  13 ++++-
 messages/uniworx/de.msg     |   5 ++
 src/Foundation.hs           |  87 +++++++++++++++++++++----------
 src/Jose/Jwt/Instances.hs   |   1 +
 src/Model/Token.hs          | 101 ++++++++++++++++++++++++++----------
 src/Model/Types.hs          |  20 +++----
 src/Utils.hs                |   6 +++
 src/Utils/Parameters.hs     |   3 +-
 src/Yesod/Core/Instances.hs |   3 ++
 test/Database.hs            |   4 +-
 10 files changed, 176 insertions(+), 67 deletions(-)

diff --git a/haddock.sh b/haddock.sh
index aaceeb329..7414e60e8 100755
--- a/haddock.sh
+++ b/haddock.sh
@@ -1,3 +1,14 @@
 #!/usr/bin/env bash
 
-exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal
+move-back() {
+    mv -v .stack-work .stack-work-doc
+    [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
+}
+
+if [[ -d .stack-work-doc ]]; then
+    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
+    mv -v .stack-work-doc .stack-work
+    trap move-back EXIT
+fi
+
+stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal
diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index da8e563fa..3172caf4e 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -203,6 +203,10 @@ CorrectorAssignTitle: Korrektor zuweisen
 Unauthorized: Sie haben hierfür keine explizite Berechtigung.
 UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
 UnauthorizedOr  l@Text r@Text: (#{l} ODER #{r})
+UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. 
+UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen.
+UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.
+UnauthorizedTokenInvalidRoute: Ihr Authorisierungs-Token ist auf dieser Unterseite nicht gültig.
 UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
 UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
 UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
@@ -698,6 +702,7 @@ AuthPredsActive: Aktive Authorisierungsprädikate
 AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
 AuthTagFree: Seite ist universell zugänglich
 AuthTagAdmin: Nutzer ist Administrator
+AuthTagToken: Nutzer präsentiert Authorisierungs-Token
 AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet
 AuthTagDeprecated: Seite ist nicht überholt
 AuthTagDevelopment: Seite ist nicht in Entwicklung
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 09755de7d..9634fda67 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -15,6 +15,7 @@ import Auth.LDAP
 import Auth.PWHash
 import Auth.Dummy
 import Jobs.Types
+import Model.Token
 
 import qualified Network.Wai as W (pathInfo)
 
@@ -43,6 +44,7 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Map (Map, (!?))
 import qualified Data.Map as Map
+import qualified Data.HashSet as HashSet
 
 import Data.List (nubBy)
 
@@ -396,6 +398,17 @@ appLanguagesOpts = do
 
 
 -- Access Control
+newtype InvalidAuthTag = InvalidAuthTag Text
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+instance Exception InvalidAuthTag
+
+data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+instance Universe SessionAuthTags
+instance Finite SessionAuthTags
+nullaryPathPiece ''SessionAuthTags (camelToPathPiece' 1)
+
+
 data AccessPredicate
   = APPure     (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
   | APHandler  (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Handler AuthResult)
@@ -460,6 +473,26 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
     adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
     guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
     return Authorized
+tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ do
+  jwt <- maybeTMExceptT (unauthorizedI MsgUnauthorizedNoToken) $ asum
+    [ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
+    , MaybeT $ lookupGlobalPostParam PostToken
+    , MaybeT $ lookupGlobalGetParam GetToken
+    ]
+  BearerToken{..} <- catch (decodeToken jwt) $ \case
+    BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
+    BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
+    other -> throwM other
+  unless (maybe True (HashSet.member route) tokenRoutes) $
+    throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidRoute
+  authorityVal <- evalAccessFor (Just tokenAuthority) route isWrite
+  unless (is _Authorized authorityVal) $
+    throwError authorityVal
+  whenIsJust tokenAddAuth $ \addDNF -> do
+    additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) addDNF mAuthId route isWrite
+    unless (is _Authorized additionalVal) $
+      throwError additionalVal
+  return Authorized
 tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
   AdminHijackUserR cID -> exceptT return return $ do
     myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
@@ -714,27 +747,21 @@ tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorize
 tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
 
 
-newtype InvalidAuthTag = InvalidAuthTag Text
-  deriving (Eq, Ord, Show, Read, Generic, Typeable)
-instance Exception InvalidAuthTag
+defaultAuthDNF :: AuthDNF
+defaultAuthDNF = PredDNF $ Set.fromList
+  [ impureNonNull . Set.singleton $ PLVariable AuthAdmin
+  , impureNonNull . Set.singleton $ PLVariable AuthToken
+  ]
 
-type DNF a = Set (NonNull (Set a))
-
-data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-instance Universe SessionAuthTags
-instance Finite SessionAuthTags
-nullaryPathPiece ''SessionAuthTags (camelToPathPiece' 1)
-
-routeAuthTags :: Route UniWorX -> Either InvalidAuthTag (NonNull (DNF AuthTag))
+routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF
 -- ^ DNF up to entailment:
 --
 -- > (A_1 && A_2 && ...) OR' B OR' ...
 --
 -- > A OR' B := ((A |- B) ==> A) && (A || B)
-routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.singleton $ Set.singleton AuthAdmin) . routeAttrs
+routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs
   where
-    partition' :: Set (Set AuthTag) -> Text -> Either InvalidAuthTag (Set (Set AuthTag))
+    partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral))
     partition' prev t
       | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t)
         = if
@@ -745,9 +772,9 @@ routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM p
       | otherwise
         = Left $ InvalidAuthTag t
 
-evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
+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 . toNullable -> authDNF) mAuthId route isWrite
+evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF) mAuthId route isWrite
   = do
       mr <- getMsgRenderer
       let
@@ -760,23 +787,31 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toN
               $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
               evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite'
 
+        evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
+        evalAuthLiteral PLVariable{..} = evalAuthTag plVar
+        evalAuthLiteral PLNegated{..} = evalAuthTag plVar >>= \case
+          Unauthorized _         -> return Authorized
+          AuthenticationRequired -> return AuthenticationRequired
+          Authorized             -> unauthorizedI plVar
+
         orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
         orAR' = shortCircuitM (is _Authorized) (orAR mr)
         andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
 
-        evalDNF :: [[AuthTag]] -> WriterT (Set AuthTag) m AuthResult
-        evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthTag aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
+        evalDNF :: [[AuthLiteral]] -> WriterT (Set AuthTag) m AuthResult
+        evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthLiteral aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
 
-      $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF
+      $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive . plVar) authDNF
 
-      result <- evalDNF $ filter (all authTagIsActive) authDNF
+      result <- evalDNF $ filter (all $ authTagIsActive . plVar) authDNF
 
-      unless (is _Authorized result) . forM_ (filter (any authTagIsInactive) authDNF) $ \conj ->
-        whenM (allM conj (\aTag -> (return . not $ authTagIsActive aTag) `or2M` (not . is _Unauthorized <$> evalAuthTag aTag))) $ do
-          let pivots = filter authTagIsInactive conj
-          whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do
-            $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|]
-            tell $ Set.fromList pivots
+      unless (is _Authorized result) . forM_ (filter (any $ authTagIsInactive . plVar) authDNF) $ \conj ->
+        whenM (allM conj (\aTag -> (return . not . authTagIsActive $ plVar aTag) `or2M` (not . is _Unauthorized <$> evalAuthLiteral aTag))) $ do
+          let pivots = filter (authTagIsInactive . plVar) conj
+          whenM (allM pivots $ fmap (is _Authorized) . evalAuthLiteral) $ do
+            let pivots' = plVar <$> pivots
+            $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots'}|]
+            tell $ Set.fromList pivots'
 
       return result
 
diff --git a/src/Jose/Jwt/Instances.hs b/src/Jose/Jwt/Instances.hs
index f7607168c..4bf4e3827 100644
--- a/src/Jose/Jwt/Instances.hs
+++ b/src/Jose/Jwt/Instances.hs
@@ -13,6 +13,7 @@ instance PathPiece Jwt where
   toPathPiece (Jwt bytes) = decodeUtf8 bytes
   fromPathPiece = Just . Jwt . encodeUtf8
 
+deriving instance Generic JwtError
 deriving instance Typeable JwtError
 
 instance Exception JwtError
diff --git a/src/Model/Token.hs b/src/Model/Token.hs
index a57b5244b..d9c3afe94 100644
--- a/src/Model/Token.hs
+++ b/src/Model/Token.hs
@@ -3,28 +3,26 @@
 module Model.Token
   ( BearerToken(..)
   , bearerToken
-  , encodeToken, decodeToken
-  , tokenToJSON, tokenParseJSON
+  , encodeToken, BearerTokenException(..), decodeToken
+  , tokenToJSON, tokenParseJSON, tokenParseJSON'
   ) where
 
 import ClassyPrelude.Yesod
 import Model
 import Settings
+import Utils (NTop(..))
 import Utils.Lens hiding ((.=))
 
 import Yesod.Auth (AuthId)
 
--- import qualified Jose.Jwa as Jose
-import Jose.Jwk (JwkSet)
--- import qualified Jose.Jwk as Jose
-import Jose.Jwt (Jwt, JwtError, IntDate(..))
+import qualified Jose.Jwa as Jose
+import Jose.Jwk (JwkSet(..))
+import Jose.Jwt (Jwt(..), IntDate(..))
 import qualified Jose.Jwt as Jose
 
 import Jose.Jwt.Instances ()
 import Data.Aeson.Types.Instances ()
 
-import qualified Crypto.Random as Crypto (MonadRandom)
-
 import Data.HashSet (HashSet)
 
 import qualified Data.HashMap.Strict as HashMap
@@ -32,6 +30,9 @@ import qualified Data.HashMap.Strict as HashMap
 import Data.Aeson.Types (Parser, (.:?), (.:))
 import qualified Data.Aeson as JSON
 import qualified Data.Aeson.Types as JSON
+import qualified Data.Aeson.Parser as JSON
+import qualified Data.Aeson.Parser.Internal as JSON (jsonEOF')
+import qualified Data.Aeson.Internal as JSON (iparse, formatError)
 
 import CryptoID
 
@@ -42,10 +43,10 @@ import Control.Monad.Random (MonadRandom(..))
 
 
 data BearerToken site = BearerToken
-  { tokenIdentifier :: TokenId
-  , tokenAuthority  :: AuthId site
-  , tokenRoutes     :: Maybe (HashSet (Route site))
-  , tokenAddAuth    :: AuthCNF
+  { tokenIdentifier :: TokenId -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
+  , tokenAuthority  :: AuthId site -- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
+  , tokenRoutes     :: Maybe (HashSet (Route site)) -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
+  , tokenAddAuth    :: Maybe AuthDNF -- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
   , tokenIssuedAt   :: UTCTime
   , tokenIssuedBy   :: InstanceId
   , tokenExpiresAt
@@ -73,10 +74,11 @@ tokenToJSON BearerToken{..} = do
         , jwtJti = Just $ toPathPiece tokenIdentifier
         }
   return . JSON.object $
-    [ "authority" .= cID
-    , "routes"    .= tokenRoutes
-    , "add-auth"  .= tokenAddAuth
-    ] ++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
+    catMaybes [ Just $ "authority" .= cID
+              , ("routes" .=) <$> tokenRoutes
+              , ("add-auth" .=) <$> tokenAddAuth
+              ]
+    ++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
 
 tokenParseJSON :: forall site.
                   ( HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
@@ -90,7 +92,7 @@ tokenParseJSON v@(Object o) = do
   tokenAuthority <- decrypt tokenAuthority'
 
   tokenRoutes    <- lift $ o .:? "routes"
-  tokenAddAuth   <- lift $ o .:  "add-auth"
+  tokenAddAuth   <- lift $ o .:? "add-auth"
   Jose.JwtClaims{..} <- lift $ parseJSON v
 
   let unIntDate (IntDate posix) = posixSecondsToUTCTime posix
@@ -104,6 +106,19 @@ tokenParseJSON v@(Object o) = do
   return BearerToken{..}
 tokenParseJSON v = lift $ JSON.typeMismatch "BearerToken" v
 
+tokenParseJSON' :: forall m.
+                  ( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
+                  , ParseRoute (HandlerSite m)
+                  , Hashable (Route (HandlerSite m))
+                  , MonadHandler m
+                  , MonadCrypto m
+                  , MonadCryptoKey m ~ CryptoIDKey
+                  )
+               => m (Value -> Parser (BearerToken (HandlerSite m)))
+tokenParseJSON' = do
+  cidKey <- cryptoIDKey return
+  return $ flip runReaderT cidKey . tokenParseJSON
+
 
 bearerToken :: forall m.
                ( MonadHandler m
@@ -113,7 +128,7 @@ bearerToken :: forall m.
                )
             => AuthId (HandlerSite m)
             -> Maybe (HashSet (Route (HandlerSite m)))
-            -> AuthCNF
+            -> Maybe AuthDNF
             -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
             -> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
             -> m (BearerToken (HandlerSite m))
@@ -135,9 +150,12 @@ bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsA
   return BearerToken{..}
 
 
+jwtEncoding :: Jose.JwtEncoding
+jwtEncoding = Jose.JwsEncoding Jose.HS256
+
+
 encodeToken :: forall m.
-               ( Crypto.MonadRandom m
-               , MonadHandler m
+               ( MonadHandler m
                , HasJSONWebKeySet (HandlerSite m) JwkSet
                , HasInstanceID (HandlerSite m) InstanceId
                , HasCryptoUUID (AuthId (HandlerSite m)) m
@@ -145,14 +163,43 @@ encodeToken :: forall m.
                )
             => BearerToken (HandlerSite m) -> m Jwt
 encodeToken token = do
-  _payload <- tokenToJSON token
-  error "Not implemented"
+  payload <- Jose.Claims . toStrict . JSON.encode <$> tokenToJSON token
+  JwkSet jwks <- getsYesod $ view jsonWebKeySet
+  either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
+
+
+data BearerTokenException
+  = BearerTokenJwtError Jose.JwtError
+  | BearerTokenUnsecured
+  | BearerTokenInvalidFormat String
+  | BearerTokenExpired | BearerTokenNotStarted
+  deriving (Eq, Show, Generic, Typeable)
+
+instance Exception BearerTokenException
 
 decodeToken :: forall m.
-               ( Crypto.MonadRandom m
-               , MonadHandler m
+               ( MonadHandler m
                , HasJSONWebKeySet (HandlerSite m) JwkSet
-               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
+               , MonadCryptoKey m ~ CryptoIDKey
+               , MonadCrypto m
+               , MonadThrow m
+               , ParseRoute (HandlerSite m)
+               , Hashable (Route (HandlerSite m))
                )
-            => Jwt -> m (Either JwtError (BearerToken (HandlerSite m)))
-decodeToken = error "Not implemented"
+            => Jwt -> m (BearerToken (HandlerSite m))
+decodeToken (Jwt bs) = do
+  JwkSet jwks <- getsYesod $ view jsonWebKeySet
+  content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
+  content' <- case content of
+    Jose.Unsecured _ -> throwM BearerTokenUnsecured
+    Jose.Jws (_header, payload) -> return payload
+    Jose.Jwe (_header, payload) -> return payload
+  parser <- tokenParseJSON'
+  token@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content'
+  now <- liftIO getCurrentTime
+  unless (NTop tokenExpiresAt > NTop (Just now)) $
+    throwM BearerTokenExpired
+  unless (tokenStartsAt <= Just now) $
+    throwM BearerTokenNotStarted
+  return token
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 5c292d146..0c3fb1198 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -714,6 +714,7 @@ pseudonymFragments = folding
 
 data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
   = AuthAdmin
+  | AuthToken
   | AuthLecturer
   | AuthCorrector
   | AuthRegistered
@@ -786,28 +787,27 @@ deriveJSON defaultOptions
   , unwrapUnaryRecords = True
   } ''PredLiteral
 
+instance PathPiece a => PathPiece (PredLiteral a) where
+  toPathPiece PLVariable{..} = toPathPiece plVar
+  toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar
 
-newtype PredCNF a = PredCNF (Set (NonNull (Set (PredLiteral a))))
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-  deriving newtype (Semigroup, Monoid)
+  fromPathPiece t = PLVariable <$> fromPathPiece t
+                <|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece)
 
-newtype PredDNF a = PredDNF (Set (NonNull (Set (PredLiteral a))))
+
+newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
   deriving newtype (Semigroup, Monoid)
 
 $(return [])
 
-instance (Ord a, ToJSON a) => ToJSON (PredCNF a) where
-  toJSON = $(mkToJSON predNFAesonOptions ''PredCNF)
-instance (Ord a, FromJSON a) => FromJSON (PredCNF a) where
-  parseJSON = $(mkParseJSON predNFAesonOptions ''PredCNF)
- 
 instance (Ord a, ToJSON a) => ToJSON (PredDNF a) where
   toJSON = $(mkToJSON predNFAesonOptions ''PredDNF)
 instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
   parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
 
-type AuthCNF = PredCNF AuthTag
+type AuthLiteral = PredLiteral AuthTag
+
 type AuthDNF = PredDNF AuthTag
 
 
diff --git a/src/Utils.hs b/src/Utils.hs
index 88adf17e4..a95cb7bfc 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -490,6 +490,12 @@ maybeExceptT err act = lift act >>= maybe (throwE err) return
 maybeMExceptT :: Monad m => m e -> m (Maybe b) -> ExceptT e m b
 maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
 
+maybeTExceptT :: Monad m => e -> MaybeT m b -> ExceptT e m b
+maybeTExceptT err act = maybeExceptT err $ runMaybeT act
+  
+maybeTMExceptT :: Monad m => m e -> MaybeT m b -> ExceptT e m b
+maybeTMExceptT err act = maybeMExceptT err $ runMaybeT act
+
 whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
 whenExceptT b err = when b $ throwE err
 
diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs
index 81b0c210a..f7922adcb 100644
--- a/src/Utils/Parameters.hs
+++ b/src/Utils/Parameters.hs
@@ -20,7 +20,7 @@ import Data.Universe
 import Control.Monad.Trans.Maybe (MaybeT(..))
 
 
-data GlobalGetParam = GetReferer
+data GlobalGetParam = GetReferer | GetToken
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe GlobalGetParam
@@ -51,6 +51,7 @@ globalGetParamField ident Field{fieldParse} = runMaybeT $ do
 data GlobalPostParam = PostFormIdentifier
                      | PostDeleteTarget
                      | PostMassInputShape
+                     | PostToken
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe GlobalPostParam
diff --git a/src/Yesod/Core/Instances.hs b/src/Yesod/Core/Instances.hs
index b8c6fed80..50b37679b 100644
--- a/src/Yesod/Core/Instances.hs
+++ b/src/Yesod/Core/Instances.hs
@@ -68,6 +68,9 @@ instance (RenderRoute site, ParseRoute site) => Binary (Route site) where
   put = Binary.put . toPathPiece
   get = Binary.get >>= maybe (fail "Could not parse route") return . fromPathPiece
 
+instance RenderRoute site => Hashable (Route site) where
+  hashWithSalt s = hashWithSalt s . routeToPathPiece
+
 
 instance Monad FormResult where
   (FormSuccess a)    >>= f = f a
diff --git a/test/Database.hs b/test/Database.hs
index 2c1992fa1..d0404df66 100755
--- a/test/Database.hs
+++ b/test/Database.hs
@@ -24,7 +24,7 @@ import qualified Data.ByteString as BS
 
 import Data.Time
 
-import Utils.Lens (review)
+import Utils.Lens (review, view)
 import Control.Monad.Random.Class (MonadRandom(..))
 
 
@@ -82,7 +82,7 @@ insertFile fileTitle = do
 
 fillDb :: DB ()
 fillDb = do
-  AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod appSettings
+  AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings
   now <- liftIO getCurrentTime
   let
     insert' :: PersistRecordBackend r (YesodPersistBackend UniWorX) => r -> YesodDB UniWorX (Key r)

From af6821c7c82966199c39b8a5f844331d809f4a80 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Fri, 5 Apr 2019 15:23:10 +0200
Subject: [PATCH 04/13] UserNotificationR

---
 messages/uniworx/de.msg                       |  8 ++++-
 routes                                        |  2 ++
 src/Foundation.hs                             | 28 ++++++++++++++++-
 src/Handler/Profile.hs                        | 31 +++++++++++++++++--
 src/Import.hs                                 |  1 +
 .../SendNotification/CorrectionsAssigned.hs   |  4 ++-
 .../Handler/SendNotification/SheetActive.hs   |  4 ++-
 .../Handler/SendNotification/SheetInactive.hs |  7 +++--
 .../SendNotification/SubmissionRated.hs       |  4 ++-
 .../SendNotification/UserRightsUpdate.hs      |  3 +-
 src/Jobs/Handler/SendNotification/Utils.hs    | 20 ++++++++++++
 src/Model/Types.hs                            |  1 +
 templates/mail/editNotifications.hamlet       |  5 ++-
 13 files changed, 105 insertions(+), 13 deletions(-)
 create mode 100644 src/Jobs/Handler/SendNotification/Utils.hs

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 3172caf4e..2e3b06abe 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -206,6 +206,7 @@ UnauthorizedOr  l@Text r@Text: (#{l} ODER #{r})
 UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. 
 UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen.
 UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.
+UnauthorizedTokenInvalid: Ihr Authorisierungs-Token konnte nicht verarbeitet werden.
 UnauthorizedTokenInvalidRoute: Ihr Authorisierungs-Token ist auf dieser Unterseite nicht gültig.
 UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
 UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
@@ -235,6 +236,7 @@ UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde au
 UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv
 UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt
 UnauthorizedRedirect: Die angeforderte Seite existiert nicht oder Sie haben keine Berechtigung, die angeforderte Seite zu sehen.
+UnauthorizedSelf: Aktueller Nutzer ist nicht angegebener Benutzer.
 
 EMail: E-Mail
 EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
@@ -276,6 +278,7 @@ ImpressumHeading: Impressum
 DataProtHeading: Datenschutzerklärung
 SystemMessageHeading: Uni2work Statusmeldung
 SystemMessageListHeading: Uni2work Statusmeldungen
+NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen für #{displayName}
 
 HomeOpenCourses: Kurse mit offener Registrierung
 HomeUpcomingSheets: Anstehende Übungsblätter
@@ -292,7 +295,8 @@ Plugin: Plugin
 Ident: Identifikation
 LastLogin: Letzter Login
 Settings: Individuelle Benutzereinstellungen
-SettingsUpdate: Einstellungen wurden gespeichert.
+SettingsUpdate: Einstellungen erfolgreich gespeichert
+NotificationSettingsUpdate: Benachrichtigungs-Einstellungen erfolgreich gespeichert
 Never: Nie
 
 MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen)
@@ -668,6 +672,7 @@ MenuCourseMembers: Kursteilnehmer
 MenuTermShow: Semester
 MenuSubmissionDelete: Abgabe löschen
 MenuUsers: Benutzer
+MenuUserNotifications: Benachrichtigungs-Einstellungen
 MenuAdminTest: Admin-Demo
 MenuMessageList: Systemnachrichten
 MenuAdminErrMsg: Fehlermeldung entschlüsseln
@@ -718,6 +723,7 @@ AuthTagOwner: Nutzer ist Besitzer
 AuthTagRated: Korrektur ist bewertet
 AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer
 AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
+AuthTagSelf: Nutzer greift nur auf eigene Daten zu
 AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich
 AuthTagRead: Zugriff ist nur lesend
 AuthTagWrite: Zugriff ist i.A. schreibend
diff --git a/routes b/routes
index f76fd47b7..24ce58838 100644
--- a/routes
+++ b/routes
@@ -16,6 +16,7 @@
 --    !registered     -- participant for this course (no effect outside of courses)
 --    !participant    -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses)
 --    !owner          -- part of the group of owners of this submission
+--    !self           -- route refers to the currently logged in user themselves
 --    !capacity       -- course this route is associated with has at least one unit of participant capacity
 --    !empty          -- course this route is associated with has no participants whatsoever
 --
@@ -39,6 +40,7 @@
 /users/#CryptoUUIDUser        AdminUserR        GET POST
 /users/#CryptoUUIDUser/delete AdminUserDeleteR      POST
 /users/#CryptoUUIDUser/hijack AdminHijackUserR  POST          !adminANDno-escalation
+/users/#CryptoUUIDUser/notifications UserNotificationR GET POST      !self
 /admin                        AdminR            GET
 /admin/features               AdminFeaturesR    GET POST
 /admin/test                   AdminTestR        GET POST
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 9634fda67..533804953 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -482,7 +482,9 @@ tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return r
   BearerToken{..} <- catch (decodeToken jwt) $ \case
     BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
     BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
-    other -> throwM other
+    other -> do
+      $logWarnS "AuthToken" $ tshow other
+      throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid
   unless (maybe True (HashSet.member route) tokenRoutes) $
     throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidRoute
   authorityVal <- evalAccessFor (Just tokenAuthority) route isWrite
@@ -735,6 +737,20 @@ tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
     guard $ sheetSubmissionMode == CorrectorSubmissions
     return Authorized
   r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
+tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return return $ do
+  referencedUser <- case route of
+    AdminUserR cID -> return cID
+    AdminUserDeleteR cID -> return cID
+    AdminHijackUserR cID -> return cID
+    UserNotificationR cID -> return cID
+    CourseR _ _ _ (CUserR cID) -> return cID
+    _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
+  referencedUser' <- decrypt referencedUser
+  case mAuthId of
+    Just uid
+      | uid == referencedUser' -> return Authorized
+    Nothing -> return AuthenticationRequired
+    _other  -> unauthorizedI MsgUnauthorizedSelf
 tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
     smId <- decrypt cID
@@ -1465,6 +1481,16 @@ pageActions (AdminR) =
       , menuItemAccessCallback' = return True
       }
   ]
+pageActions (AdminUserR cID) = [
+    MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuUserNotifications
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ UserNotificationR cID
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
+  ]
 pageActions (InfoR) = [
     MenuItem
       { menuItemType  = PageActionPrime
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index 5de418a34..326beb0d6 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -42,11 +42,10 @@ makeSettingForm template = identifyForm FIDsettings $ \html -> do
                                    & setTooltip MsgDownloadFilesTip
                                 ) (stgDownloadFiles <$> template)
         <*  aformSection MsgFormNotifications
-        <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
+        <*> notificationForm (stgNotificationSettings <$> template)
     return (result, widget) -- no validation required here
   where
     themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
-    nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
 --
 -- Version with proper grouping:
 --
@@ -76,6 +75,12 @@ makeSettingForm template = identifyForm FIDsettings $ \html -> do
 --       <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
 --     nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
 
+notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
+notificationForm template = NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True
+  where
+    nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt <$> template)
+    
+
 getProfileR, postProfileR :: Handler Html
 getProfileR = postProfileR
 postProfileR = do
@@ -532,3 +537,25 @@ postAuthPredsR = do
   siteLayoutMsg MsgAuthPredsActive $ do
     setTitleI MsgAuthPredsActive
     $(widgetFile "authpreds")
+
+
+getUserNotificationR, postUserNotificationR :: CryptoUUIDUser -> Handler Html
+getUserNotificationR = postUserNotificationR
+postUserNotificationR cID = do
+  uid <- decrypt cID
+  User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid
+  
+  ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
+  isModal <- hasCustomHeader HeaderIsModal
+  let formWidget = wrapForm nsInnerWdgt def
+        { formAction = Just . SomeRoute $ UserNotificationR cID
+        , formEncoding = nsEnc
+        , formAttrs = [ ("data-ajax-submit", "") | isModal ]
+        }
+
+  formResultModal nsRes (UserNotificationR cID) $ \ns -> do
+    lift . runDB $ update uid [ UserNotificationSettings =. ns ]
+    tell . pure =<< messageI Success MsgNotificationSettingsUpdate
+
+  siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $
+    formWidget
diff --git a/src/Import.hs b/src/Import.hs
index 27dc6e5df..9743e86ac 100644
--- a/src/Import.hs
+++ b/src/Import.hs
@@ -6,3 +6,4 @@ import Foundation            as Import
 import Import.NoFoundation   as Import
 
 import Utils.SystemMessage   as Import
+import Model.Token           as Import
diff --git a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs
index 51ec02f77..f7943cb6c 100644
--- a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs
+++ b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs
@@ -6,6 +6,7 @@ module Jobs.Handler.SendNotification.CorrectionsAssigned
 
 import Import
 
+import Jobs.Handler.SendNotification.Utils
 import Handler.Utils.Mail
 
 import Text.Hamlet
@@ -27,6 +28,7 @@ dispatchNotificationCorrectionsAssigned  nUser nSheet jRecipient = do
     MsgRenderer mr <- getMailMsgRenderer
     let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
 
+    editNotifications <- mkEditNotifications jRecipient
+
     addAlternatives $ do
-      let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
       providePreferredAlternative ($(ihamletFile "templates/mail/correctionsAssigned.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
diff --git a/src/Jobs/Handler/SendNotification/SheetActive.hs b/src/Jobs/Handler/SendNotification/SheetActive.hs
index 91a8fc716..6e3618de2 100644
--- a/src/Jobs/Handler/SendNotification/SheetActive.hs
+++ b/src/Jobs/Handler/SendNotification/SheetActive.hs
@@ -7,6 +7,7 @@ module Jobs.Handler.SendNotification.SheetActive
 import Import
 
 import Handler.Utils.Mail
+import Jobs.Handler.SendNotification.Utils
 
 import Text.Hamlet
 import qualified Data.CaseInsensitive as CI
@@ -26,6 +27,7 @@ dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
       csh = courseShorthand
       shn = sheetName
 
+  editNotifications <- mkEditNotifications jRecipient
+
   addAlternatives $ do
-    let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
     providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
diff --git a/src/Jobs/Handler/SendNotification/SheetInactive.hs b/src/Jobs/Handler/SendNotification/SheetInactive.hs
index 7112e5c39..bab937c89 100644
--- a/src/Jobs/Handler/SendNotification/SheetInactive.hs
+++ b/src/Jobs/Handler/SendNotification/SheetInactive.hs
@@ -8,6 +8,7 @@ module Jobs.Handler.SendNotification.SheetInactive
 import Import
 
 import Handler.Utils.Mail
+import Jobs.Handler.SendNotification.Utils
 
 import Text.Hamlet
 import qualified Data.CaseInsensitive as CI
@@ -29,8 +30,9 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $
       csh = courseShorthand
       shn = sheetName
 
+  editNotifications <- mkEditNotifications jRecipient
+
   addAlternatives $ do
-    let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
     providePreferredAlternative ($(ihamletFile "templates/mail/sheetSoonInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
 
 dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler ()
@@ -54,7 +56,8 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
       csh = courseShorthand
       shn = sheetName
 
+  editNotifications <- mkEditNotifications jRecipient
+
   addAlternatives $ do
-    let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
     providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
 
diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs
index 78083d83f..16423a924 100644
--- a/src/Jobs/Handler/SendNotification/SubmissionRated.hs
+++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs
@@ -9,6 +9,7 @@ import Import
 import Utils.Lens
 import Handler.Utils.DateTime
 import Handler.Utils.Mail
+import Jobs.Handler.SendNotification.Utils
 
 import Text.Hamlet
 import qualified Data.Aeson as Aeson
@@ -34,6 +35,8 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
       csh = courseShorthand
       shn = sheetName
 
+  editNotifications <- mkEditNotifications jRecipient
+
   -- TODO: provide convienience template-haskell for `addAlternatives`
   addAlternatives $ do
     provideAlternative $ Aeson.object
@@ -51,5 +54,4 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
       , "course-school" Aeson..= courseSchool
       ]
     -- provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX)) -- textFile does not support control statements
-    let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
     providePreferredAlternative ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
diff --git a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs
index aaf50ac72..90e645de7 100644
--- a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs
+++ b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs
@@ -8,6 +8,7 @@ import Import
 
 import Handler.Utils.Database
 import Handler.Utils.Mail
+import Jobs.Handler.SendNotification.Utils
 
 import Text.Hamlet
 -- import qualified Data.CaseInsensitive as CI
@@ -21,7 +22,7 @@ dispatchNotificationUserRightsUpdate  nUser _originalRights jRecipient = userMai
       return (user,adminSchools,lecturerSchools)
     setSubjectI $ MsgMailSubjectUserRightsUpdate userDisplayName
     -- MsgRenderer mr <- getMailMsgRenderer
+    editNotifications <- mkEditNotifications jRecipient
     addAlternatives $ do
-      let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
       providePreferredAlternative ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
 
diff --git a/src/Jobs/Handler/SendNotification/Utils.hs b/src/Jobs/Handler/SendNotification/Utils.hs
new file mode 100644
index 000000000..d7ca82a76
--- /dev/null
+++ b/src/Jobs/Handler/SendNotification/Utils.hs
@@ -0,0 +1,20 @@
+module Jobs.Handler.SendNotification.Utils
+  ( mkEditNotifications
+  ) where
+
+import Import
+
+import Text.Hamlet
+
+import qualified Data.HashSet as HashSet
+
+
+mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
+mkEditNotifications uid = liftHandlerT $ do
+  cID <- encrypt uid
+  jwt <- encodeToken =<< bearerToken uid (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
+  let
+    editNotificationsUrl :: SomeRoute UniWorX
+    editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetToken, toPathPiece jwt)])
+  editNotificationsUrl' <- toTextUrl editNotificationsUrl
+  return ($(ihamletFile "templates/mail/editNotifications.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 0c3fb1198..21672d9d2 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -727,6 +727,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthCorrectorSubmissions
   | AuthCapacity
   | AuthEmpty
+  | AuthSelf
   | AuthAuthentication
   | AuthNoEscalation
   | AuthRead
diff --git a/templates/mail/editNotifications.hamlet b/templates/mail/editNotifications.hamlet
index 7ca5d9f8b..6e701e511 100644
--- a/templates/mail/editNotifications.hamlet
+++ b/templates/mail/editNotifications.hamlet
@@ -1,4 +1,3 @@
 <p>      
-  <a href=@{ProfileR}>
-    _{MsgProfileHeading}
-  \ _{MsgMailEditNotifications}
\ No newline at end of file
+  <a href=#{editNotificationsUrl'}>
+    _{MsgMailEditNotifications}

From 6e29d8ed89513200ef4b6ea9de9c8d80bbb7de6d Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Fri, 5 Apr 2019 16:37:39 +0200
Subject: [PATCH 05/13] Token revocation & Bugfixes

---
 messages/uniworx/de.msg                      |   3 +
 models/users                                 |   1 +
 src/Foundation.hs                            |  23 ++--
 src/Handler/Profile.hs                       | 115 +++++++++++++------
 src/Model/Token.hs                           |  17 ++-
 templates/profile.hamlet                     |   2 -
 templates/profile/profile.hamlet             |  13 +++
 templates/profile/tokenExplanation/de.hamlet |  13 +++
 8 files changed, 141 insertions(+), 46 deletions(-)
 delete mode 100644 templates/profile.hamlet
 create mode 100644 templates/profile/profile.hamlet
 create mode 100644 templates/profile/tokenExplanation/de.hamlet

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 2e3b06abe..1c07086f8 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -10,6 +10,7 @@ BtnSave: Speichern
 BtnCandidatesInfer: Studienfachzuordnung automatisch lernen
 BtnCandidatesDeleteConflicts: Konflikte löschen
 BtnCandidatesDeleteAll: Alle Beobachtungen löschen
+BtnResetTokens: Authorisierungs-Tokens invalidieren
 
 Aborted: Abgebrochen
 Remarks: Hinweise
@@ -279,6 +280,8 @@ DataProtHeading: Datenschutzerklärung
 SystemMessageHeading: Uni2work Statusmeldung
 SystemMessageListHeading: Uni2work Statusmeldungen
 NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen für #{displayName}
+TokensLastReset: Tokens zuletzt invalidiert
+TokensResetSuccess: Authorisierungs-Tokens invalidiert
 
 HomeOpenCourses: Kurse mit offener Registrierung
 HomeUpcomingSheets: Anstehende Übungsblätter
diff --git a/models/users b/models/users
index 80e5ff43c..cd08164d1 100644
--- a/models/users
+++ b/models/users
@@ -11,6 +11,7 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     ident          (CI Text)                -- Case-insensitive user-identifier
     authentication AuthenticationMode       -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
     lastAuthentication UTCTime Maybe        -- last login date
+    tokensIssuedAfter  UTCTime Maybe        -- do not accept bearer tokens issued before this time (accept all tokens if null) 
     matrikelnummer Text Maybe               -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
     email          (CI Text)                -- Case-insensitive eMail address
     displayName    Text                     -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 533804953..4e2ea8695 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -474,26 +474,26 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
     guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
     return Authorized
 tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ do
-  jwt <- maybeTMExceptT (unauthorizedI MsgUnauthorizedNoToken) $ asum
-    [ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
-    , MaybeT $ lookupGlobalPostParam PostToken
-    , MaybeT $ lookupGlobalGetParam GetToken
-    ]
+  jwt <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askJwt
   BearerToken{..} <- catch (decodeToken jwt) $ \case
     BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
     BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
     other -> do
       $logWarnS "AuthToken" $ tshow other
       throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid
-  unless (maybe True (HashSet.member route) tokenRoutes) $
-    throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidRoute
+
+  guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
+
+  User{userTokensIssuedAfter} <- lift $ get404 tokenAuthority
+  guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
+
   authorityVal <- evalAccessFor (Just tokenAuthority) route isWrite
-  unless (is _Authorized authorityVal) $
-    throwError authorityVal
+  guardExceptT (is _Authorized authorityVal) authorityVal
+
   whenIsJust tokenAddAuth $ \addDNF -> do
     additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) addDNF mAuthId route isWrite
-    unless (is _Authorized additionalVal) $
-      throwError additionalVal
+    guardExceptT (is _Authorized additionalVal) additionalVal
+
   return Authorized
 tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
   AdminHijackUserR cID -> exceptT return return $ do
@@ -2206,6 +2206,7 @@ instance YesodAuth UniWorX where
               , userDownloadFiles        = userDefaultDownloadFiles
               , userNotificationSettings = def
               , userMailLanguages        = def
+              , userTokensIssuedAfter    = Nothing
               , ..
               }
             userUpdate =  [ UserMatrikelnummer     =. userMatrikelnummer
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index 326beb0d6..f01f34281 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -79,7 +79,26 @@ notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSett
 notificationForm template = NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True
   where
     nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt <$> template)
-    
+
+
+data ButtonResetTokens = BtnResetTokens
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonResetTokens
+instance Finite ButtonResetTokens
+
+nullaryPathPiece ''ButtonResetTokens $ camelToPathPiece' 1
+
+embedRenderMessage ''UniWorX ''ButtonResetTokens id
+instance Button UniWorX ButtonResetTokens where
+  btnClasses BtnResetTokens = [BCIsButton, BCDanger]
+
+data ProfileAnchor = ProfileSettings | ProfileResetTokens
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+instance Universe ProfileAnchor
+instance Finite ProfileAnchor
+
+nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1
+
 
 getProfileR, postProfileR :: Handler Html
 getProfileR = postProfileR
@@ -94,37 +113,60 @@ postProfileR = do
         , stgDownloadFiles = userDownloadFiles
         , stgNotificationSettings = userNotificationSettings
         }
-  ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate
-  case res of
-    (FormSuccess SettingsForm{..}) -> do
-        runDB $ do
-          update uid  [ UserMaxFavourites  =. stgMaxFavourties
-                      , UserTheme          =. stgTheme
-                      , UserDateTimeFormat =. stgDateTime
-                      , UserDateFormat     =. stgDate
-                      , UserTimeFormat     =. stgTime
-                      , UserDownloadFiles  =. stgDownloadFiles
-                      , UserNotificationSettings =. stgNotificationSettings
-                      ]
-          when (stgMaxFavourties < userMaxFavourites) $ do
-            -- prune Favourites to user-defined size
-            oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
-                                      [ Desc CourseFavouriteTime
-                                      , OffsetBy stgMaxFavourties
-                                      ]
-            mapM_ delete oldFavs
-        addMessageI Info MsgSettingsUpdate
-        redirect ProfileR -- TODO: them change does not happen without redirect
+  ((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate
 
-    (FormFailure msgs) -> forM_ msgs $ addMessage Warning . toHtml
-    _ -> return ()
+  formResult res $ \SettingsForm{..} -> do
+    runDB $ do
+      update uid  [ UserMaxFavourites  =. stgMaxFavourties
+                  , UserTheme          =. stgTheme
+                  , UserDateTimeFormat =. stgDateTime
+                  , UserDateFormat     =. stgDate
+                  , UserTimeFormat     =. stgTime
+                  , UserDownloadFiles  =. stgDownloadFiles
+                  , UserNotificationSettings =. stgNotificationSettings
+                  ]
+      when (stgMaxFavourties < userMaxFavourites) $ do
+        -- prune Favourites to user-defined size
+        oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
+                                  [ Desc CourseFavouriteTime
+                                  , OffsetBy stgMaxFavourties
+                                  ]
+        mapM_ delete oldFavs
+    addMessageI Info MsgSettingsUpdate
+    redirect $ ProfileR :#: ProfileSettings
+
+  ((tokenRes, tokenFormWidget), tokenEnctype) <- runFormPost . identifyForm ProfileResetTokens $ buttonForm
+
+  formResult tokenRes $ \BtnResetTokens -> do
+    now <- liftIO getCurrentTime
+    runDB $ update uid [ UserTokensIssuedAfter =. Just now ]
+    addMessageI Info MsgTokensResetSuccess
+    redirect $ ProfileR :#: ProfileResetTokens
+
+  tResetTime <- traverse (formatTime SelFormatDateTime) userTokensIssuedAfter
 
   siteLayout [whamlet|_{MsgProfileFor} ^{nameWidget userDisplayName userSurname}|] $ do
     setTitle . toHtml $ "Profil " <> userIdent
-    wrapForm formWidget def
-      { formAction = Just $ SomeRoute ProfileR
-      , formEncoding = formEnctype
-      }
+    let settingsForm = 
+          wrapForm formWidget FormSettings
+            { formMethod = POST
+            , formAction = Just . SomeRoute $ ProfileR :#: ProfileSettings
+            , formEncoding = formEnctype
+            , formAttrs = []
+            , formSubmit = FormSubmit
+            , formAnchor = Just ProfileSettings
+            }
+        tokenForm =
+          wrapForm tokenFormWidget FormSettings
+            { formMethod = POST
+            , formAction = Just . SomeRoute $ ProfileR :#: ProfileResetTokens
+            , formEncoding = tokenEnctype
+            , formAttrs = []
+            , formSubmit = FormNoSubmit
+            , formAnchor = Just ProfileResetTokens
+            }
+        tokenExplanation = $(i18nWidgetFile "profile/tokenExplanation")
+    $(widgetFile "profile/profile")
 
 
 getProfileDataR :: Handler Html
@@ -544,18 +586,27 @@ getUserNotificationR = postUserNotificationR
 postUserNotificationR cID = do
   uid <- decrypt cID
   User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid
-  
+
   ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
+  mJwt <- askJwt
   isModal <- hasCustomHeader HeaderIsModal
-  let formWidget = wrapForm nsInnerWdgt def
+  let formWidget = wrapForm nsInnerWdgt' def
         { formAction = Just . SomeRoute $ UserNotificationR cID
         , formEncoding = nsEnc
         , formAttrs = [ ("data-ajax-submit", "") | isModal ]
         }
+      nsInnerWdgt'
+        = [whamlet|
+            $newline never
+            $maybe jwt <- mJwt
+              <input type=hidden name=#{toPathPiece PostToken} value=#{toPathPiece jwt}>
+            ^{nsInnerWdgt}
+          |]
 
-  formResultModal nsRes (UserNotificationR cID) $ \ns -> do
+  formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetToken, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do
     lift . runDB $ update uid [ UserNotificationSettings =. ns ]
     tell . pure =<< messageI Success MsgNotificationSettingsUpdate
 
-  siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $
+  siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do
+    setTitleI $ MsgNotificationSettingsHeading userDisplayName
     formWidget
diff --git a/src/Model/Token.hs b/src/Model/Token.hs
index d9c3afe94..a4d108714 100644
--- a/src/Model/Token.hs
+++ b/src/Model/Token.hs
@@ -5,13 +5,15 @@ module Model.Token
   , bearerToken
   , encodeToken, BearerTokenException(..), decodeToken
   , tokenToJSON, tokenParseJSON, tokenParseJSON'
+  , askJwt
   ) where
 
 import ClassyPrelude.Yesod
 import Model
 import Settings
-import Utils (NTop(..))
+import Utils (NTop(..), hoistMaybe)
 import Utils.Lens hiding ((.=))
+import Utils.Parameters
 
 import Yesod.Auth (AuthId)
 
@@ -40,6 +42,7 @@ import Data.Time.Clock
 import Data.Time.Clock.POSIX
 
 import Control.Monad.Random (MonadRandom(..))
+import Control.Monad.Trans.Maybe (MaybeT(..))
 
 
 data BearerToken site = BearerToken
@@ -203,3 +206,15 @@ decodeToken (Jwt bs) = do
   unless (tokenStartsAt <= Just now) $
     throwM BearerTokenNotStarted
   return token
+
+
+askJwt :: forall m.
+          ( MonadHandler m
+          )
+       => m (Maybe Jwt)
+-- | Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
+askJwt = runMaybeT $ asum
+  [ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
+  , MaybeT $ lookupGlobalPostParam PostToken
+  , MaybeT $ lookupGlobalGetParam GetToken
+  ]
diff --git a/templates/profile.hamlet b/templates/profile.hamlet
deleted file mode 100644
index fc6a9bef7..000000000
--- a/templates/profile.hamlet
+++ /dev/null
@@ -1,2 +0,0 @@
-<div .profile>
-  ^{settingsForm}
diff --git a/templates/profile/profile.hamlet b/templates/profile/profile.hamlet
new file mode 100644
index 000000000..e2b1e4365
--- /dev/null
+++ b/templates/profile/profile.hamlet
@@ -0,0 +1,13 @@
+$newline never
+<section>
+  ^{settingsForm}
+<section>
+  ^{tokenExplanation}
+  <p>
+    _{MsgTokensLastReset}:
+    $maybe tResetTime' <- tResetTime
+      \ #{tResetTime'}
+    $nothing
+      \ _{MsgNever}
+    <br />
+    ^{tokenForm}
diff --git a/templates/profile/tokenExplanation/de.hamlet b/templates/profile/tokenExplanation/de.hamlet
new file mode 100644
index 000000000..2237bddee
--- /dev/null
+++ b/templates/profile/tokenExplanation/de.hamlet
@@ -0,0 +1,13 @@
+<p>
+  Das System stellt gelegentlich Benutzer-bezogene <i>Authorisierungs-Tokens</i> aus.
+  Diese Tokens erlauben es jedem, der in Besitz dieses Tokens ist, bestimmte Ihrer Benutzer-Rechte anzunehmen.
+
+<p>
+  Dies ist insbesondere notwendig um verschickten Emails einen Link beifügen zu können, der das Deabonnieren von Benachrichtigungen erlaubt.
+
+<p>
+  Mit dem untigen Knopf können Sie alle Authorisierungs-Tokens, die bisher für Sie ausgestellt wurden, als ungültig markieren.
+  Dies ist zum Beispiel dann notwendig, wenn Sie Grund haben zu vermuten, dass Dritte Zugriff auf eines Ihrer Tokens gehabt haben könnten.
+
+<p>
+  Für die sichere Verwahrung Ihnen ausgehändigter Tokens sind immer Sie selbst verantwortlich.

From e94792195595c07a08124e778cba6785c80f92e5 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Fri, 5 Apr 2019 17:15:26 +0200
Subject: [PATCH 06/13] Fix Test

---
 .../Handler/SendNotification/CorrectionsAssigned.hs   |  2 +-
 src/Jobs/Handler/SendNotification/SheetActive.hs      |  2 +-
 src/Jobs/Handler/SendNotification/SheetInactive.hs    |  4 ++--
 src/Jobs/Handler/SendNotification/UserRightsUpdate.hs |  2 +-
 src/Model/Token.hs                                    |  4 ++--
 test.sh                                               | 11 +++++++++++
 test/Database.hs                                      |  5 +++++
 test/ModelSpec.hs                                     |  1 +
 test/TestImport.hs                                    |  3 ++-
 9 files changed, 26 insertions(+), 8 deletions(-)

diff --git a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs
index f7943cb6c..2644a36ef 100644
--- a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs
+++ b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs
@@ -30,5 +30,5 @@ dispatchNotificationCorrectionsAssigned  nUser nSheet jRecipient = do
 
     editNotifications <- mkEditNotifications jRecipient
 
-    addAlternatives $ do
+    addAlternatives $
       providePreferredAlternative ($(ihamletFile "templates/mail/correctionsAssigned.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
diff --git a/src/Jobs/Handler/SendNotification/SheetActive.hs b/src/Jobs/Handler/SendNotification/SheetActive.hs
index 6e3618de2..1530d3e44 100644
--- a/src/Jobs/Handler/SendNotification/SheetActive.hs
+++ b/src/Jobs/Handler/SendNotification/SheetActive.hs
@@ -29,5 +29,5 @@ dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
 
   editNotifications <- mkEditNotifications jRecipient
 
-  addAlternatives $ do
+  addAlternatives $
     providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
diff --git a/src/Jobs/Handler/SendNotification/SheetInactive.hs b/src/Jobs/Handler/SendNotification/SheetInactive.hs
index bab937c89..21cd7aced 100644
--- a/src/Jobs/Handler/SendNotification/SheetInactive.hs
+++ b/src/Jobs/Handler/SendNotification/SheetInactive.hs
@@ -32,7 +32,7 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $
 
   editNotifications <- mkEditNotifications jRecipient
 
-  addAlternatives $ do
+  addAlternatives $
     providePreferredAlternative ($(ihamletFile "templates/mail/sheetSoonInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
 
 dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler ()
@@ -58,6 +58,6 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
 
   editNotifications <- mkEditNotifications jRecipient
 
-  addAlternatives $ do
+  addAlternatives $
     providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
 
diff --git a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs
index 90e645de7..a70d167e9 100644
--- a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs
+++ b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs
@@ -23,6 +23,6 @@ dispatchNotificationUserRightsUpdate  nUser _originalRights jRecipient = userMai
     setSubjectI $ MsgMailSubjectUserRightsUpdate userDisplayName
     -- MsgRenderer mr <- getMailMsgRenderer
     editNotifications <- mkEditNotifications jRecipient
-    addAlternatives $ do
+    addAlternatives $
       providePreferredAlternative ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
 
diff --git a/src/Model/Token.hs b/src/Model/Token.hs
index a4d108714..cfaaacb55 100644
--- a/src/Model/Token.hs
+++ b/src/Model/Token.hs
@@ -136,8 +136,8 @@ bearerToken :: forall m.
             -> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
             -> m (BearerToken (HandlerSite m))
 bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do
-  tokenIdentifier <- liftIO $ getRandom
-  tokenIssuedAt <- liftIO $ getCurrentTime
+  tokenIdentifier <- liftIO getRandom
+  tokenIssuedAt <- liftIO getCurrentTime
   tokenIssuedBy <- getsYesod $ view instanceID
 
   defaultExpiration <- getsYesod $ view _appJWTExpiration
diff --git a/test.sh b/test.sh
index 09d4b3a53..f4a4da1cf 100755
--- a/test.sh
+++ b/test.sh
@@ -1,3 +1,14 @@
 #!/usr/bin/env bash
 
+move-back() {
+    mv -v .stack-work .stack-work-test
+    [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
+}
+
+if [[ -d .stack-work-test ]]; then
+    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
+    mv -v .stack-work-test .stack-work
+    trap move-back EXIT
+fi
+
 exec -- stack build --test --fast --flag uniworx:dev --flag uniworx:library-only ${@}
diff --git a/test/Database.hs b/test/Database.hs
index d0404df66..3943263db 100755
--- a/test/Database.hs
+++ b/test/Database.hs
@@ -94,6 +94,7 @@ fillDb = do
     { userIdent  = "G.Kleen@campus.lmu.de"
     , userAuthentication = AuthLDAP
     , userLastAuthentication = Just now
+    , userTokensIssuedAfter = Just now
     , userMatrikelnummer = Nothing
     , userEmail  = "G.Kleen@campus.lmu.de"
     , userDisplayName = "Gregor Kleen"
@@ -111,6 +112,7 @@ fillDb = do
     { userIdent  = "felix.hamann@campus.lmu.de"
     , userAuthentication = AuthLDAP
     , userLastAuthentication = Nothing
+    , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
     , userEmail  = "felix.hamann@campus.lmu.de"
     , userDisplayName = "Felix Hamann"
@@ -128,6 +130,7 @@ fillDb = do
     { userIdent  = "jost@tcs.ifi.lmu.de"
     , userAuthentication = AuthLDAP
     , userLastAuthentication = Nothing
+    , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
     , userEmail  = "jost@tcs.ifi.lmu.de"
     , userDisplayName = "Steffen Jost"
@@ -145,6 +148,7 @@ fillDb = do
     { userIdent  = "max@campus.lmu.de"
     , userAuthentication = AuthLDAP
     , userLastAuthentication = Just now
+    , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Just "1299"
     , userEmail  = "max@campus.lmu.de"
     , userDisplayName = "Max Musterstudent"
@@ -162,6 +166,7 @@ fillDb = do
     { userIdent  = "tester@campus.lmu.de"
     , userAuthentication = AuthLDAP
     , userLastAuthentication = Nothing
+    , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Just "999"
     , userEmail  = "tester@campus.lmu.de"
     , userDisplayName = "Tina Tester"
diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs
index 258211f94..3850363a6 100644
--- a/test/ModelSpec.hs
+++ b/test/ModelSpec.hs
@@ -41,6 +41,7 @@ instance Arbitrary User where
       ]
     userAuthentication <- arbitrary
     userLastAuthentication <- arbitrary
+    userTokensIssuedAfter <- arbitrary
     userMatrikelnummer <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9'])
     userEmail <- CI.mk . decodeUtf8 . Email.toByteString <$> arbitrary
 
diff --git a/test/TestImport.hs b/test/TestImport.hs
index f576ccf30..4ba8082bd 100644
--- a/test/TestImport.hs
+++ b/test/TestImport.hs
@@ -103,11 +103,12 @@ authenticateAs (Entity _ User{..}) = do
 -- checking is switched off in wipeDB for those database backends which need it.
 createUser :: (User -> User) -> YesodExample UniWorX (Entity User)
 createUser adjUser = do
-  UserDefaultConf{..} <- appUserDefaults . appSettings <$> getTestYesod
+  UserDefaultConf{..} <- appUserDefaults . view appSettings <$> getTestYesod
   let
     userMatrikelnummer = Nothing
     userAuthentication = AuthLDAP
     userLastAuthentication = Nothing
+    userTokensIssuedAfter = Nothing
     userIdent = "dummy@example.invalid"
     userEmail = "dummy@example.invalid"
     userDisplayName = "Dummy Example"

From 15fa8d11302cb7d34e971210b9572c339c281b62 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Fri, 5 Apr 2019 22:45:03 +0200
Subject: [PATCH 07/13] =?UTF-8?q?(Get|Post)Token=20=E2=86=92=20(Get|Post)B?=
 =?UTF-8?q?earer?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 src/Handler/Profile.hs                     | 4 ++--
 src/Jobs/Handler/SendNotification/Utils.hs | 2 +-
 src/Model/Token.hs                         | 4 ++--
 src/Utils/Parameters.hs                    | 4 ++--
 4 files changed, 7 insertions(+), 7 deletions(-)

diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index f01f34281..71e718da9 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -599,11 +599,11 @@ postUserNotificationR cID = do
         = [whamlet|
             $newline never
             $maybe jwt <- mJwt
-              <input type=hidden name=#{toPathPiece PostToken} value=#{toPathPiece jwt}>
+              <input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece jwt}>
             ^{nsInnerWdgt}
           |]
 
-  formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetToken, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do
+  formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do
     lift . runDB $ update uid [ UserNotificationSettings =. ns ]
     tell . pure =<< messageI Success MsgNotificationSettingsUpdate
 
diff --git a/src/Jobs/Handler/SendNotification/Utils.hs b/src/Jobs/Handler/SendNotification/Utils.hs
index d7ca82a76..c91199db9 100644
--- a/src/Jobs/Handler/SendNotification/Utils.hs
+++ b/src/Jobs/Handler/SendNotification/Utils.hs
@@ -15,6 +15,6 @@ mkEditNotifications uid = liftHandlerT $ do
   jwt <- encodeToken =<< bearerToken uid (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
   let
     editNotificationsUrl :: SomeRoute UniWorX
-    editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetToken, toPathPiece jwt)])
+    editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])
   editNotificationsUrl' <- toTextUrl editNotificationsUrl
   return ($(ihamletFile "templates/mail/editNotifications.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
diff --git a/src/Model/Token.hs b/src/Model/Token.hs
index cfaaacb55..f84fc970a 100644
--- a/src/Model/Token.hs
+++ b/src/Model/Token.hs
@@ -215,6 +215,6 @@ askJwt :: forall m.
 -- | Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
 askJwt = runMaybeT $ asum
   [ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
-  , MaybeT $ lookupGlobalPostParam PostToken
-  , MaybeT $ lookupGlobalGetParam GetToken
+  , MaybeT $ lookupGlobalPostParam PostBearer
+  , MaybeT $ lookupGlobalGetParam GetBearer
   ]
diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs
index f7922adcb..bc3735620 100644
--- a/src/Utils/Parameters.hs
+++ b/src/Utils/Parameters.hs
@@ -20,7 +20,7 @@ import Data.Universe
 import Control.Monad.Trans.Maybe (MaybeT(..))
 
 
-data GlobalGetParam = GetReferer | GetToken
+data GlobalGetParam = GetReferer | GetBearer
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe GlobalGetParam
@@ -51,7 +51,7 @@ globalGetParamField ident Field{fieldParse} = runMaybeT $ do
 data GlobalPostParam = PostFormIdentifier
                      | PostDeleteTarget
                      | PostMassInputShape
-                     | PostToken
+                     | PostBearer
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe GlobalPostParam

From 1532518943da98cc472d5a8dba9663ec842010b4 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Wed, 10 Apr 2019 09:25:51 +0200
Subject: [PATCH 08/13] Fix build

---
 src/Foundation.hs | 2 +-
 src/Utils/Lens.hs | 2 ++
 2 files changed, 3 insertions(+), 1 deletion(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index 41d23fa65..1eebfd41c 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -2306,7 +2306,7 @@ instance YesodMail UniWorX where
   mailT ctx mail = defMailT ctx $ do
     void setMailObjectId
     setDateCurrent
-    replaceMailHeader "Sender" . Just . addressEmail =<< getsYesod (appMailFrom . appSettings)
+    replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)
 
     mail <* setMailSmtpData
 
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index b6a09e3c3..4493dc612 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -70,6 +70,8 @@ hasEntityUser = hasEntity
 --   hasUser = _entityVal . hasUser
 
 
+makeLenses_ ''Address
+
 makeLenses_ ''SheetCorrector
 
 makeLenses_ ''SubmissionGroup

From 1eb076cc93b2b8d608668ea190b5a33731c18108 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Wed, 10 Apr 2019 10:39:03 +0200
Subject: [PATCH 09/13] tokenRestrictions and documentation

---
 package.yaml       |  1 +
 src/Model/Token.hs | 67 +++++++++++++++++++++++++++++++++-------------
 2 files changed, 49 insertions(+), 19 deletions(-)

diff --git a/package.yaml b/package.yaml
index 94235a3c1..f6d487376 100644
--- a/package.yaml
+++ b/package.yaml
@@ -119,6 +119,7 @@ dependencies:
   - semigroupoids
   - jose-jwt
   - mono-traversable
+  - lens-aeson
 
 other-extensions:
   - GeneralizedNewtypeDeriving
diff --git a/src/Model/Token.hs b/src/Model/Token.hs
index f84fc970a..5b67782a5 100644
--- a/src/Model/Token.hs
+++ b/src/Model/Token.hs
@@ -2,8 +2,9 @@
 
 module Model.Token
   ( BearerToken(..)
+  , _tokenIdentifier, _tokenAuthority, _tokenRoutes, _tokenAddAuth, _tokenRestrictions, _tokenRestrictionIx, _tokenRestrictionAt, _tokenIssuedAt, _tokenIssuedBy, _tokenExpiresAt, _tokenStartsAt
   , bearerToken
-  , encodeToken, BearerTokenException(..), decodeToken
+  , encodeToken, BearerTokenException(..), decodeToken, jwtEncoding
   , tokenToJSON, tokenParseJSON, tokenParseJSON'
   , askJwt
   ) where
@@ -11,8 +12,9 @@ module Model.Token
 import ClassyPrelude.Yesod
 import Model
 import Settings
-import Utils (NTop(..), hoistMaybe)
+import Utils (NTop(..), hoistMaybe, assertM')
 import Utils.Lens hiding ((.=))
+import Data.Aeson.Lens (AsJSON(..))
 import Utils.Parameters
 
 import Yesod.Auth (AuthId)
@@ -29,7 +31,7 @@ import Data.HashSet (HashSet)
 
 import qualified Data.HashMap.Strict as HashMap
 
-import Data.Aeson.Types (Parser, (.:?), (.:))
+import Data.Aeson.Types (Parser, (.:?), (.:), (.!=))
 import qualified Data.Aeson as JSON
 import qualified Data.Aeson.Types as JSON
 import qualified Data.Aeson.Parser as JSON
@@ -45,26 +47,42 @@ import Control.Monad.Random (MonadRandom(..))
 import Control.Monad.Trans.Maybe (MaybeT(..))
 
 
+-- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to _whoever_ presents the token
 data BearerToken site = BearerToken
-  { tokenIdentifier :: TokenId -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
-  , tokenAuthority  :: AuthId site -- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
-  , tokenRoutes     :: Maybe (HashSet (Route site)) -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
-  , tokenAddAuth    :: Maybe AuthDNF -- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
-  , tokenIssuedAt   :: UTCTime
-  , tokenIssuedBy   :: InstanceId
+  { tokenIdentifier   :: TokenId -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
+  , tokenAuthority    :: AuthId site -- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
+  , tokenRoutes       :: Maybe (HashSet (Route site)) -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
+  , tokenAddAuth      :: Maybe AuthDNF -- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
+  , tokenRestrictions :: HashMap (Route site) Value -- ^ Tokens can be restricted to certain actions within the context of a route (i.e. creating an user only with a certain username, resetting a password only if the old matches a hash, ...)
+  , tokenIssuedAt     :: UTCTime
+  , tokenIssuedBy     :: InstanceId
   , tokenExpiresAt
-  , tokenStartsAt   :: Maybe UTCTime
+  , tokenStartsAt     :: Maybe UTCTime
   } deriving (Generic, Typeable)
 
 deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
 deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site)) => Read (BearerToken site)
 deriving instance (Show (AuthId site), Show (Route site)) => Show (BearerToken site)
 
+makeLenses_ ''BearerToken
+
+_tokenRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) a
+-- ^ Focus a singular restriction (by route) if it exists
+_tokenRestrictionIx route = _tokenRestrictions . ix route . _JSON
+
+_tokenRestrictionAt :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) (Maybe a)
+-- ^ Focus a singular restriction (by route) whether it exists, or not
+_tokenRestrictionAt route = _tokenRestrictions . at route . maybePrism _JSON
+
+
 tokenToJSON :: forall m.
                ( MonadHandler m
                , HasCryptoUUID (AuthId (HandlerSite m)) m
                , RenderRoute (HandlerSite m)
                ) => BearerToken (HandlerSite m) -> m Value
+-- ^ Encode a `BearerToken` analogously to `toJSON`
+--
+-- Monadic context is needed because `AuthId`s are encrypted during encoding
 tokenToJSON BearerToken{..} = do
   cID <- encrypt tokenAuthority :: m (CryptoUUID (AuthId (HandlerSite m)))
   let stdPayload = Jose.JwtClaims
@@ -80,6 +98,7 @@ tokenToJSON BearerToken{..} = do
     catMaybes [ Just $ "authority" .= cID
               , ("routes" .=) <$> tokenRoutes
               , ("add-auth" .=) <$> tokenAddAuth
+              , ("restrictions" .=) <$> assertM' (not . HashMap.null) tokenRestrictions
               ]
     ++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
 
@@ -90,12 +109,18 @@ tokenParseJSON :: forall site.
                   )
                => Value
                -> ReaderT CryptoIDKey Parser (BearerToken site)
+-- ^ Decode a `Value` to a `BearerToken` analogously to `parseJSON`
+--
+-- Monadic context is needed because `AuthId`s are encrypted during encoding
+--
+-- It's usually easier to use `tokenParseJSON'`
 tokenParseJSON v@(Object o) = do
   tokenAuthority' <- lift (o .: "authority") :: ReaderT CryptoIDKey Parser (CryptoUUID (AuthId site))
   tokenAuthority <- decrypt tokenAuthority'
 
-  tokenRoutes    <- lift $ o .:? "routes"
-  tokenAddAuth   <- lift $ o .:? "add-auth"
+  tokenRoutes        <- lift $ o .:? "routes"
+  tokenAddAuth       <- lift $ o .:? "add-auth"
+  tokenRestrictions  <- lift $ o .:? "restrictions" .!= HashMap.empty
   Jose.JwtClaims{..} <- lift $ parseJSON v
 
   let unIntDate (IntDate posix) = posixSecondsToUTCTime posix
@@ -118,6 +143,7 @@ tokenParseJSON' :: forall m.
                   , MonadCryptoKey m ~ CryptoIDKey
                   )
                => m (Value -> Parser (BearerToken (HandlerSite m)))
+-- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s
 tokenParseJSON' = do
   cidKey <- cryptoIDKey return
   return $ flip runReaderT cidKey . tokenParseJSON
@@ -135,6 +161,7 @@ bearerToken :: forall m.
             -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
             -> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
             -> m (BearerToken (HandlerSite m))
+-- ^ Smart constructor for `Bearertoken`, does not set route restrictions (due to polymorphism), use `_tokenRestrictionAt`
 bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do
   tokenIdentifier <- liftIO getRandom
   tokenIssuedAt <- liftIO getCurrentTime
@@ -149,11 +176,13 @@ bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsA
         = Just $ tDiff `addUTCTime` fromMaybe tokenIssuedAt tokenStartsAt
         | otherwise
         = Nothing
+      tokenRestrictions = HashMap.empty
 
   return BearerToken{..}
 
 
 jwtEncoding :: Jose.JwtEncoding
+-- ^ How should `Jwt`s be signed and/or encrypted?
 jwtEncoding = Jose.JwsEncoding Jose.HS256
 
 
@@ -165,6 +194,7 @@ encodeToken :: forall m.
                , RenderRoute (HandlerSite m)
                )
             => BearerToken (HandlerSite m) -> m Jwt
+-- ^ Call `tokenToJSON` and encode the result as a `Jwt` according to `jwtEncoding`
 encodeToken token = do
   payload <- Jose.Claims . toStrict . JSON.encode <$> tokenToJSON token
   JwkSet jwks <- getsYesod $ view jsonWebKeySet
@@ -172,9 +202,9 @@ encodeToken token = do
 
 
 data BearerTokenException
-  = BearerTokenJwtError Jose.JwtError
-  | BearerTokenUnsecured
-  | BearerTokenInvalidFormat String
+  = BearerTokenJwtError Jose.JwtError -- ^ An Error occurred in the underlying `Jwt`-Implementation
+  | BearerTokenUnsecured -- ^ `Jwt` is insufficiently secured (unsigned and not encrypted)
+  | BearerTokenInvalidFormat String -- ^ Content of the `Jwt` could not be parsed as a `BearerToken`
   | BearerTokenExpired | BearerTokenNotStarted
   deriving (Eq, Show, Generic, Typeable)
 
@@ -191,6 +221,7 @@ decodeToken :: forall m.
                , Hashable (Route (HandlerSite m))
                )
             => Jwt -> m (BearerToken (HandlerSite m))
+-- ^ Decode a `Jwt` according to `jwtEncoding` and call `tokenParseJSON`
 decodeToken (Jwt bs) = do
   JwkSet jwks <- getsYesod $ view jsonWebKeySet
   content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
@@ -208,11 +239,9 @@ decodeToken (Jwt bs) = do
   return token
 
 
-askJwt :: forall m.
-          ( MonadHandler m
-          )
+askJwt :: forall m. ( MonadHandler m )
        => m (Maybe Jwt)
--- | Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
+-- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
 askJwt = runMaybeT $ asum
   [ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
   , MaybeT $ lookupGlobalPostParam PostBearer

From 0b33becbc908e01964f2152d6133c2142c451400 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Wed, 10 Apr 2019 11:05:03 +0200
Subject: [PATCH 10/13] Add warning about _tokenRestrictionIx

---
 src/Model/Token.hs | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/src/Model/Token.hs b/src/Model/Token.hs
index 5b67782a5..d438965a4 100644
--- a/src/Model/Token.hs
+++ b/src/Model/Token.hs
@@ -68,6 +68,8 @@ makeLenses_ ''BearerToken
 
 _tokenRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) a
 -- ^ Focus a singular restriction (by route) if it exists
+--
+-- This /cannot/ be used to add restrictions, use `_tokenRestrictionAt` instead
 _tokenRestrictionIx route = _tokenRestrictions . ix route . _JSON
 
 _tokenRestrictionAt :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) (Maybe a)

From 9c3e413706f82dacb5716a7e4b1e269983fcbc94 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Wed, 10 Apr 2019 11:38:42 +0200
Subject: [PATCH 11/13] tokenRestrict & documentation

---
 src/Model/Token.hs | 31 +++++++++++++++++++++++--------
 1 file changed, 23 insertions(+), 8 deletions(-)

diff --git a/src/Model/Token.hs b/src/Model/Token.hs
index d438965a4..e3b3148cf 100644
--- a/src/Model/Token.hs
+++ b/src/Model/Token.hs
@@ -3,6 +3,7 @@
 module Model.Token
   ( BearerToken(..)
   , _tokenIdentifier, _tokenAuthority, _tokenRoutes, _tokenAddAuth, _tokenRestrictions, _tokenRestrictionIx, _tokenRestrictionAt, _tokenIssuedAt, _tokenIssuedBy, _tokenExpiresAt, _tokenStartsAt
+  , tokenRestrict
   , bearerToken
   , encodeToken, BearerTokenException(..), decodeToken, jwtEncoding
   , tokenToJSON, tokenParseJSON, tokenParseJSON'
@@ -47,13 +48,20 @@ import Control.Monad.Random (MonadRandom(..))
 import Control.Monad.Trans.Maybe (MaybeT(..))
 
 
--- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to _whoever_ presents the token
+-- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
 data BearerToken site = BearerToken
-  { tokenIdentifier   :: TokenId -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
-  , tokenAuthority    :: AuthId site -- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
-  , tokenRoutes       :: Maybe (HashSet (Route site)) -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
-  , tokenAddAuth      :: Maybe AuthDNF -- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
-  , tokenRestrictions :: HashMap (Route site) Value -- ^ Tokens can be restricted to certain actions within the context of a route (i.e. creating an user only with a certain username, resetting a password only if the old matches a hash, ...)
+  { tokenIdentifier   :: TokenId
+    -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
+  , tokenAuthority    :: AuthId site
+    -- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
+  , tokenRoutes       :: Maybe (HashSet (Route site))
+    -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
+  , tokenAddAuth      :: Maybe AuthDNF
+    -- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
+  , tokenRestrictions :: HashMap (Route site) Value
+    -- ^ Tokens can be restricted to certain actions within the context of a route (i.e. creating an user only with a certain username, resetting a password only if the old matches a hash, ...)
+    --
+    -- In general this is not encrypted; some care is required to not expose sensitive information to the bearer of the token
   , tokenIssuedAt     :: UTCTime
   , tokenIssuedBy     :: InstanceId
   , tokenExpiresAt
@@ -69,13 +77,20 @@ makeLenses_ ''BearerToken
 _tokenRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) a
 -- ^ Focus a singular restriction (by route) if it exists
 --
--- This /cannot/ be used to add restrictions, use `_tokenRestrictionAt` instead
+-- This /cannot/ be used to add restrictions, use `_tokenRestrictionAt` or `tokenRestrict` instead
 _tokenRestrictionIx route = _tokenRestrictions . ix route . _JSON
 
 _tokenRestrictionAt :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) (Maybe a)
 -- ^ Focus a singular restriction (by route) whether it exists, or not
 _tokenRestrictionAt route = _tokenRestrictions . at route . maybePrism _JSON
 
+tokenRestrict :: (ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> a -> BearerToken site -> BearerToken site
+-- ^ Add a restriction to a `BearerToken`
+--
+-- If a restriction already exists for the targeted route, it's silently overwritten
+tokenRestrict route (toJSON -> resVal) = over _tokenRestrictions $ HashMap.insert route resVal
+
+
 
 tokenToJSON :: forall m.
                ( MonadHandler m
@@ -163,7 +178,7 @@ bearerToken :: forall m.
             -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
             -> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
             -> m (BearerToken (HandlerSite m))
--- ^ Smart constructor for `Bearertoken`, does not set route restrictions (due to polymorphism), use `_tokenRestrictionAt`
+-- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict`
 bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do
   tokenIdentifier <- liftIO getRandom
   tokenIssuedAt <- liftIO getCurrentTime

From ea658f65ce25ddc85c225e88825698c6906e6b02 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Fri, 12 Apr 2019 14:08:55 +0200
Subject: [PATCH 12/13] Lecturer invitations via e-mail

---
 messages/uniworx/de.msg                  |  14 +-
 models/courses                           |   6 +
 routes                                   |   1 +
 src/Database/Persist/Types/Instances.hs  |  12 ++
 src/Foundation.hs                        |   6 +-
 src/Handler/Course.hs                    | 155 +++++++++++++++++++----
 src/Import/NoFoundation.hs               |   1 +
 src/Jobs.hs                              |   1 +
 src/Jobs/Handler/LecturerInvitation.hs   |  43 +++++++
 src/Jobs/Types.hs                        |   3 +
 src/Model.hs                             |   2 +
 src/Model/Types.hs                       |   2 +
 src/Utils/DB.hs                          |   6 +
 templates/courseLecInvite.hamlet         |   3 +
 templates/mail/lecturerInvitation.hamlet |  11 ++
 15 files changed, 237 insertions(+), 29 deletions(-)
 create mode 100644 src/Database/Persist/Types/Instances.hs
 create mode 100644 src/Jobs/Handler/LecturerInvitation.hs
 create mode 100644 templates/courseLecInvite.hamlet
 create mode 100644 templates/mail/lecturerInvitation.hamlet

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index a2b384c03..06715ee26 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -11,6 +11,8 @@ BtnCandidatesInfer: Studienfachzuordnung automatisch lernen
 BtnCandidatesDeleteConflicts: Konflikte löschen
 BtnCandidatesDeleteAll: Alle Beobachtungen löschen
 BtnResetTokens: Authorisierungs-Tokens invalidieren
+BtnLecInvAccept: Annehmen
+BtnLecInvDecline: Ablehnen
 
 Aborted: Abgebrochen
 Remarks: Hinweise
@@ -523,6 +525,9 @@ MailEditNotifications: Benachrichtigungen ein-/ausschalten
 MailSubjectSupport: Supportanfrage
 MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject}
 
+MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursverwalter
+CourseLecturerInvitationAcceptDecline: Einladung annehmen/ablehnen
+
 SheetGrading: Bewertung
 SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
 SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
@@ -745,4 +750,11 @@ DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus de
 MassInputAddDimension: Hinzufügen
 MassInputDeleteCell: Entfernen
 
-NavigationFavourites: Favoriten
\ No newline at end of file
+NavigationFavourites: Favoriten
+
+EmailInvitationWarning: Dem System ist kein Nutzer mit dieser Addresse bekannt. Es wird eine Einladung per E-Mail versandt.
+
+LecturerInvitationAccepted lType@Text csh@CourseShorthand: Sie wurden als #{lType} für #{csh} eingetragen
+LecturerInvitationDeclined csh@CourseShorthand: Sie haben die Einladung, Kursverwalter für #{csh} zu werden, abgelehnt
+CourseLecInviteHeading courseName@Text: Einladung zum Kursverwalter für #{courseName}
+CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu sein.
\ No newline at end of file
diff --git a/models/courses b/models/courses
index 4fcf67d65..45166d7d5 100644
--- a/models/courses
+++ b/models/courses
@@ -35,6 +35,12 @@ Lecturer                       -- course ownership
     course       CourseId
     type         LecturerType  default='"lecturer"'
     UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table
+LecturerInvitation json        -- preliminary course ownership for when a token to become `Lecturer` is sent to an email
+    email        (CI Text)
+    course       CourseId
+    type         LecturerType Maybe
+    UniqueLecturerInvitation email course
+    deriving Eq Ord Read Show Generic Typeable
 CourseParticipant                      -- course enrolement
     course       CourseId
     user         UserId
diff --git a/routes b/routes
index 6e4a39302..87401b00d 100644
--- a/routes
+++ b/routes
@@ -76,6 +76,7 @@
   /                           CShowR          GET             !free
   /register                   CRegisterR          POST        !timeANDcapacity
   /edit                       CEditR          GET POST
+  /lecturer-invite/#UserEmail CLecInviteR     GET POST
   /delete                     CDeleteR        GET POST        !lecturerANDempty
   /users                      CUsersR         GET POST
   /users/#CryptoUUIDUser      CUserR          GET POST        !lecturerANDparticipant
diff --git a/src/Database/Persist/Types/Instances.hs b/src/Database/Persist/Types/Instances.hs
new file mode 100644
index 000000000..db5957d54
--- /dev/null
+++ b/src/Database/Persist/Types/Instances.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Database.Persist.Types.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Database.Persist.Types
+
+instance (Hashable record, Hashable (Key record)) => Hashable (Entity record) where
+  s `hashWithSalt` Entity{..} = s `hashWithSalt` entityKey `hashWithSalt` entityVal
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 1eebfd41c..38c2052c9 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -487,11 +487,13 @@ tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return r
   User{userTokensIssuedAfter} <- lift $ get404 tokenAuthority
   guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
 
-  authorityVal <- evalAccessFor (Just tokenAuthority) route isWrite
+  authorityVal <- do
+    dnf <- either throwM return $ routeAuthTags route
+    fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) dnf (Just tokenAuthority) route isWrite
   guardExceptT (is _Authorized authorityVal) authorityVal
 
   whenIsJust tokenAddAuth $ \addDNF -> do
-    additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) addDNF mAuthId route isWrite
+    additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) addDNF mAuthId route isWrite
     guardExceptT (is _Authorized additionalVal) additionalVal
 
   return Authorized
diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs
index 98016ca8e..848faf0e7 100644
--- a/src/Handler/Course.hs
+++ b/src/Handler/Course.hs
@@ -33,6 +33,8 @@ import qualified Database.Esqueleto as E
 
 import Text.Blaze.Html.Renderer.Text (renderHtml)
 
+import Jobs.Queue
+
 -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
 type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
 
@@ -416,7 +418,7 @@ getCourseNewR = do
           return course
       template <- case listToMaybe oldCourses of
         (Just oldTemplate) ->
-            let newTemplate = courseToForm oldTemplate [] in
+            let newTemplate = courseToForm oldTemplate [] [] in
             return $ Just $ newTemplate
                 { cfCourseId   = Nothing
                 , cfTerm       = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
@@ -445,13 +447,14 @@ postCEditR = pgCEditR
 
 pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 pgCEditR tid ssh csh = do
-  courseLecs <- runDB $ do
-      mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
-      mbLecs   <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
-      return $ (,) <$> mbCourse <*> mbLecs
+  courseData <- runDB $ do
+      mbCourse     <- getBy (TermSchoolCourseShort tid ssh csh)
+      mbLecs       <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
+      mbLecInvites <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerInvitationCourse ==. entityKey course] [Asc LecturerInvitationType]
+      return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
   -- IMPORTANT: both GET and POST Handler must use the same template,
   --    since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
-  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ uncurry courseToForm <$> courseLecs
+  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData
 
 
 getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@@ -479,7 +482,7 @@ courseEditHandler miButtonAction mbCourseForm = do
         , cfTerm     = tid
         } -> do -- create new course
           now <- liftIO getCurrentTime
-          insertOkay <- runDB $ do
+          insertOkay <- runDBJobs $ do
             insertOkay <- insertUnique Course
               { courseName            = cfName     res
               , courseDescription     = cfDesc     res
@@ -495,7 +498,11 @@ courseEditHandler miButtonAction mbCourseForm = do
               , courseDeregisterUntil = cfDeRegUntil res
               }
             whenIsJust insertOkay $ \cid -> do
-                forM_ (cfLecturers res) (\(lid,lty) -> insert_  $ Lecturer lid cid lty)
+                forM_ (cfLecturers res) $ \case
+                  Right (lid, lty) -> insert_  $ Lecturer lid cid lty
+                  Left (lEmail, mLTy) -> do
+                    insert_ $ LecturerInvitation lEmail cid mLTy
+                    queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy
                 insert_ $ CourseEdit aid now cid
             return insertOkay
           case insertOkay of
@@ -513,7 +520,7 @@ courseEditHandler miButtonAction mbCourseForm = do
         } -> do -- edit existing course
           now <- liftIO getCurrentTime
           -- addMessage "debug" [shamlet| #{show res}|]
-          success <- runDB $ do
+          success <- runDBJobs $ do
             old <- get cid
             case old of
               Nothing -> addMessageI Error MsgInvalidInput $> False
@@ -536,7 +543,15 @@ courseEditHandler miButtonAction mbCourseForm = do
                   (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
                   Nothing  -> do
                     deleteWhere [LecturerCourse ==. cid]
-                    forM_ (cfLecturers res) (\(lid,lty) -> insert_  $ Lecturer lid cid lty)
+                    forM_ (cfLecturers res) $ \case
+                      Right (lid, lty) -> insert_  $ Lecturer lid cid lty
+                      Left (lEmail, mLTy) -> do
+                        insertRes <- insertUnique (LecturerInvitation lEmail cid mLTy)
+                        case insertRes of
+                          Just _  ->
+                            queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy
+                          Nothing -> 
+                            updateBy (UniqueLecturerInvitation lEmail cid) [ LecturerInvitationType =. mLTy ]
                     insert_ $ CourseEdit aid now cid
                     addMessageI Success $ MsgCourseEditOk tid ssh csh
                     return True
@@ -564,11 +579,11 @@ data CourseForm = CourseForm
         , cfRegFrom    :: Maybe UTCTime
         , cfRegTo      :: Maybe UTCTime
         , cfDeRegUntil :: Maybe UTCTime
-        , cfLecturers  :: [(UserId, LecturerType)]
+        , cfLecturers  :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
         }
 
-courseToForm :: Entity Course -> [Lecturer] -> CourseForm
-courseToForm (Entity cid Course{..}) lecs = CourseForm
+courseToForm :: Entity Course -> [Lecturer] -> [LecturerInvitation] -> CourseForm
+courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
     { cfCourseId   = Just cid
     , cfName       = courseName
     , cfDesc       = courseDescription
@@ -582,7 +597,8 @@ courseToForm (Entity cid Course{..}) lecs = CourseForm
     , cfRegFrom    = courseRegisterFrom
     , cfRegTo      = courseRegisterTo
     , cfDeRegUntil = courseDeregisterUntil
-    , cfLecturers  = [(lecturerUser, lecturerType) | Lecturer{..} <- lecs]
+    , cfLecturers  = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
+                  ++ [Left (lecturerInvitationEmail, lecturerInvitationType) | LecturerInvitation{..} <- lecInvites ]
     }
 
 makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
@@ -609,29 +625,46 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
                 | otherwise ->  termsSetField [cfTerm cform]
           _allOtherCases -> return termsAllowedField
 
-    let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition UserId -> FormResult (Map ListPosition UserId)))
+    let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
         miAdd _ _ nudge btn = Just $ \csrf -> do
           (addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing
           addRes'  <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk
           let addRes'' = case (,) <$> addRes <*> addRes' of
-                FormSuccess (email, Nothing) -> FormFailure [ mr . MsgEMailUnknown $ CI.mk email ]
-                FormSuccess (email, Just lid) -> FormSuccess $ \prev -> if
-                  | lid `elem` Map.elems prev -> FormFailure [ mr . MsgCourseLecturerAlreadyAdded $ CI.mk email ]
-                  | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) lid
+                FormSuccess (CI.mk -> email, mLid) ->
+                  let new = maybe (Left email) Right mLid
+                  in  FormSuccess $ \prev -> if
+                        | new `elem` Map.elems prev -> FormFailure [ mr $ MsgCourseLecturerAlreadyAdded email ] -- Since there is only ever one email address associated with any user, the case where a @Left email@ corresponds to a @Right lid@ can never occur (at least logically; might still be the same person, of course)
+                        | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) new
                 FormFailure errs -> FormFailure errs
                 FormMissing -> FormMissing
               addView'  = toWidget csrf >> fvInput addView >> fvInput btn
           return (addRes'', addView')
 
-        miCell :: ListPosition -> UserId -> Maybe LecturerType -> (Text -> Text) -> Form LecturerType
-        miCell _ lid defType nudge = \csrf -> do
-          (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
+        miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
+        miCell _ (Right lid) defType nudge = \csrf -> do
+          (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType)
           User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
           let lrwView' = [whamlet|$newline never
                   #{csrf}
                   ^{nameEmailWidget userEmail userDisplayName userSurname} #
                   ^{fvInput lrwView}
                 |]
+          return (Just <$> lrwRes,lrwView')
+        miCell _ (Left lEmail) defType nudge = \csrf -> do
+          (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
+          let lrwView' = [whamlet|
+                           $newline never
+                           #{csrf}
+                           <span style="font-family:monospace">
+                             #{lEmail}
+                            #
+                           <div .tooltip>
+                             <div .tooltip__handle>
+                             <div .tooltip__content>
+                               _{MsgEmailInvitationWarning}
+                            #
+                           ^{fvInput lrwView}
+                         |]
           return (lrwRes,lrwView')
 
         miDelete :: ListLength   -- ^ Current shape
@@ -643,13 +676,22 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
         miAllowAdd _ _ _ = True
 
 
-        lecturerForm :: AForm Handler [(UserId,LecturerType)]
-        lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) Map.elems $ massInput
+        lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
+        lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
                 MassInput{..}
                 (fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical)
                 True
-                (Just . Map.fromList . zip [0..] $ maybe [(uid, CourseLecturer)] cfLecturers template)
+                (Just . Map.fromList . zip [0..] $ maybe [(Right uid, Just CourseLecturer)] (map unliftEither . cfLecturers) template)
                 mempty
+          where
+            liftEither :: (Either UserEmail UserId, Maybe LecturerType) -> Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)
+            liftEither (Right lid  , Just lType) = Right (lid   , lType )
+            liftEither (Left lEmail, mLType    ) = Left  (lEmail, mLType)
+            liftEither _                         = error "liftEither: lecturerForm produced output it should not have been able to"
+
+            unliftEither :: Either (UserEmail, Maybe LecturerType) (UserId, LecturerType) -> (Either UserEmail UserId, Maybe LecturerType)
+            unliftEither (Right (lid   , lType )) = (Right lid  , Just lType)
+            unliftEither (Left  (lEmail, mLType)) = (Left lEmail, mLType    )
 
     (newRegFrom,newRegTo,newDeRegUntil) <- case template of
         (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
@@ -717,7 +759,7 @@ validateCourse CourseForm{..} = do
           ( NTop cfRegFrom <= NTop cfDeRegUntil
           , MsgCourseDeregistrationEndMustBeAfterStart
           )
-        , ( maybe (any ((== uid) . fst) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
+        , ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
           , MsgCourseUserMustBeLecturer
           )
         ] ]
@@ -1039,3 +1081,64 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 -- If they are shared, adjust MsgCourseUserNoteTooltip
 getCNotesR  = error "CNotesR: Not implemented"
 postCNotesR = error "CNotesR: Not implemented"
+
+
+data ButtonLecInvite = BtnLecInvAccept | BtnLecInvDecline
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe ButtonLecInvite
+instance Finite ButtonLecInvite
+
+nullaryPathPiece ''ButtonLecInvite $ camelToPathPiece' 3
+embedRenderMessage ''UniWorX ''ButtonLecInvite id
+
+instance Button UniWorX ButtonLecInvite where
+  btnClasses BtnLecInvAccept = [BCIsButton, BCPrimary]
+  btnClasses BtnLecInvDecline = [BCIsButton, BCDanger]
+
+getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> UserEmail -> Handler Html
+getCLecInviteR = postCLecInviteR
+postCLecInviteR tid ssh csh email = do
+  uid <- requireAuthId
+  (Entity cid Course{..}, Entity liId LecturerInvitation{..}) <- runDB $ do
+    cRes@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
+    iRes <- getBy404 $ UniqueLecturerInvitation email cid
+    return (cRes, iRes)
+
+  ((btnResult, btnInnerWidget), btnEncoding) <- runFormPost $ \csrf -> do
+    (ltRes, ltView) <- case lecturerInvitationType of
+      Nothing -> mreq (selectField optionsFinite) "" Nothing
+      Just lType -> mforced (selectField optionsFinite) "" lType
+    (btnRes, btnWdgt) <- buttonForm mempty
+    return ((,) <$> ltRes <*> btnRes, toWidget csrf <> fvInput ltView <> btnWdgt)
+  mJwt <- askJwt
+
+  let btnWidget = wrapForm btnInnerWidget' def
+        { formEncoding = btnEncoding
+        , formAction = Just . SomeRoute . CourseR tid ssh csh $ CLecInviteR email
+        , formSubmit = FormNoSubmit
+        }
+      btnInnerWidget'
+        = [whamlet|
+            $newline never
+            $maybe jwt <- mJwt
+              <input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece jwt}>
+            ^{btnInnerWidget}
+          |]
+
+  formResult btnResult $ \case
+    (lType, BtnLecInvAccept) -> do
+      runDB $ do
+        delete liId
+        insert_ $ Lecturer uid cid lType
+      MsgRenderer mr <- getMsgRenderer
+      addMessageI Success $ MsgLecturerInvitationAccepted (mr lType) csh
+      redirect $ CourseR tid ssh csh CShowR
+    (_, BtnLecInvDecline) -> do
+      runDB $
+        delete liId
+      addMessageI Info $ MsgLecturerInvitationDeclined csh
+      redirect HomeR
+
+  siteLayoutMsg (MsgCourseLecInviteHeading $ CI.original courseName) $ do
+    setTitleI . MsgCourseLecInviteHeading $ CI.original courseName
+    $(widgetFile "courseLecInvite")
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index fd37d73bc..cae93d5f8 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -64,6 +64,7 @@ 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)
diff --git a/src/Jobs.hs b/src/Jobs.hs
index 04df2686c..9b06c3a1c 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -59,6 +59,7 @@ import Jobs.Handler.QueueNotification
 import Jobs.Handler.HelpRequest
 import Jobs.Handler.SetLogSettings
 import Jobs.Handler.DistributeCorrections
+import Jobs.Handler.LecturerInvitation
 
   
 data JobQueueException = JInvalid QueuedJobId QueuedJob
diff --git a/src/Jobs/Handler/LecturerInvitation.hs b/src/Jobs/Handler/LecturerInvitation.hs
new file mode 100644
index 000000000..098ccbb61
--- /dev/null
+++ b/src/Jobs/Handler/LecturerInvitation.hs
@@ -0,0 +1,43 @@
+module Jobs.Handler.LecturerInvitation
+  ( dispatchJobLecturerInvitation
+  ) where
+
+import Import
+
+import Text.Hamlet
+
+import qualified Data.HashSet as HashSet
+
+import qualified Data.CaseInsensitive as CI
+
+import Utils.Lens
+
+import Control.Monad.Trans.Maybe
+
+
+dispatchJobLecturerInvitation :: UserId -> LecturerInvitation -> Handler ()
+dispatchJobLecturerInvitation jInviter jLecturerInvitation@LecturerInvitation{..} = do
+  ctx <- runDB . runMaybeT $ do
+    course <- MaybeT $ get lecturerInvitationCourse
+    void . MaybeT $ getByValue jLecturerInvitation
+    user <- MaybeT $ get jInviter
+    return (course, user)
+
+  case ctx of
+    Just (Course{..}, User{..}) -> do
+      let baseRoute = CourseR courseTerm courseSchool courseShorthand $ CLecInviteR lecturerInvitationEmail
+      jwt <- encodeToken =<< bearerToken jInviter (Just $ HashSet.singleton baseRoute) Nothing Nothing Nothing
+      let
+        invitationUrl :: SomeRoute UniWorX
+        invitationUrl = SomeRoute (baseRoute, [(toPathPiece GetBearer, toPathPiece jwt)])
+      invitationUrl' <- toTextUrl invitationUrl
+
+      mailT def $ do
+        _mailTo .= [Address Nothing (CI.original $ lecturerInvitationEmail)]
+        replaceMailHeader "Reply-To" . Just . renderAddress $ Address (Just userDisplayName) (CI.original userEmail)
+        replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+        setSubjectI $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
+      
+        addPart ($(ihamletFile "templates/mail/lecturerInvitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
+    Nothing -> runDB .
+      deleteBy $ UniqueLecturerInvitation lecturerInvitationEmail lecturerInvitationCourse
diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs
index dc29a9e7a..42ce48824 100644
--- a/src/Jobs/Types.hs
+++ b/src/Jobs/Types.hs
@@ -23,6 +23,9 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
                           }
          | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
          | JobDistributeCorrections { jSheet :: SheetId }
+         | JobLecturerInvitation { jInviter :: UserId
+                                 , jLecturerInvitation :: LecturerInvitation
+                                 }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
                   | NotificationSheetActive { nSheet :: SheetId }
diff --git a/src/Model.hs b/src/Model.hs
index 9210edfde..1b16cd35e 100644
--- a/src/Model.hs
+++ b/src/Model.hs
@@ -40,5 +40,7 @@ deriving instance Eq (Unique Sheet)
 -- Automatically generated (i.e. numeric) ids are already taken care of
 deriving instance Binary (Key Term)
 
+instance Hashable LecturerInvitation
+
 submissionRatingDone :: Submission -> Bool
 submissionRatingDone Submission{..} = isJust submissionRatingTime
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 21672d9d2..00bda42a1 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -824,6 +824,8 @@ deriveJSON  defaultOptions
   } ''LecturerType
 derivePersistFieldJSON ''LecturerType
 
+instance Hashable LecturerType
+
 
 -- Type synonyms
 
diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs
index cb8b80d4e..9700dd88f 100644
--- a/src/Utils/DB.hs
+++ b/src/Utils/DB.hs
@@ -35,6 +35,12 @@ existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity r
   => Key record -> ReaderT backend m Bool
 existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record
 
+updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
+  => Unique record -> [Update record] -> ReaderT backend m ()
+updateBy uniq updates = do
+  key <- getKeyBy uniq
+  for_ key $ flip update updates
+
 myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq  record which is not needed anyway)
     :: (MonadIO m
        ,Eq (Unique record)
diff --git a/templates/courseLecInvite.hamlet b/templates/courseLecInvite.hamlet
new file mode 100644
index 000000000..408556fb7
--- /dev/null
+++ b/templates/courseLecInvite.hamlet
@@ -0,0 +1,3 @@
+<p>
+  _{MsgCourseLecInviteExplanation}
+^{btnWidget}
diff --git a/templates/mail/lecturerInvitation.hamlet b/templates/mail/lecturerInvitation.hamlet
new file mode 100644
index 000000000..9de17cc39
--- /dev/null
+++ b/templates/mail/lecturerInvitation.hamlet
@@ -0,0 +1,11 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+  <body>
+    <p>
+      _{MsgCourseLecInviteExplanation}
+    <p>
+      <a href=#{invitationUrl'}>
+        _{MsgCourseLecturerInvitationAcceptDecline}

From 60e95e8ef7bfe05c4f795e94ad834a5e2e7a3294 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Wed, 17 Apr 2019 11:35:27 +0200
Subject: [PATCH 13/13] Cleanup & (maybe|require)BearerToken

---
 config/settings.yml                  |   1 +
 messages/uniworx/de.msg              |   2 +
 package.yaml                         |   1 +
 src/Data/Aeson/Types/Instances.hs    |  10 +-
 src/Data/HashMap/Strict/Instances.hs |  16 +++
 src/Data/HashSet/Instances.hs        |  17 +++
 src/Data/NonNull/Instances.hs        |   8 ++
 src/Data/Time/Clock/Instances.hs     |  26 ++++
 src/Data/Vector/Instances.hs         |  18 +++
 src/Foundation.hs                    |  78 +++++++-----
 src/Handler/Admin.hs                 |   7 +-
 src/Handler/Course.hs                |  12 +-
 src/Handler/Profile.hs               |  11 +-
 src/Handler/Utils/Tokens.hs          |  27 +++++
 src/Import.hs                        |   1 -
 src/Import/NoFoundation.hs           |   9 ++
 src/Language/Haskell/TH/Instances.hs |  14 +++
 src/Mail.hs                          |   2 +
 src/Model/{Token.hs => Tokens.hs}    | 147 +++-------------------
 src/Model/Types.hs                   |   9 +-
 src/Settings.hs                      |  21 +++-
 src/Utils.hs                         |  21 ++++
 src/Utils/Lens.hs                    |  12 +-
 src/Utils/Tokens.hs                  | 174 +++++++++++++++++++++++++++
 24 files changed, 447 insertions(+), 197 deletions(-)
 create mode 100644 src/Data/HashMap/Strict/Instances.hs
 create mode 100644 src/Data/HashSet/Instances.hs
 create mode 100644 src/Data/Time/Clock/Instances.hs
 create mode 100644 src/Data/Vector/Instances.hs
 create mode 100644 src/Handler/Utils/Tokens.hs
 create mode 100644 src/Language/Haskell/TH/Instances.hs
 rename src/Model/{Token.hs => Tokens.hs} (51%)
 create mode 100644 src/Utils/Tokens.hs

diff --git a/config/settings.yml b/config/settings.yml
index 9479d002a..287baf0b3 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -28,6 +28,7 @@ notification-collate-delay: 300
 notification-expiration: 259201
 session-timeout: 7200
 jwt-expiration: 604800
+jwt-encoding: HS256
 maximum-content-length: 52428800
 
 log-settings:
diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index fb521065d..c42f8cb0c 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -214,6 +214,8 @@ UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen.
 UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.
 UnauthorizedTokenInvalid: Ihr Authorisierungs-Token konnte nicht verarbeitet werden.
 UnauthorizedTokenInvalidRoute: Ihr Authorisierungs-Token ist auf dieser Unterseite nicht gültig.
+UnauthorizedTokenInvalidAuthority: Ihr Authorisierungs-Token basiert auf den Rechten eines Nutzers, der nicht mehr existiert.
+UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden.
 UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
 UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
 UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
diff --git a/package.yaml b/package.yaml
index f6d487376..47917503c 100644
--- a/package.yaml
+++ b/package.yaml
@@ -85,6 +85,7 @@ dependencies:
   - scientific
   - tz
   - system-locale
+  - th-lift
   - th-lift-instances
   - gitrev
   - Glob
diff --git a/src/Data/Aeson/Types/Instances.hs b/src/Data/Aeson/Types/Instances.hs
index f785576f2..66ff1df61 100644
--- a/src/Data/Aeson/Types/Instances.hs
+++ b/src/Data/Aeson/Types/Instances.hs
@@ -6,9 +6,17 @@ module Data.Aeson.Types.Instances
 
 import ClassyPrelude
 
-import Data.Aeson.Types (Parser)
+import Data.Aeson.Types (Parser, Value)
 import Control.Monad.Catch
 
+import Data.Binary (Binary)
+
+import Data.HashMap.Strict.Instances ()
+import Data.Vector.Instances ()
+
 
 instance MonadThrow Parser where
   throwM = fail . show
+
+
+instance Binary Value
diff --git a/src/Data/HashMap/Strict/Instances.hs b/src/Data/HashMap/Strict/Instances.hs
new file mode 100644
index 000000000..7d56f03a8
--- /dev/null
+++ b/src/Data/HashMap/Strict/Instances.hs
@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.HashMap.Strict.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Binary (Binary(..))
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+
+
+instance (Binary k, Binary v, Hashable k, Eq k) => Binary (HashMap k v) where
+  put = put . HashMap.toList
+  get = HashMap.fromList <$> get
diff --git a/src/Data/HashSet/Instances.hs b/src/Data/HashSet/Instances.hs
new file mode 100644
index 000000000..3fc16cd43
--- /dev/null
+++ b/src/Data/HashSet/Instances.hs
@@ -0,0 +1,17 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.HashSet.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HashSet
+
+import Data.Binary (Binary(..))
+
+
+instance (Binary a, Hashable a, Eq a) => Binary (HashSet a) where
+  get = HashSet.fromList <$> get
+  put = put . HashSet.toList
diff --git a/src/Data/NonNull/Instances.hs b/src/Data/NonNull/Instances.hs
index 1a11a66d9..55981d6ff 100644
--- a/src/Data/NonNull/Instances.hs
+++ b/src/Data/NonNull/Instances.hs
@@ -8,6 +8,9 @@ import ClassyPrelude
 
 import Data.Aeson
 
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
 
 instance ToJSON a => ToJSON (NonNull a) where
   toJSON = toJSON . toNullable
@@ -18,3 +21,8 @@ instance (FromJSON a, MonoFoldable a) => FromJSON (NonNull a) where
 
 instance Hashable a => Hashable (NonNull a) where
   hashWithSalt s = hashWithSalt s . toNullable
+
+
+instance (Binary a, MonoFoldable a) => Binary (NonNull a) where
+  get = Binary.get >>= maybe (fail "Expected non-empty structure") return . fromNullable
+  put = Binary.put . toNullable
diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs
new file mode 100644
index 000000000..1783ac465
--- /dev/null
+++ b/src/Data/Time/Clock/Instances.hs
@@ -0,0 +1,26 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Time.Clock.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Time.Clock
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+
+deriving instance Generic 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
+  
+instance Binary UTCTime
diff --git a/src/Data/Vector/Instances.hs b/src/Data/Vector/Instances.hs
new file mode 100644
index 000000000..953130328
--- /dev/null
+++ b/src/Data/Vector/Instances.hs
@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Vector.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+
+instance Binary a => Binary (Vector a) where
+  get = Vector.fromList <$> Binary.get
+  put = Binary.put . Vector.toList
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 40dc1246c..cc919e8b4 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -15,7 +15,6 @@ import Auth.LDAP
 import Auth.PWHash
 import Auth.Dummy
 import Jobs.Types
-import Model.Token
 
 import qualified Network.Wai as W (pathInfo)
 
@@ -57,7 +56,7 @@ import Data.Conduit.List (sourceList)
 
 import qualified Database.Esqueleto as E
 
-import Control.Monad.Except (MonadError(..), runExceptT)
+import Control.Monad.Except (MonadError(..), ExceptT, runExceptT)
 import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Trans.Reader (runReader, mapReaderT)
 import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
@@ -152,7 +151,7 @@ mkYesodData "UniWorX" $(parseRoutesFile "routes")
 deriving instance Generic (Route UniWorX)
 
 -- | Convenient Type Synonyms:
-type DB a = YesodDB UniWorX a
+type DB = YesodDB UniWorX
 type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
 type MsgRenderer = MsgRendererS UniWorX -- see Utils
 type MailM a = MailT (HandlerT UniWorX IO) a
@@ -403,12 +402,6 @@ newtype InvalidAuthTag = InvalidAuthTag Text
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 instance Exception InvalidAuthTag
 
-data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-instance Universe SessionAuthTags
-instance Finite SessionAuthTags
-nullaryPathPiece ''SessionAuthTags (camelToPathPiece' 1)
-
 
 data AccessPredicate
   = APPure     (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
@@ -453,6 +446,47 @@ trueAP  = APPure . const . const . const $ trueAR <$> ask
 falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
 
 
+askTokenUnsafe :: forall m.
+                  ( MonadHandler m
+                  , HandlerSite m ~ UniWorX
+                  , MonadLogger m
+                  , MonadCatch m
+                  )
+               => ExceptT AuthResult m (BearerToken (UniWorX))
+-- | This performs /no/ meaningful validation of the `BearerToken`
+--
+-- Use `Handler.Utils.Tokens.requireBearerToken` or `Handler.Utils.Tokens.maybeBearerToken` instead
+askTokenUnsafe = $cachedHere $ do
+  jwt <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askJwt
+  catch (decodeToken jwt) $ \case
+    BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
+    BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
+    other -> do
+      $logWarnS "AuthToken" $ tshow other
+      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'
+  where
+    validateToken' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult
+    validateToken' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
+      guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
+
+      User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority
+      guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
+
+      authorityVal <- do
+        dnf <- either throwM return $ routeAuthTags route
+        fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) dnf (Just tokenAuthority) route isWrite
+      guardExceptT (is _Authorized authorityVal) authorityVal
+
+      whenIsJust tokenAddAuth $ \addDNF -> do
+        additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) addDNF mAuthId route isWrite
+        guardExceptT (is _Authorized additionalVal) additionalVal
+
+      return Authorized
+
+
 tagAccessPredicate :: AuthTag -> AccessPredicate
 tagAccessPredicate AuthFree = trueAP
 tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
@@ -474,30 +508,8 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
     adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
     guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
     return Authorized
-tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ do
-  jwt <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askJwt
-  BearerToken{..} <- catch (decodeToken jwt) $ \case
-    BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
-    BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
-    other -> do
-      $logWarnS "AuthToken" $ tshow other
-      throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid
-
-  guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
-
-  User{userTokensIssuedAfter} <- lift $ get404 tokenAuthority
-  guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
-
-  authorityVal <- do
-    dnf <- either throwM return $ routeAuthTags route
-    fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) dnf (Just tokenAuthority) route isWrite
-  guardExceptT (is _Authorized authorityVal) authorityVal
-
-  whenIsJust tokenAddAuth $ \addDNF -> do
-    additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) addDNF mAuthId route isWrite
-    guardExceptT (is _Authorized additionalVal) additionalVal
-
-  return Authorized
+tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
+  lift . validateToken mAuthId route isWrite =<< askTokenUnsafe
 tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
   AdminHijackUserR cID -> exceptT return return $ do
     myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index 4e4b07eee..32f8db822 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -286,9 +286,6 @@ instance Button UniWorX ButtonAdminStudyTerms where
   btnClasses BtnCandidatesDeleteAll       = [BCIsButton, BCDanger]
 -- END Button needed only here
 
-sessionKeyNewStudyTerms :: Text
-sessionKeyNewStudyTerms = "key-new-study-terms"
-
 getAdminFeaturesR, postAdminFeaturesR :: Handler Html
 getAdminFeaturesR = postAdminFeaturesR
 postAdminFeaturesR = do
@@ -304,7 +301,7 @@ postAdminFeaturesR = do
         unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous
         unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant
         let newKeys = map (StudyTermsKey' . fst) infAccepted
-        setSessionJson sessionKeyNewStudyTerms newKeys
+        setSessionJson SessionNewStudyTerms newKeys
         if  | null infAccepted
               -> addMessageI Info      MsgNoCandidatesInferred
             | otherwise
@@ -322,7 +319,7 @@ postAdminFeaturesR = do
         Candidates.conflicts
       _other -> runDB Candidates.conflicts
 
-    newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson sessionKeyNewStudyTerms
+    newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
     (   (degreeResult,degreeTable)
       , (studyTermsResult,studytermsTable)
       , ((), candidateTable)) <- runDB $ (,,)
diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs
index 848faf0e7..c084c139f 100644
--- a/src/Handler/Course.hs
+++ b/src/Handler/Course.hs
@@ -1104,26 +1104,18 @@ postCLecInviteR tid ssh csh email = do
     iRes <- getBy404 $ UniqueLecturerInvitation email cid
     return (cRes, iRes)
 
-  ((btnResult, btnInnerWidget), btnEncoding) <- runFormPost $ \csrf -> do
+  ((btnResult, btnInnerWidget), btnEncoding) <- runFormPost . formEmbedJwtPost $ \csrf -> do
     (ltRes, ltView) <- case lecturerInvitationType of
       Nothing -> mreq (selectField optionsFinite) "" Nothing
       Just lType -> mforced (selectField optionsFinite) "" lType
     (btnRes, btnWdgt) <- buttonForm mempty
     return ((,) <$> ltRes <*> btnRes, toWidget csrf <> fvInput ltView <> btnWdgt)
-  mJwt <- askJwt
 
-  let btnWidget = wrapForm btnInnerWidget' def
+  let btnWidget = wrapForm btnInnerWidget def
         { formEncoding = btnEncoding
         , formAction = Just . SomeRoute . CourseR tid ssh csh $ CLecInviteR email
         , formSubmit = FormNoSubmit
         }
-      btnInnerWidget'
-        = [whamlet|
-            $newline never
-            $maybe jwt <- mJwt
-              <input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece jwt}>
-            ^{btnInnerWidget}
-          |]
 
   formResult btnResult $ \case
     (lType, BtnLecInvAccept) -> do
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index 71e718da9..aa1593ea2 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -587,21 +587,14 @@ postUserNotificationR cID = do
   uid <- decrypt cID
   User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid
 
-  ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
+  ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
   mJwt <- askJwt
   isModal <- hasCustomHeader HeaderIsModal
-  let formWidget = wrapForm nsInnerWdgt' def
+  let formWidget = wrapForm nsInnerWdgt def
         { formAction = Just . SomeRoute $ UserNotificationR cID
         , formEncoding = nsEnc
         , formAttrs = [ ("data-ajax-submit", "") | isModal ]
         }
-      nsInnerWdgt'
-        = [whamlet|
-            $newline never
-            $maybe jwt <- mJwt
-              <input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece jwt}>
-            ^{nsInnerWdgt}
-          |]
 
   formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do
     lift . runDB $ update uid [ UserNotificationSettings =. ns ]
diff --git a/src/Handler/Utils/Tokens.hs b/src/Handler/Utils/Tokens.hs
new file mode 100644
index 000000000..00a0cdbe7
--- /dev/null
+++ b/src/Handler/Utils/Tokens.hs
@@ -0,0 +1,27 @@
+module Handler.Utils.Tokens
+  ( maybeBearerToken, requireBearerToken
+  ) where
+
+import Import
+
+import Utils.Lens
+
+import Control.Monad.Trans.Maybe (runMaybeT)
+
+
+maybeBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => m (Maybe (BearerToken UniWorX))
+maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken
+  where
+    cPred err = any ($ err)
+      [ is $ _HCError . _PermissionDenied
+      , is $ _HCError . _NotAuthenticated
+      ]
+
+requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX)
+requireBearerToken = liftHandlerT $ do
+  token <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return $ askTokenUnsafe
+  mAuthId <- maybeAuthId
+  currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
+  isWrite <- isWriteRequest currentRoute
+  guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
+  return token
diff --git a/src/Import.hs b/src/Import.hs
index 9743e86ac..27dc6e5df 100644
--- a/src/Import.hs
+++ b/src/Import.hs
@@ -6,4 +6,3 @@ import Foundation            as Import
 import Import.NoFoundation   as Import
 
 import Utils.SystemMessage   as Import
-import Model.Token           as Import
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index 2c89df2a1..9b7114837 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -9,6 +9,7 @@ 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 Settings               as Import
 import Settings.StaticFiles   as Import
 import Yesod.Auth             as Import
@@ -20,6 +21,10 @@ import Utils.Frontend.I18n    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
 
@@ -49,6 +54,10 @@ import Data.Text.Encoding.Error as Import(UnicodeException(..))
 import Data.Semigroup         as Import (Semigroup)
 import Data.Monoid            as Import (Last(..), First(..))
 import Data.Monoid.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)
 
diff --git a/src/Language/Haskell/TH/Instances.hs b/src/Language/Haskell/TH/Instances.hs
new file mode 100644
index 000000000..48c419705
--- /dev/null
+++ b/src/Language/Haskell/TH/Instances.hs
@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Language.Haskell.TH.Instances
+  (
+  ) where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Lift (deriveLift)
+import Data.Binary (Binary)
+
+
+instance Binary Loc
+
+deriveLift ''Loc
diff --git a/src/Mail.hs b/src/Mail.hs
index 008af9987..283de2deb 100644
--- a/src/Mail.hs
+++ b/src/Mail.hs
@@ -27,6 +27,7 @@ module Mail
   , setSubjectI, setMailObjectId, setMailObjectId'
   , setDate, setDateCurrent
   , setMailSmtpData
+  , _addressName, _addressEmail
   , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts
   , _partType, _partEncoding, _partFilename, _partHeaders, _partContent
   ) where
@@ -105,6 +106,7 @@ import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
   
 
+makeLenses_ ''Address
 makeLenses_ ''Mail
 makeLenses_ ''Part
 
diff --git a/src/Model/Token.hs b/src/Model/Tokens.hs
similarity index 51%
rename from src/Model/Token.hs
rename to src/Model/Tokens.hs
index e3b3148cf..2b445eb99 100644
--- a/src/Model/Token.hs
+++ b/src/Model/Tokens.hs
@@ -1,28 +1,23 @@
 {-# LANGUAGE UndecidableInstances #-}
 
-module Model.Token
+module Model.Tokens
   ( BearerToken(..)
   , _tokenIdentifier, _tokenAuthority, _tokenRoutes, _tokenAddAuth, _tokenRestrictions, _tokenRestrictionIx, _tokenRestrictionAt, _tokenIssuedAt, _tokenIssuedBy, _tokenExpiresAt, _tokenStartsAt
   , tokenRestrict
-  , bearerToken
-  , encodeToken, BearerTokenException(..), decodeToken, jwtEncoding
-  , tokenToJSON, tokenParseJSON, tokenParseJSON'
-  , askJwt
+  , tokenToJSON, tokenParseJSON
   ) where
 
 import ClassyPrelude.Yesod
+import Yesod.Core.Instances ()
+  
 import Model
-import Settings
-import Utils (NTop(..), hoistMaybe, assertM')
+import Utils (assertM')
 import Utils.Lens hiding ((.=))
 import Data.Aeson.Lens (AsJSON(..))
-import Utils.Parameters
 
 import Yesod.Auth (AuthId)
 
-import qualified Jose.Jwa as Jose
-import Jose.Jwk (JwkSet(..))
-import Jose.Jwt (Jwt(..), IntDate(..))
+import Jose.Jwt (IntDate(..))
 import qualified Jose.Jwt as Jose
 
 import Jose.Jwt.Instances ()
@@ -31,21 +26,20 @@ import Data.Aeson.Types.Instances ()
 import Data.HashSet (HashSet)
 
 import qualified Data.HashMap.Strict as HashMap
+import Data.HashMap.Strict.Instances ()
+import Data.HashSet.Instances ()
+import Data.Time.Clock.Instances ()
 
-import Data.Aeson.Types (Parser, (.:?), (.:), (.!=))
+import Data.Aeson.Types (Parser, (.:?), (.:), (.!=), (.=))
 import qualified Data.Aeson as JSON
 import qualified Data.Aeson.Types as JSON
-import qualified Data.Aeson.Parser as JSON
-import qualified Data.Aeson.Parser.Internal as JSON (jsonEOF')
-import qualified Data.Aeson.Internal as JSON (iparse, formatError)
 
 import CryptoID
 
-import Data.Time.Clock
 import Data.Time.Clock.POSIX
 
-import Control.Monad.Random (MonadRandom(..))
-import Control.Monad.Trans.Maybe (MaybeT(..))
+import Data.Binary (Binary)
+
 
 
 -- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
@@ -72,6 +66,8 @@ deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
 deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site)) => Read (BearerToken site)
 deriving instance (Show (AuthId site), Show (Route site)) => Show (BearerToken site)
 
+instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site)) => Binary (BearerToken site)
+
 makeLenses_ ''BearerToken
 
 _tokenRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) a
@@ -130,7 +126,7 @@ tokenParseJSON :: forall site.
 --
 -- Monadic context is needed because `AuthId`s are encrypted during encoding
 --
--- It's usually easier to use `tokenParseJSON'`
+-- It's usually easier to use `Utils.Tokens.tokenParseJSON'`
 tokenParseJSON v@(Object o) = do
   tokenAuthority' <- lift (o .: "authority") :: ReaderT CryptoIDKey Parser (CryptoUUID (AuthId site))
   tokenAuthority <- decrypt tokenAuthority'
@@ -151,116 +147,3 @@ tokenParseJSON v@(Object o) = do
   return BearerToken{..}
 tokenParseJSON v = lift $ JSON.typeMismatch "BearerToken" v
 
-tokenParseJSON' :: forall m.
-                  ( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
-                  , ParseRoute (HandlerSite m)
-                  , Hashable (Route (HandlerSite m))
-                  , MonadHandler m
-                  , MonadCrypto m
-                  , MonadCryptoKey m ~ CryptoIDKey
-                  )
-               => m (Value -> Parser (BearerToken (HandlerSite m)))
--- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s
-tokenParseJSON' = do
-  cidKey <- cryptoIDKey return
-  return $ flip runReaderT cidKey . tokenParseJSON
-
-
-bearerToken :: forall m.
-               ( MonadHandler m
-               , HasInstanceID (HandlerSite m) InstanceId
-               , HasCryptoUUID (AuthId (HandlerSite m)) m
-               , HasAppSettings (HandlerSite m)
-               )
-            => AuthId (HandlerSite m)
-            -> Maybe (HashSet (Route (HandlerSite m)))
-            -> Maybe AuthDNF
-            -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
-            -> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
-            -> m (BearerToken (HandlerSite m))
--- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict`
-bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do
-  tokenIdentifier <- liftIO getRandom
-  tokenIssuedAt <- liftIO getCurrentTime
-  tokenIssuedBy <- getsYesod $ view instanceID
-
-  defaultExpiration <- getsYesod $ view _appJWTExpiration
-  
-  let tokenExpiresAt
-        | Just t <- mTokenExpiresAt
-        = t
-        | Just tDiff <- defaultExpiration
-        = Just $ tDiff `addUTCTime` fromMaybe tokenIssuedAt tokenStartsAt
-        | otherwise
-        = Nothing
-      tokenRestrictions = HashMap.empty
-
-  return BearerToken{..}
-
-
-jwtEncoding :: Jose.JwtEncoding
--- ^ How should `Jwt`s be signed and/or encrypted?
-jwtEncoding = Jose.JwsEncoding Jose.HS256
-
-
-encodeToken :: forall m.
-               ( MonadHandler m
-               , HasJSONWebKeySet (HandlerSite m) JwkSet
-               , HasInstanceID (HandlerSite m) InstanceId
-               , HasCryptoUUID (AuthId (HandlerSite m)) m
-               , RenderRoute (HandlerSite m)
-               )
-            => BearerToken (HandlerSite m) -> m Jwt
--- ^ Call `tokenToJSON` and encode the result as a `Jwt` according to `jwtEncoding`
-encodeToken token = do
-  payload <- Jose.Claims . toStrict . JSON.encode <$> tokenToJSON token
-  JwkSet jwks <- getsYesod $ view jsonWebKeySet
-  either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
-
-
-data BearerTokenException
-  = BearerTokenJwtError Jose.JwtError -- ^ An Error occurred in the underlying `Jwt`-Implementation
-  | BearerTokenUnsecured -- ^ `Jwt` is insufficiently secured (unsigned and not encrypted)
-  | BearerTokenInvalidFormat String -- ^ Content of the `Jwt` could not be parsed as a `BearerToken`
-  | BearerTokenExpired | BearerTokenNotStarted
-  deriving (Eq, Show, Generic, Typeable)
-
-instance Exception BearerTokenException
-
-decodeToken :: forall m.
-               ( MonadHandler m
-               , HasJSONWebKeySet (HandlerSite m) JwkSet
-               , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
-               , MonadCryptoKey m ~ CryptoIDKey
-               , MonadCrypto m
-               , MonadThrow m
-               , ParseRoute (HandlerSite m)
-               , Hashable (Route (HandlerSite m))
-               )
-            => Jwt -> m (BearerToken (HandlerSite m))
--- ^ Decode a `Jwt` according to `jwtEncoding` and call `tokenParseJSON`
-decodeToken (Jwt bs) = do
-  JwkSet jwks <- getsYesod $ view jsonWebKeySet
-  content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
-  content' <- case content of
-    Jose.Unsecured _ -> throwM BearerTokenUnsecured
-    Jose.Jws (_header, payload) -> return payload
-    Jose.Jwe (_header, payload) -> return payload
-  parser <- tokenParseJSON'
-  token@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content'
-  now <- liftIO getCurrentTime
-  unless (NTop tokenExpiresAt > NTop (Just now)) $
-    throwM BearerTokenExpired
-  unless (tokenStartsAt <= Just now) $
-    throwM BearerTokenNotStarted
-  return token
-
-
-askJwt :: forall m. ( MonadHandler m )
-       => m (Maybe Jwt)
--- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
-askJwt = runMaybeT $ asum
-  [ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
-  , MaybeT $ lookupGlobalPostParam PostBearer
-  , MaybeT $ lookupGlobalGetParam GetBearer
-  ]
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 00bda42a1..3978399b4 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -81,6 +81,7 @@ import Model.Types.Wordlist
 import Data.Text.Metrics (damerauLevenshtein)
 
 import Data.Binary (Binary)
+import qualified Data.Binary as Binary
   
 
 instance PathPiece UUID where
@@ -795,6 +796,8 @@ instance PathPiece a => PathPiece (PredLiteral a) where
   fromPathPiece t = PLVariable <$> fromPathPiece t
                 <|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece)
 
+instance Binary a => Binary (PredLiteral a)
+
 
 newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
@@ -802,11 +805,15 @@ newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
 
 $(return [])
 
-instance (Ord a, ToJSON a) => ToJSON (PredDNF a) where
+instance ToJSON a => ToJSON (PredDNF a) where
   toJSON = $(mkToJSON predNFAesonOptions ''PredDNF)
 instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
   parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
 
+instance (Ord a, Binary a) => Binary (PredDNF a) where
+  get = PredDNF <$> Binary.get
+  put = Binary.put . dnfTerms
+
 type AuthLiteral = PredLiteral AuthTag
 
 type AuthDNF = PredDNF AuthTag
diff --git a/src/Settings.hs b/src/Settings.hs
index ae2ce4b30..47e0b25e8 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -63,6 +63,9 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
 
 import qualified System.FilePath as FilePath
 
+import Jose.Jwt (JwtEncoding(..))
+
+
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,
 -- theoretically even a database.
@@ -100,7 +103,8 @@ data AppSettings = AppSettings
     , appNotificationExpiration :: NominalDiffTime
     , appSessionTimeout         :: NominalDiffTime
     , appMaximumContentLength   :: Maybe Word64
-    , appJWTExpiration          :: Maybe NominalDiffTime
+    , appJwtExpiration          :: Maybe NominalDiffTime
+    , appJwtEncoding            :: JwtEncoding
 
     , appInitialLogSettings     :: LogSettings
 
@@ -311,6 +315,18 @@ deriveFromJSON
     }
   ''SmtpAuthConf
 
+instance FromJSON JwtEncoding where
+  parseJSON v@(String _) = JwsEncoding <$> parseJSON v
+  parseJSON v = flip (withObject "JwtEncoding") v $ \obj -> asum
+    [ do
+        alg <- obj .: "alg"
+        return $ JwsEncoding alg
+    , do
+        alg <- obj .: "alg"
+        enc <- obj .: "enc"
+        return $ JweEncoding alg enc
+    ]
+
 
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
@@ -353,7 +369,8 @@ instance FromJSON AppSettings where
         appNotificationRateLimit  <- o .:  "notification-rate-limit"
         appNotificationCollateDelay <- o .: "notification-collate-delay"
         appNotificationExpiration <- o .: "notification-expiration"
-        appJWTExpiration          <- o .:? "jwt-expiration"
+        appJwtExpiration          <- o .:? "jwt-expiration"
+        appJwtEncoding            <- o .: "jwt-encoding"
 
         appSessionTimeout         <- o .: "session-timeout"
 
diff --git a/src/Utils.hs b/src/Utils.hs
index a95cb7bfc..68906d803 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -52,6 +52,7 @@ import Control.Monad.Catch hiding (throwM)
 import qualified Database.Esqueleto as E (Value, unValue)
 
 import Language.Haskell.TH
+import Language.Haskell.TH.Instances ()
 import Instances.TH.Lift ()
 
 import Text.Shakespeare.Text (st)
@@ -69,6 +70,8 @@ import qualified Crypto.Data.PKCS7 as PKCS7
 import Data.Fixed (Centi)
 import Data.Ratio ((%))
 
+import qualified Data.Binary as Binary
+
 {-# ANN choice ("HLint: ignore Use asum" :: String) #-}
 
 
@@ -607,6 +610,15 @@ choice = foldr (<|>) empty
 -- Sessions --
 --------------
 
+data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
+                | SessionNewStudyTerms
+                | SessionBearer
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+instance Universe SessionKey
+instance Finite SessionKey
+
+nullaryPathPiece ''SessionKey $ camelToPathPiece' 1
+
 setSessionJson :: (PathPiece k, ToJSON v, MonadHandler m) => k -> v -> m ()
 setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSessionBS key val
 
@@ -731,3 +743,12 @@ encodedSecretBoxOpen :: ( FromJSON a, MonadError EncodedSecretBoxException m, Mo
 encodedSecretBoxOpen ciphertext = do
   sKey <- secretBoxKey
   encodedSecretBoxOpen' sKey ciphertext
+
+-------------
+-- Caching --
+-------------
+
+cachedHere :: Q Exp
+cachedHere = do
+  loc <- location
+  [e| cachedBy (toStrict $ Binary.encode loc) |]
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 4493dc612..05261e95b 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -1,12 +1,16 @@
 module Utils.Lens ( module Utils.Lens ) where
 
-import Import.NoFoundation
+import ClassyPrelude.Yesod hiding ((.=))
+import Model
 import Control.Lens as Utils.Lens hiding ((<.>))
 import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
 
+import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
+
 import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
 
+
 _unValue :: Lens' (E.Value a) a
 _unValue f (E.Value a) = E.Value <$> f a
 
@@ -70,8 +74,6 @@ hasEntityUser = hasEntity
 --   hasUser = _entityVal . hasUser
 
 
-makeLenses_ ''Address
-
 makeLenses_ ''SheetCorrector
 
 makeLenses_ ''SubmissionGroup
@@ -92,6 +94,10 @@ makeLenses_ ''StudyTerms
 
 makeLenses_ ''StudyTermCandidate
 
+makePrisms ''HandlerContents
+
+makePrisms ''ErrorResponse
+
 
 -- makeClassy_ ''Load
 
diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs
new file mode 100644
index 000000000..f6533120d
--- /dev/null
+++ b/src/Utils/Tokens.hs
@@ -0,0 +1,174 @@
+module Utils.Tokens
+  ( bearerToken
+  , encodeToken, BearerTokenException(..), decodeToken
+  , tokenParseJSON'
+  , askJwt
+  , formEmbedJwtPost, formEmbedJwtGet
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Yesod.Auth (AuthId)
+
+import Utils (NTop(..), hoistMaybe, SessionKey(..))
+import Utils.Parameters
+import Utils.Lens hiding ((.=))
+
+import Model
+import Model.Tokens
+
+import Jose.Jwk (JwkSet(..))
+import Jose.Jwt (Jwt(..))
+import qualified Jose.Jwt as Jose
+
+import Data.Aeson.Types (Parser)
+import qualified Data.Aeson as JSON
+import qualified Data.Aeson.Parser as JSON
+import qualified Data.Aeson.Parser.Internal as JSON (jsonEOF')
+import qualified Data.Aeson.Internal as JSON (iparse, formatError)
+
+import qualified Data.HashMap.Strict as HashMap
+
+import Data.Time.Clock
+
+import Control.Monad.Random (MonadRandom(..))
+import Control.Monad.Trans.Maybe (MaybeT(..))
+
+import Settings
+
+import CryptoID
+
+import Text.Blaze (Markup)
+
+
+tokenParseJSON' :: forall m.
+                  ( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
+                  , ParseRoute (HandlerSite m)
+                  , Hashable (Route (HandlerSite m))
+                  , MonadHandler m
+                  , MonadCrypto m
+                  , MonadCryptoKey m ~ CryptoIDKey
+                  )
+               => m (Value -> Parser (BearerToken (HandlerSite m)))
+-- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s
+tokenParseJSON' = do
+  cidKey <- cryptoIDKey return
+  return $ flip runReaderT cidKey . tokenParseJSON
+
+
+bearerToken :: forall m.
+               ( MonadHandler m
+               , HasInstanceID (HandlerSite m) InstanceId
+               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               , HasAppSettings (HandlerSite m)
+               )
+            => AuthId (HandlerSite m)
+            -> Maybe (HashSet (Route (HandlerSite m)))
+            -> Maybe AuthDNF
+            -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
+            -> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
+            -> m (BearerToken (HandlerSite m))
+-- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict`
+bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do
+  tokenIdentifier <- liftIO getRandom
+  tokenIssuedAt <- liftIO getCurrentTime
+  tokenIssuedBy <- getsYesod $ view instanceID
+
+  defaultExpiration <- getsYesod $ view _appJwtExpiration
+  
+  let tokenExpiresAt
+        | Just t <- mTokenExpiresAt
+        = t
+        | Just tDiff <- defaultExpiration
+        = Just $ tDiff `addUTCTime` fromMaybe tokenIssuedAt tokenStartsAt
+        | otherwise
+        = Nothing
+      tokenRestrictions = HashMap.empty
+
+  return BearerToken{..}
+
+
+encodeToken :: forall m.
+               ( MonadHandler m
+               , HasJSONWebKeySet (HandlerSite m) JwkSet
+               , HasInstanceID (HandlerSite m) InstanceId
+               , HasAppSettings (HandlerSite m)
+               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               , RenderRoute (HandlerSite m)
+               )
+            => BearerToken (HandlerSite m) -> m Jwt
+-- ^ Call `tokenToJSON` and encode the result as a `Jwt` according to `appJwtEncoding`
+encodeToken token = do
+  payload <- Jose.Claims . toStrict . JSON.encode <$> tokenToJSON token
+  JwkSet jwks <- getsYesod $ view jsonWebKeySet
+  jwtEncoding <- getsYesod $ view _appJwtEncoding
+  either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
+
+
+data BearerTokenException
+  = BearerTokenJwtError Jose.JwtError -- ^ An Error occurred in the underlying `Jwt`-Implementation
+  | BearerTokenUnsecured -- ^ `Jwt` is insufficiently secured (unsigned and not encrypted)
+  | BearerTokenInvalidFormat String -- ^ Content of the `Jwt` could not be parsed as a `BearerToken`
+  | BearerTokenExpired | BearerTokenNotStarted
+  deriving (Eq, Show, Generic, Typeable)
+
+instance Exception BearerTokenException
+
+decodeToken :: forall m.
+               ( MonadHandler m
+               , HasJSONWebKeySet (HandlerSite m) JwkSet
+               , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
+               , MonadCryptoKey m ~ CryptoIDKey
+               , MonadCrypto m
+               , MonadThrow m
+               , ParseRoute (HandlerSite m)
+               , Hashable (Route (HandlerSite m))
+               )
+            => Jwt -> m (BearerToken (HandlerSite m))
+-- ^ Decode a `Jwt` and call `tokenParseJSON`
+--
+-- Throws `bearerTokenException`s
+decodeToken (Jwt bs) = do
+  JwkSet jwks <- getsYesod $ view jsonWebKeySet
+  content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
+  content' <- case content of
+    Jose.Unsecured _ -> throwM BearerTokenUnsecured
+    Jose.Jws (_header, payload) -> return payload
+    Jose.Jwe (_header, payload) -> return payload
+  parser <- tokenParseJSON'
+  token@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content'
+  now <- liftIO getCurrentTime
+  unless (NTop tokenExpiresAt > NTop (Just now)) $
+    throwM BearerTokenExpired
+  unless (tokenStartsAt <= Just now) $
+    throwM BearerTokenNotStarted
+  return token
+
+
+askJwt :: forall m. ( MonadHandler m )
+       => m (Maybe Jwt)
+-- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
+askJwt = runMaybeT $ asum
+  [ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
+  , MaybeT $ lookupGlobalPostParam PostBearer
+  , MaybeT $ lookupGlobalGetParam GetBearer
+  , fmap Jwt . MaybeT $ lookupSessionBS (toPathPiece SessionBearer)
+  ]
+
+formEmbedJwtPost, formEmbedJwtGet :: MonadHandler m => (Markup -> m a) -> (Markup -> m a)
+formEmbedJwtPost f fragment = do
+  mJwt <- askJwt
+  f [shamlet|
+       $newline never
+       $maybe jwt <- mJwt
+         <input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece jwt}>
+       #{fragment}
+    |]
+formEmbedJwtGet f fragment = do
+  mJwt <- askJwt
+  f [shamlet|
+       $newline never
+       $maybe jwt <- mJwt
+         <input type=hidden name=#{toPathPiece GetBearer} value=#{toPathPiece jwt}>
+       #{fragment}
+    |]