Merge branch '234-onboarding-bearer-tokens' into 'master'

Work on "Onboarding / Bearer-Tokens"

See merge request !175

config/settings.yml

@@ -27,6 +27,8 @@ notification-rate-limit: 3600
 notification-collate-delay: 300
 notification-expiration: 259201
 session-timeout: 7200
+jwt-expiration: 604800
+jwt-encoding: HS256
 maximum-content-length: 52428800
 
 log-settings:

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

messages/uniworx/de.msg

@@ -10,6 +10,9 @@ BtnSave: Speichern
 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
@@ -206,6 +209,13 @@ 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.
+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.
@@ -234,6 +244,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.
@@ -275,6 +286,9 @@ ImpressumHeading: Impressum
 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
@@ -291,7 +305,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
 
 PreviouslyUploadedInfo: Bereits hochgeladene Dateien:
@@ -515,6 +530,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
@@ -672,6 +690,7 @@ MenuCourseMembers: Kursteilnehmer
 MenuTermShow: Semester
 MenuSubmissionDelete: Abgabe löschen
 MenuUsers: Benutzer
+MenuUserNotifications: Benachrichtigungs-Einstellungen
 MenuAdminTest: Admin-Demo
 MenuMessageList: Systemnachrichten
 MenuAdminErrMsg: Fehlermeldung entschlüsseln
@@ -706,6 +725,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
@@ -721,6 +741,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
@@ -735,3 +756,10 @@ MassInputAddDimension: Hinzufügen
 MassInputDeleteCell: Entfernen
 
 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.

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

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)

package.yaml

@@ -85,6 +85,7 @@ dependencies:
   - scientific
   - tz
   - system-locale
+  - th-lift
   - th-lift-instances
   - gitrev
   - Glob
@@ -117,6 +118,9 @@ dependencies:
   - lattices
   - hsass
   - semigroupoids
+  - jose-jwt
+  - mono-traversable
+  - lens-aeson
 
 other-extensions:
   - GeneralizedNewtypeDeriving

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
@@ -74,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

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)
+    & setPort (foundation ^. _appPort)
-    & setHost (appHost $ appSettings foundation)
+    & 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{..}

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

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

src/Data/Aeson/Types/Instances.hs

@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Aeson.Types.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+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

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

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

src/Data/NonNull/Instances.hs

@@ -0,0 +1,28 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.NonNull.Instances
+  (
+  ) where
+
+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
+
+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
+
+
+instance (Binary a, MonoFoldable a) => Binary (NonNull a) where
+  get = Binary.get >>= maybe (fail "Expected non-empty structure") return . fromNullable
+  put = Binary.put . toNullable

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

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

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

src/Foundation.hs

@@ -43,6 +43,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)
 
@@ -55,12 +56,12 @@ 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)
 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
@@ -77,6 +78,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 +98,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 +108,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 +123,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:
@@ -137,8 +148,10 @@ 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 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
@@ -385,25 +398,30 @@ appLanguagesOpts = do
 
 
 -- Access Control
+newtype InvalidAuthTag = InvalidAuthTag Text
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+instance Exception InvalidAuthTag
+
+
 data AccessPredicate
-  = APPure     (Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
+  = APPure     (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
-  | APHandler  (Route UniWorX -> Bool -> Handler AuthResult)
+  | APHandler  (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Handler AuthResult)
-  | APDB       (Route UniWorX -> Bool -> DB 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
+  evalAccessPred aPred aid r w = liftHandlerT $ case aPred of
-    (APPure    p) -> runReader (p r w) <$> getMsgRenderer
+    (APPure    p) -> runReader (p aid r w) <$> getMsgRenderer
-    (APHandler p) -> p r w
+    (APHandler p) -> p aid r w
-    (APDB      p) -> runDB $ p 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
+  evalAccessPred aPred aid r w = mapReaderT liftHandlerT $ case aPred of
-    (APPure    p) -> lift $ runReader (p r w) <$> getMsgRenderer
+    (APPure    p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
-    (APHandler p) -> lift $ p r w
+    (APHandler p) -> lift $ p aid r w
-    (APDB      p) -> p r w
+    (APDB      p) -> p aid r w
 
 
 orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
@@ -424,16 +442,57 @@ trueAR = const Authorized
 falseAR = Unauthorized . ($ MsgUnauthorized) . render
 
 trueAP, falseAP :: AccessPredicate
-trueAP  = APPure . const . const $ trueAR <$> ask
+trueAP  = APPure . const . const . const $ trueAR <$> ask
-falseAP = APPure . const . const $ falseAR <$> ask -- included for completeness
+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 $ \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
@@ -445,13 +504,15 @@ 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 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 $ 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] []
@@ -459,21 +520,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
+  allow <- view _appAllowDeprecated
   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
@@ -485,11 +546,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
+tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
-  authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+  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
@@ -516,7 +577,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
@@ -542,8 +603,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,mAuthId) of
-    registered <- case (mbc,mAid) of
       (Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid)
       _ -> return False
     case mbc of
@@ -565,9 +625,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
@@ -578,7 +638,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
@@ -640,14 +700,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
@@ -658,73 +718,81 @@ 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 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
     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 AuthRead = APHandler . const . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
-tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
+tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
 
 
-newtype InvalidAuthTag = InvalidAuthTag Text
+defaultAuthDNF :: AuthDNF
-  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+defaultAuthDNF = PredDNF $ Set.fromList
-instance Exception InvalidAuthTag
+  [ impureNonNull . Set.singleton $ PLVariable AuthAdmin
+  , impureNonNull . Set.singleton $ PLVariable AuthToken
+  ]
 
-type DNF a = Set (NonNull (Set a))
+routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF
-
-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))
 -- ^ 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
@@ -735,42 +803,63 @@ 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 -> 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) route isWrite
+evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF) mAuthId route isWrite
-  = startEvalMemoT $ do
+  = do
-      mr <- lift getMsgRenderer
+      mr <- getMsgRenderer
       let
         authTagIsInactive = not . authTagIsActive
 
-        evalAuthTag :: AuthTag -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
+        evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult
-        evalAuthTag = memo $ \authTag -> lift . lift $ evalAccessPred (tagAccessPredicate authTag) route isWrite
+        evalAuthTag authTag = lift . (runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite
+          where
+            evalAccessPred' authTag' mAuthId' route' isWrite' = CachedMemoT $ do
+              $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]] -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
+        evalDNF :: [[AuthLiteral]] -> 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 = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthLiteral 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 . 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 ->
+      unless (is _Authorized result) . forM_ (filter (any $ authTagIsInactive . plVar) authDNF) $ \conj ->
-        whenM (allM conj (\aTag -> (return . not $ authTagIsActive aTag) `or2M` (not . is _Unauthorized <$> evalAuthTag aTag))) $ do
+        whenM (allM conj (\aTag -> (return . not . authTagIsActive $ plVar aTag) `or2M` (not . is _Unauthorized <$> evalAuthLiteral aTag))) $ do
-          let pivots = filter authTagIsInactive conj
+          let pivots = filter (authTagIsInactive . plVar) conj
-          whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do
+          whenM (allM pivots $ fmap (is _Authorized) . evalAuthLiteral) $ do
-            lift $ $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|]
+            let pivots' = plVar <$> 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
@@ -796,17 +885,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
+    makeSessionBackend app = do
-      (getCachedDate, _) <- clientSessionDateCacher appSessionTimeout
+      (getCachedDate, _) <- clientSessionDateCacher (app ^. _appSessionTimeout)
-      return . Just $ clientSessionBackend appSessionKey getCachedDate
+      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.
@@ -865,7 +954,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
@@ -906,8 +995,8 @@ instance Yesod UniWorX where
     isAuthorized = evalAccess
 
     addStaticContent ext _mime content = do
-      UniWorX{appWidgetMemcached, appSettings} <- getYesod
+      UniWorX{appWidgetMemcached, appSettings'} <- getYesod
-      for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
+      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
@@ -958,8 +1047,7 @@ siteLayout = siteLayout' . Just
 siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading`
            -> Widget -> Handler Html
 siteLayout' headingOverride widget = do
-  master <- getYesod
+  AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- view appSettings
-  let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master
 
   isModal <- hasCustomHeader HeaderIsModal
 
@@ -1414,6 +1502,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
@@ -2074,7 +2172,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
@@ -2129,6 +2227,7 @@ instance YesodAuth UniWorX where
               , userDownloadFiles        = userDefaultDownloadFiles
               , userNotificationSettings = def
               , userMailLanguages        = def
+              , userTokensIssuedAfter    = Nothing
               , ..
               }
             userUpdate =  [ UserMatrikelnummer     =. userMatrikelnummer
@@ -2193,7 +2292,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
@@ -2218,9 +2317,9 @@ unsafeHandler f h = do
 
 
 instance YesodMail UniWorX where
-  defaultFromAddress = getsYesod $ appMailFrom . appSettings
+  defaultFromAddress = getsYesod $ view _appMailFrom
-  mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings
+  mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
-  mailVerp = getsYesod $ appMailVerp . appSettings
+  mailVerp = getsYesod $ view _appMailVerp
   mailDateTZ = return appTZ
   mailSmtp act = do
     pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
@@ -2228,7 +2327,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
 

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 $ (,,)

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
+  courseData <- runDB $ do
-      mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
+      mbCourse     <- getBy (TermSchoolCourseShort tid ssh csh)
-      mbLecs   <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
+      mbLecs       <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
-      return $ (,) <$> mbCourse <*> mbLecs
+      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 Course -> [Lecturer] -> [LecturerInvitation] -> CourseForm
-courseToForm (Entity cid Course{..}) lecs = 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 (CI.mk -> email, mLid) ->
-                FormSuccess (email, Just lid) -> FormSuccess $ \prev -> if
+                  let new = maybe (Left email) Right mLid
-                  | lid `elem` Map.elems prev -> FormFailure [ mr . MsgCourseLecturerAlreadyAdded $ CI.mk email ]
+                  in  FormSuccess $ \prev -> if
-                  | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) lid
+                        | 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 :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
-        miCell _ lid defType nudge = \csrf -> do
+        miCell _ (Right lid) defType nudge = \csrf -> do
-          (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
+          (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 :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
-        lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) Map.elems $ massInput
+        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,56 @@ 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 . 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)
+
+  let btnWidget = wrapForm btnInnerWidget def
+        { formEncoding = btnEncoding
+        , formAction = Just . SomeRoute . CourseR tid ssh csh $ CLecInviteR email
+        , formSubmit = FormNoSubmit
+        }
+
+  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")

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,31 @@ 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)
+
+
+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
 postProfileR = do
@@ -89,38 +113,60 @@ postProfileR = do
         , stgDownloadFiles = userDownloadFiles
         , stgNotificationSettings = userNotificationSettings
         }
-  ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate
+  ((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ 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
 
-    (FormFailure msgs) -> forM_ msgs $ addMessage Warning . toHtml
+  formResult res $ \SettingsForm{..} -> do
-    _ -> return ()
+    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
-    let settingsForm = wrapForm formWidget def
+    let settingsForm = 
-          { formAction = Just $ SomeRoute ProfileR
+          wrapForm formWidget FormSettings
-          , formEncoding = formEnctype
+            { formMethod = POST
-          }
+            , formAction = Just . SomeRoute $ ProfileR :#: ProfileSettings
-    $(widgetFile "profile")
+            , 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
@@ -533,3 +579,27 @@ 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 . formEmbedJwtPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
+  mJwt <- askJwt
+  isModal <- hasCustomHeader HeaderIsModal
+  let formWidget = wrapForm nsInnerWdgt def
+        { formAction = Just . SomeRoute $ UserNotificationR cID
+        , formEncoding = nsEnc
+        , formAttrs = [ ("data-ajax-submit", "") | isModal ]
+        }
+
+  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
+
+  siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do
+    setTitleI $ MsgNotificationSettingsHeading userDisplayName
+    formWidget

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

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)
+      | otherwise = loop (succ n) (addOneWeek t)

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

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
@@ -18,7 +19,11 @@ import Utils                  as Import
 import Utils.Frontend.Modal   as Import
 import Utils.Frontend.I18n    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 Language.Haskell.TH.Instances as Import ()
+
+import Utils.Tokens           as Import
 
 
 import Data.Fixed             as Import
@@ -44,10 +49,15 @@ 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(..))
 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)
 
@@ -57,17 +67,21 @@ import Control.Monad.Trans.Resource as Import (ReleaseKey)
 
 import Network.Mail.Mime.Instances as Import ()
 import Yesod.Core.Instances as Import ()
+import Data.Aeson.Types.Instances as Import ()
 
 import Ldap.Client.Pool as Import
 
 import Database.Esqueleto.Instances as Import ()
 import Database.Persist.Sql.Instances as Import ()
 import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
+import Database.Persist.Types.Instances as Import ()
 
 import Numeric.Natural.Instances as Import ()
 import System.Random as Import (Random)
 import Control.Monad.Random.Class as Import (MonadRandom(..))
 
+import Jose.Jwt.Instances as Import ()
+
 
 import Control.Monad.Trans.RWS (RWST)
 

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))
@@ -58,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
@@ -77,7 +79,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 +137,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 +159,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 +168,7 @@ execCrontab = evalStateT go HashMap.empty
                               CronLastExec
                                 { cronLastExecJob = toJSON job
                                 , cronLastExecTime = now
-                                , cronLastExecInstance = instanceID
+                                , cronLastExecInstance = instanceID'
                                 }
                               [ CronLastExecTime =. now ]
                             lift . lift $ queueDBJob job
@@ -285,21 +287,21 @@ jLocked jId act = do
   let
     lock = runDB . setSerializable $ do
       qj@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId
-      instanceID <- getsYesod appInstanceID
+      instanceID' <- getsYesod $ view instanceID
-      threshold <- getsYesod $ appJobStaleThreshold . appSettings
+      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

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

src/Jobs/Handler/HelpRequest.hs

@@ -21,7 +21,7 @@ dispatchJobHelpRequest :: Either (Maybe Address) UserId
                        -> Maybe Text -- ^ Referer
                        -> Handler ()
 dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do
-  supportAddress <- getsYesod $ appMailSupport . appSettings
+  supportAddress <- view _appMailSupport
   userInfo <- bitraverse return (runDB . getEntity) jSender
   let userAddress = either
         id

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

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
@@ -28,6 +29,7 @@ dispatchNotificationCorrectionsAssigned  nUser nSheet jRecipient = do
     MsgRenderer mr <- getMailMsgRenderer
     let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
 
-    addAlternatives $ do
+    editNotifications <- mkEditNotifications jRecipient
-      let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
+
+    addAlternatives $
       providePreferredAlternative ($(ihamletFile "templates/mail/correctionsAssigned.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

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
@@ -27,6 +28,7 @@ dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
       csh = courseShorthand
       shn = sheetName
 
-  addAlternatives $ do
+  editNotifications <- mkEditNotifications jRecipient
-    let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
+
+  addAlternatives $
     providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

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
@@ -30,8 +31,9 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $
       csh = courseShorthand
       shn = sheetName
 
-  addAlternatives $ do
+  editNotifications <- mkEditNotifications jRecipient
-    let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
+
+  addAlternatives $
     providePreferredAlternative ($(ihamletFile "templates/mail/sheetSoonInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
 
 dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler ()
@@ -56,7 +58,8 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
       csh = courseShorthand
       shn = sheetName
 
-  addAlternatives $ do
+  editNotifications <- mkEditNotifications jRecipient
-    let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
+
+  addAlternatives $
     providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
 

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
@@ -35,6 +36,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
@@ -52,5 +55,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))

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
@@ -22,7 +23,7 @@ dispatchNotificationUserRightsUpdate  nUser _originalRights jRecipient = userMai
     replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
     setSubjectI $ MsgMailSubjectUserRightsUpdate userDisplayName
     -- MsgRenderer mr <- getMailMsgRenderer
-    addAlternatives $ do
+    editNotifications <- mkEditNotifications jRecipient
-      let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
+    addAlternatives $
       providePreferredAlternative ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
 

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 GetBearer, toPathPiece jwt)])
+  editNotificationsUrl' <- toTextUrl editNotificationsUrl
+  return ($(ihamletFile "templates/mail/editNotifications.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

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 }

src/Jose/Jwt/Instances.hs

@@ -0,0 +1,19 @@
+{-# 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 Generic JwtError
+deriving instance Typeable JwtError
+
+instance Exception JwtError

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

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
 

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

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

src/Model/Tokens.hs

@@ -0,0 +1,149 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Model.Tokens
+  ( BearerToken(..)
+  , _tokenIdentifier, _tokenAuthority, _tokenRoutes, _tokenAddAuth, _tokenRestrictions, _tokenRestrictionIx, _tokenRestrictionAt, _tokenIssuedAt, _tokenIssuedBy, _tokenExpiresAt, _tokenStartsAt
+  , tokenRestrict
+  , tokenToJSON, tokenParseJSON
+  ) where
+
+import ClassyPrelude.Yesod
+import Yesod.Core.Instances ()
+  
+import Model
+import Utils (assertM')
+import Utils.Lens hiding ((.=))
+import Data.Aeson.Lens (AsJSON(..))
+
+import Yesod.Auth (AuthId)
+
+import Jose.Jwt (IntDate(..))
+import qualified Jose.Jwt as Jose
+
+import Jose.Jwt.Instances ()
+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 qualified Data.Aeson as JSON
+import qualified Data.Aeson.Types as JSON
+
+import CryptoID
+
+import Data.Time.Clock.POSIX
+
+import Data.Binary (Binary)
+
+
+
+-- | 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, ...)
+    --
+    -- 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
+  , 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)
+
+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
+-- ^ Focus a singular restriction (by route) if it exists
+--
+-- 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
+               , 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
+        { 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 $
+    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
+
+tokenParseJSON :: forall site.
+                  ( HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
+                  , ParseRoute site
+                  , Hashable (Route 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 `Utils.Tokens.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"
+  tokenRestrictions  <- lift $ o .:? "restrictions" .!= HashMap.empty
+  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
+

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,8 @@ import Model.Types.Wordlist
 import Data.Text.Metrics (damerauLevenshtein)
 
 import Data.Binary (Binary)
-
+import qualified Data.Binary as Binary
+  
 
 instance PathPiece UUID where
   fromPathPiece = UUID.fromString . unpack
@@ -712,6 +715,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
@@ -724,6 +728,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthCorrectorSubmissions
   | AuthCapacity
   | AuthEmpty
+  | AuthSelf
   | AuthAuthentication
   | AuthNoEscalation
   | AuthRead
@@ -731,7 +736,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
@@ -749,6 +754,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)
@@ -772,6 +779,45 @@ 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
+
+instance PathPiece a => PathPiece (PredLiteral a) where
+  toPathPiece PLVariable{..} = toPathPiece plVar
+  toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar
+
+  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)
+  deriving newtype (Semigroup, Monoid)
+
+$(return [])
+
+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
+
 
 data LecturerType = CourseLecturer | CourseAssistant
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
@@ -785,6 +831,8 @@ deriveJSON  defaultOptions
   } ''LecturerType
 derivePersistFieldJSON ''LecturerType
 
+instance Hashable LecturerType
+
 
 -- Type synonyms
 
@@ -799,4 +847,5 @@ type UserEmail       = CI Email
 
 type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
 type InstanceId      = UUID
+type TokenId         = UUID
 type TermCandidateIncidence = UUID

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

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,6 +103,8 @@ data AppSettings = AppSettings
     , appNotificationExpiration :: NominalDiffTime
     , appSessionTimeout         :: NominalDiffTime
     , appMaximumContentLength   :: Maybe Word64
+    , appJwtExpiration          :: Maybe NominalDiffTime
+    , appJwtEncoding            :: JwtEncoding
 
     , appInitialLogSettings     :: LogSettings
 
@@ -310,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
@@ -352,6 +369,8 @@ instance FromJSON AppSettings where
         appNotificationRateLimit  <- o .:  "notification-rate-limit"
         appNotificationCollateDelay <- o .: "notification-collate-delay"
         appNotificationExpiration <- o .: "notification-expiration"
+        appJwtExpiration          <- o .:? "jwt-expiration"
+        appJwtEncoding            <- o .: "jwt-encoding"
 
         appSessionTimeout         <- o .: "session-timeout"
 
@@ -379,6 +398,8 @@ instance FromJSON AppSettings where
 
         return AppSettings {..}
 
+makeClassy_ ''AppSettings
+
 -- | Settings for 'widgetFile', such as which template languages to support and
 -- default Hamlet settings.
 --

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

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) #-}
 
 
@@ -490,6 +493,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
 
@@ -601,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
 
@@ -725,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) |]

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)

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
 
@@ -90,7 +94,19 @@ makeLenses_ ''StudyTerms
 
 makeLenses_ ''StudyTermCandidate
 
+makePrisms ''HandlerContents
+
+makePrisms ''ErrorResponse
+
 
 -- 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

src/Utils/Parameters.hs

@@ -20,7 +20,7 @@ import Data.Universe
 import Control.Monad.Trans.Maybe (MaybeT(..))
 
 
-data GlobalGetParam = GetReferer
+data GlobalGetParam = GetReferer | GetBearer
   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
+                     | PostBearer
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe GlobalPostParam

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

src/Yesod/Core/Instances.hs

@@ -15,37 +15,61 @@ 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
+  fromPathPiece = routeFromPathPiece
-    = parseRoute
+  toPathPiece = routeToPathPiece
-    . 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
     
-instance (RenderRoute site, ParseRoute site) => FromJSON (Route site) where
+instance ParseRoute site => FromJSON (Route site) where
-  parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . fromPathPiece
+  parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . routeFromPathPiece
 
-instance (RenderRoute site, ParseRoute site) => ToJSON (Route site) where
+instance RenderRoute site => ToJSON (Route site) where
-  toJSON = String . toPathPiece
+  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 RenderRoute site => Hashable (Route site) where
+  hashWithSalt s = hashWithSalt s . routeToPathPiece
 
 
 instance Monad FormResult where
@@ -77,3 +101,5 @@ instance Extend FormResult where
   duplicated (FormSuccess x)    = FormSuccess $ FormSuccess x
   duplicated  FormMissing       = FormMissing
   duplicated (FormFailure errs) = FormFailure errs
+
+

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

start.sh

@@ -1,12 +1,11 @@
 #!/usr/bin/env bash
 
 unset HOST
-export DETAILED_LOGGING=true
+export DETAILED_LOGGING=${DETAILED_LOGGIN:-true}
-export LOG_ALL=false
+export LOG_ALL=${LOG_ALL:-false}
-export LOGLEVEL=info
+export LOGLEVEL=${LOGLEVEL:-info}
-export DUMMY_LOGIN=true
+export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
-export ALLOW_DEPRECATED=true
+export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
-export PWFILE=users.yml
 
 move-back() {
     mv -v .stack-work .stack-work-run

templates/courseLecInvite.hamlet

@@ -0,0 +1,3 @@
+<p>
+  _{MsgCourseLecInviteExplanation}
+^{btnWidget}

templates/mail/editNotifications.hamlet

@@ -1,4 +1,3 @@
 <p>      
-  <a href=@{ProfileR}>
+  <a href=#{editNotificationsUrl'}>
-    _{MsgProfileHeading}
+    _{MsgMailEditNotifications}
-  \ _{MsgMailEditNotifications}

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}

templates/profile.hamlet

@@ -1,2 +0,0 @@
-<div .profile>
-  ^{settingsForm}

templates/profile/profile.hamlet

@@ -0,0 +1,13 @@
+$newline never
+<section>
+  ^{settingsForm}
+<section>
+  ^{tokenExplanation}
+  <p>
+    _{MsgTokensLastReset}:
+    $maybe tResetTime' <- tResetTime
+      \ #{tResetTime'}
+    $nothing
+      \ _{MsgNever}
+    <br />
+    ^{tokenForm}

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.

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 --coverage --fast --flag uniworx:dev --flag uniworx:library-only ${@}

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)
@@ -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"

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
 

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"