From bc47dcf43f08fdc6e9b52dc205fbabea1893259f Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Thu, 9 Apr 2020 10:30:25 +0200
Subject: [PATCH 1/7] feat(tokens): multiple authorities

---
 messages/uniworx/de-de-formal.msg          |  1 +
 messages/uniworx/en-eu.msg                 |  1 +
 src/Foundation.hs                          | 21 ++++++++++--------
 src/Handler/Course/LecturerInvite.hs       |  4 +++-
 src/Handler/Course/ParticipantInvite.hs    |  2 +-
 src/Handler/Exam/CorrectorInvite.hs        |  4 +++-
 src/Handler/Exam/RegistrationInvite.hs     |  2 +-
 src/Handler/ExamOffice/Users.hs            |  2 +-
 src/Handler/ExternalExam/StaffInvite.hs    |  4 +++-
 src/Handler/Sheet.hs                       |  2 +-
 src/Handler/Submission.hs                  |  2 +-
 src/Handler/Tutorial/TutorInvite.hs        |  4 +++-
 src/Handler/Users.hs                       |  2 +-
 src/Handler/Utils/Invitations.hs           |  2 +-
 src/Jobs/Handler/ChangeUserDisplayEmail.hs |  3 ++-
 src/Jobs/Handler/SendNotification/Utils.hs |  3 ++-
 src/Jobs/Handler/SendPasswordReset.hs      |  3 ++-
 src/Model/Tokens/Bearer.hs                 | 25 ++++++++++++++--------
 src/Utils/Tokens.hs                        |  6 ++++--
 19 files changed, 59 insertions(+), 34 deletions(-)

diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg
index d603bb15a..6bd109c2c 100644
--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@@ -403,6 +403,7 @@ 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.
+UnauthorizedTokenInvalidNoAuthority: Ihr Authorisierungs-Token nennt keine Nutzer, auf deren Rechten es basiert.
 UnauthorizedTokenInvalidAuthority: Ihr Authorisierungs-Token basiert auf den Rechten eines Nutzers, der nicht mehr existiert.
 UnauthorizedTokenInvalidAuthorityGroup: Ihr Authorisierungs-Token basiert auf den Rechten einer Gruppe von Nutzern, die nicht mehr existiert.
 UnauthorizedTokenInvalidAuthorityValue: Ihr Authorisierungs-Token basiert auf Rechten, deren Spezifikation nicht interpretiert werden konnte.
diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg
index 9862452f0..ccef9a61e 100644
--- a/messages/uniworx/en-eu.msg
+++ b/messages/uniworx/en-eu.msg
@@ -401,6 +401,7 @@ UnauthorizedTokenExpired: Your authorisation-token is expired.
 UnauthorizedTokenNotStarted: Your authorisation-token is not yet valid.
 UnauthorizedTokenInvalid: Your authorisation-token could not be processed.
 UnauthorizedTokenInvalidRoute: Your authorisation-token is not valid for this page.
+UnauthorizedTokenInvalidNoAuthority: Your authorisation-token does not list any users on whose rights it is based.
 UnauthorizedTokenInvalidAuthority: Your authorisation-token is based in an user's rights who does not exist anymore.
 UnauthorizedTokenInvalidAuthorityGroup: Your authorisation-token is based in an user groups rights which does not exist anymore.
 UnauthorizedTokenInvalidAuthorityValue: The specification of the rights in which your authorisation-token is based, could not be interpreted.
diff --git a/src/Foundation.hs b/src/Foundation.hs
index bc289fd3e..cba51a599 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -332,22 +332,25 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
         Left tVal
           | JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do
               Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active
-              return userGroupMemberUser
+              return $ Set.singleton userGroupMemberUser
           | otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue
-        Right uid -> return uid
-        
-      User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get bearerAuthority'
-      guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
+        Right uids -> return uids
 
       let
         -- Prevent infinite loops
         noTokenAuth :: AuthDNF -> AuthDNF
         noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
 
-      authorityVal <- do
-        dnf <- either throwM return $ routeAuthTags route
-        fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just bearerAuthority') route isWrite
-      guardExceptT (is _Authorized authorityVal) authorityVal
+      guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority
+
+      forM_ bearerAuthority' $ \uid -> do
+        User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get uid
+        guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
+
+        authorityVal <- do
+          dnf <- either throwM return $ routeAuthTags route
+          fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just uid) route isWrite
+        guardExceptT (is _Authorized authorityVal) authorityVal
 
       whenIsJust bearerAddAuth $ \addDNF -> do
         $logDebugS "validateToken" $ tshow addDNF
diff --git a/src/Handler/Course/LecturerInvite.hs b/src/Handler/Course/LecturerInvite.hs
index 0e410a597..ac1ab7480 100644
--- a/src/Handler/Course/LecturerInvite.hs
+++ b/src/Handler/Course/LecturerInvite.hs
@@ -17,6 +17,8 @@ import Data.Aeson hiding (Result(..))
 
 import Text.Hamlet (ihamlet)
 
+import qualified Data.Set as Set
+
 
 instance IsInvitableJunction Lecturer where
   type InvitationFor Lecturer = Course
@@ -65,7 +67,7 @@ lecturerInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right <$> liftHandler requireAuthId
+      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandler $ toJunction <$> case mlType of
diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs
index cfdba213a..d3e7cd5e9 100644
--- a/src/Handler/Course/ParticipantInvite.hs
+++ b/src/Handler/Course/ParticipantInvite.hs
@@ -81,7 +81,7 @@ participantInvitationConfig = InvitationConfig{..}
     invitationHeading     (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
     invitationExplanation  _                    _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right <$> liftHandler requireAuthId
+      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs
index 2cb691360..205c8bf0f 100644
--- a/src/Handler/Exam/CorrectorInvite.hs
+++ b/src/Handler/Exam/CorrectorInvite.hs
@@ -16,6 +16,8 @@ import Text.Hamlet (ihamlet)
 
 import Data.Aeson hiding (Result(..))
 
+import qualified Data.Set as Set
+
   
 instance IsInvitableJunction ExamCorrector where
   type InvitationFor ExamCorrector = Exam
@@ -67,7 +69,7 @@ examCorrectorInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right <$> liftHandler requireAuthId
+      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ _ _ = pure (JunctionExamCorrector, ())
diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs
index be7decbf4..1f55b34dd 100644
--- a/src/Handler/Exam/RegistrationInvite.hs
+++ b/src/Handler/Exam/RegistrationInvite.hs
@@ -77,7 +77,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
     invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
-      itAuthority <- Right <$> liftHandler requireAuthId
+      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
       let itExpiresAt = Just $ Just invDBExamRegistrationDeadline
           itAddAuth
             | not invDBExamRegistrationCourseRegister
diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs
index ab5588677..ac7b110ba 100644
--- a/src/Handler/ExamOffice/Users.hs
+++ b/src/Handler/ExamOffice/Users.hs
@@ -67,7 +67,7 @@ examOfficeUserInvitationConfig = InvitationConfig{..}
       return . SomeMessage $ MsgExamOfficeUserInviteHeading userDisplayName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamOfficeUserInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right <$> liftHandler requireAuthId
+      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
       let itExpiresAt = Nothing
           itStartsAt = Nothing
           itAddAuth = Nothing
diff --git a/src/Handler/ExternalExam/StaffInvite.hs b/src/Handler/ExternalExam/StaffInvite.hs
index 0e9414913..cdc2a464d 100644
--- a/src/Handler/ExternalExam/StaffInvite.hs
+++ b/src/Handler/ExternalExam/StaffInvite.hs
@@ -13,6 +13,8 @@ import Handler.Utils.Invitations
 import Text.Hamlet (ihamlet)
 import Data.Aeson hiding (Result(..))
 
+import qualified Data.Set as Set
+
 
 instance IsInvitableJunction ExternalExamStaff where
   type InvitationFor ExternalExamStaff = ExternalExam
@@ -59,7 +61,7 @@ externalExamStaffInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ ExternalExam{..}) _ = return . SomeMessage $ MsgExternalExamStaffInviteHeading externalExamCourseName externalExamExamName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExternalExamStaffInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right <$> liftHandler requireAuthId
+      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing (Just Nothing) Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ (InvDBDataExternalExamStaff, _) _ = pure (JunctionExternalExamStaff, ())
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 137fa3c64..f12c355f8 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -881,7 +881,7 @@ correctorInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right <$> liftHandler requireAuthId
+      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ())
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index a89be407d..d4c0ba631 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -104,7 +104,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
     invitationTokenConfig (Entity _ Submission{..}) _ = do
       Sheet{..} <- getJust submissionSheet
       Course{..} <- getJust sheetCourse
-      itAuthority <- Right <$> liftHandler requireAuthId
+      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
       itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR)
       let itExpiresAt = Nothing
           itStartsAt = Nothing
diff --git a/src/Handler/Tutorial/TutorInvite.hs b/src/Handler/Tutorial/TutorInvite.hs
index bcb002f4d..e8688da59 100644
--- a/src/Handler/Tutorial/TutorInvite.hs
+++ b/src/Handler/Tutorial/TutorInvite.hs
@@ -13,6 +13,8 @@ import Handler.Utils.Invitations
 import Data.Aeson hiding (Result(..))
 import Text.Hamlet (ihamlet)
 
+import qualified Data.Set as Set
+
 
 instance IsInvitableJunction Tutor where
   type InvitationFor Tutor = Tutorial
@@ -64,7 +66,7 @@ tutorInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right <$> liftHandler requireAuthId
+      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ _ _ = pure (JunctionTutor, ())
diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index cec5533b6..a3d860a5e 100644
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@@ -571,7 +571,7 @@ functionInvitationConfig = InvitationConfig{..}
       MsgRenderer mr <- getMsgRenderer
       return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|]
     invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do
-      itAuthority <- Right <$> liftHandler requireAuthId
+      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
       let itExpiresAt = Just $ Just invDBUserFunctionDeadline
           itAddAuth = Nothing
           itStartsAt = Nothing
diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs
index 637aeb25a..2537ace7d 100644
--- a/src/Handler/Utils/Invitations.hs
+++ b/src/Handler/Utils/Invitations.hs
@@ -140,7 +140,7 @@ data InvitationConfig junction = forall formCtx. InvitationConfig
 
 -- | Additional configuration needed for an invocation of `bearerToken`
 data InvitationTokenConfig = InvitationTokenConfig
-  { itAuthority :: Either Value UserId
+  { itAuthority :: Either Value (Set UserId)
   , itAddAuth   :: Maybe AuthDNF
   , itExpiresAt :: Maybe (Maybe UTCTime)
   , itStartsAt  :: Maybe UTCTime
diff --git a/src/Jobs/Handler/ChangeUserDisplayEmail.hs b/src/Jobs/Handler/ChangeUserDisplayEmail.hs
index ff48ed9a2..db9747729 100644
--- a/src/Jobs/Handler/ChangeUserDisplayEmail.hs
+++ b/src/Jobs/Handler/ChangeUserDisplayEmail.hs
@@ -7,12 +7,13 @@ import Import
 import Handler.Utils.Mail
 import qualified Data.HashSet as HashSet
 import qualified Data.CaseInsensitive as CI
+import qualified Data.Set as Set
 
 import Text.Hamlet
 
 dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> Handler ()
 dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = do
-  bearer <- bearerRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
+  bearer <- bearerRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (Right $ Set.singleton jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
   jwt <- encodeBearer bearer
   let
     setDisplayEmailUrl :: SomeRoute UniWorX
diff --git a/src/Jobs/Handler/SendNotification/Utils.hs b/src/Jobs/Handler/SendNotification/Utils.hs
index 4b894286e..ce234035f 100644
--- a/src/Jobs/Handler/SendNotification/Utils.hs
+++ b/src/Jobs/Handler/SendNotification/Utils.hs
@@ -8,6 +8,7 @@ import Import
 import Text.Hamlet
 
 import qualified Data.HashSet as HashSet
+import qualified Data.Set as Set
 
 
 ihamletSomeMessage :: HtmlUrlI18n UniWorXMessage (Route UniWorX) -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
@@ -16,7 +17,7 @@ ihamletSomeMessage f trans = f $ trans . SomeMessage
 mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
 mkEditNotifications uid = liftHandler $ do
   cID <- encrypt uid
-  jwt <- encodeBearer =<< bearerToken (Right uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
+  jwt <- encodeBearer =<< bearerToken (Right $ Set.singleton uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
   let
     editNotificationsUrl :: SomeRoute UniWorX
     editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])
diff --git a/src/Jobs/Handler/SendPasswordReset.hs b/src/Jobs/Handler/SendPasswordReset.hs
index d61934db6..504d0d2ce 100644
--- a/src/Jobs/Handler/SendPasswordReset.hs
+++ b/src/Jobs/Handler/SendPasswordReset.hs
@@ -10,6 +10,7 @@ import Handler.Utils.Users
 import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteArray as BA
 import qualified Data.HashSet as HashSet
+import qualified Data.Set as Set
 
 import Text.Hamlet
 
@@ -29,7 +30,7 @@ dispatchJobSendPasswordReset jRecipient = userMailT jRecipient $ do
       LTUUnique utc' _ -> utc'
       _other           -> UTCTime (addDays 2 $ utctDay now) 0
 
-  resetBearer' <- bearerToken (Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
+  resetBearer' <- bearerToken (Right $ Set.singleton jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
   let resetBearer = resetBearer'
         & bearerRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
   encodedBearer <- encodeBearer resetBearer
diff --git a/src/Model/Tokens/Bearer.hs b/src/Model/Tokens/Bearer.hs
index c1c4578fb..3dc7413f8 100644
--- a/src/Model/Tokens/Bearer.hs
+++ b/src/Model/Tokens/Bearer.hs
@@ -13,7 +13,7 @@ import Yesod.Core.Instances ()
   
 import Model
 import Model.Tokens.Lens
-import Utils (assertM')
+import Utils (assertM', foldMapM)
 import Utils.Lens hiding ((.=))
 import Data.Aeson.Lens (AsJSON(..))
 
@@ -39,13 +39,15 @@ import Data.Binary (Binary)
 
 import qualified Data.CryptoID.Class.ImplicitNamespace as I
 
+import qualified Data.Set as Set
+
 
 
 -- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
 data BearerToken site = BearerToken
   { bearerIdentifier   :: TokenId
     -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
-  , bearerAuthority    :: Either Value (AuthId site)
+  , bearerAuthority    :: Either Value (Set (AuthId site))
     -- ^ Tokens only grant rights the `bearerAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `bearerAuthority`)
   , bearerRoutes       :: Maybe (HashSet (Route site))
     -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
@@ -63,8 +65,8 @@ data BearerToken site = BearerToken
   } 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)
+deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site), Ord (AuthId site)) => Read (BearerToken site)
+deriving instance (Show (AuthId site), Show (Route site), Ord (AuthId site)) => Show (BearerToken site)
 
 instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site)) => Binary (BearerToken site)
 
@@ -109,7 +111,7 @@ bearerToJSON :: forall m.
 --
 -- Monadic context is needed because `AuthId`s are encrypted during encoding
 bearerToJSON BearerToken{..} = do
-  cID <- either (return . Left) (fmap Right . I.encrypt) bearerAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m))))
+  cID <- either (return . Left) (fmap Right . foldMapM (fmap Set.singleton . I.encrypt)) bearerAuthority :: m (Either Value (Set (CryptoUUID (AuthId (HandlerSite m)))))
   let stdPayload = Jose.JwtClaims
         { jwtIss = Just $ toPathPiece bearerIssuedBy
         , jwtSub = Nothing
@@ -119,8 +121,12 @@ bearerToJSON BearerToken{..} = do
         , jwtIat = Just . IntDate $ utcTimeToPOSIXSeconds bearerIssuedAt
         , jwtJti = Just $ toPathPiece bearerIdentifier
         }
+
+      authorityToJSON (Left  v  ) = v
+      authorityToJSON (Right ids) | [uid] <- toList ids = toJSON uid
+                                  | otherwise           = toJSON ids
   return . JSON.object $
-    catMaybes [ Just $ "authority" .= either id toJSON cID
+    catMaybes [ Just $ "authority" .= authorityToJSON cID
               , ("routes" .=) <$> bearerRoutes
               , ("add-auth" .=) <$> bearerAddAuth
               , ("restrictions" .=) <$> assertM' (not . HashMap.null) bearerRestrictions
@@ -128,7 +134,8 @@ bearerToJSON BearerToken{..} = do
     ++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
 
 bearerParseJSON :: forall site.
-                  ( HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
+                  ( Ord (AuthId site)
+                  , HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
                   , ParseRoute site
                   , Hashable (Route site)
                   )
@@ -140,8 +147,8 @@ bearerParseJSON :: forall site.
 --
 -- It's usually easier to use `Utils.Tokens.bearerParseJSON'`
 bearerParseJSON v@(Object o) = do
-  bearerAuthority' <- lift $ (Right <$> o .: "authority") <|> (Left <$> o .: "authority") :: ReaderT CryptoIDKey Parser (Either Value (CryptoUUID (AuthId site)))
-  bearerAuthority <- either (return . Left) (fmap Right . I.decrypt) bearerAuthority'
+  bearerAuthority' <- lift $ (Right <$> o .: "authority") <|> (Right . Set.singleton <$> o .: "authority") <|> (Left <$> o .: "authority") :: ReaderT CryptoIDKey Parser (Either Value (Set (CryptoUUID (AuthId site))))
+  bearerAuthority <- either (return . Left) (fmap Right . foldMapM (fmap Set.singleton . I.decrypt)) bearerAuthority'
 
   bearerRoutes        <- lift $ o .:? "routes"
   bearerAddAuth       <- lift $ o .:? "add-auth"
diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs
index e7853f525..0e05629aa 100644
--- a/src/Utils/Tokens.hs
+++ b/src/Utils/Tokens.hs
@@ -33,7 +33,8 @@ import Text.Blaze (Markup)
 
 
 bearerParseJSON' :: forall m.
-                  ( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
+                  ( Ord (AuthId (HandlerSite m))
+                  , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
                   , ParseRoute (HandlerSite m)
                   , Hashable (Route (HandlerSite m))
                   , MonadHandler m
@@ -53,7 +54,7 @@ bearerToken :: forall m.
                , HasClusterID (HandlerSite m) ClusterId
                , HasAppSettings (HandlerSite m)
                )
-            => Either Value (AuthId (HandlerSite m))
+            => Either Value (Set (AuthId (HandlerSite m)))
             -> Maybe (HashSet (Route (HandlerSite m)))
             -> Maybe AuthDNF
             -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
@@ -108,6 +109,7 @@ instance Exception BearerTokenException
 decodeBearer :: forall m.
                ( MonadHandler m
                , HasJSONWebKeySet (HandlerSite m) JwkSet
+               , Ord (AuthId (HandlerSite m))
                , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
                , MonadCryptoKey m ~ CryptoIDKey
                , MonadCrypto m

From 0d399247773a0e4799602c49e6c06de906b43fec Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Thu, 9 Apr 2020 11:56:29 +0200
Subject: [PATCH 2/7] feat(news): show system messages

---
 frontend/src/app.sass                 | 24 +++++++++++++++++
 messages/uniworx/de-de-formal.msg     |  1 +
 messages/uniworx/en-eu.msg            |  1 +
 models/system-messages.model          |  1 +
 src/Foundation.hs                     |  2 ++
 src/Handler/News.hs                   | 22 ++++++++++++++++
 src/Handler/SystemMessage.hs          | 38 +++++++++++++--------------
 src/Utils/SystemMessage.hs            | 12 +++++++++
 templates/news/system-messages.hamlet |  9 +++++++
 test/Database/Fill.hs                 |  9 ++++---
 10 files changed, 95 insertions(+), 24 deletions(-)
 create mode 100644 templates/news/system-messages.hamlet

diff --git a/frontend/src/app.sass b/frontend/src/app.sass
index 265d516b2..220f09d1c 100644
--- a/frontend/src/app.sass
+++ b/frontend/src/app.sass
@@ -1265,3 +1265,27 @@ a.breadcrumbs__home
 
   &__label
     grid-area: label
+
+.news__system-messages
+  overflow-y: auto
+  max-height: 75vh
+
+.news__system-message
+  border-left: 3px solid var(--color-info)
+  padding-left: 17px
+  background-color: rgba(0,0,0,0.015)
+
+  & + .news__system-message
+    margin-top: 17px
+  
+  &--info
+    border-left-color: var(--color-info)
+
+  &--error
+    border-left-color: var(--color-error)
+    
+  &--warning
+    border-left-color: var(--color-warning)
+    
+  &--success
+    border-left-color: var(--color-success)
diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg
index 6bd109c2c..8f0a55fa7 100644
--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@@ -1064,6 +1064,7 @@ HelpSent: Ihre Supportanfrage wurde weitergeleitet.
 InfoLecturerTitle: Hinweise für Veranstalter
 
 
+SystemMessageNewsOnly: Nur auf "Aktuelles"
 SystemMessageFrom: Sichtbar ab
 SystemMessageTo: Sichtbar bis
 SystemMessageAuthenticatedOnly: Nur angemeldet
diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg
index ccef9a61e..2d107c14b 100644
--- a/messages/uniworx/en-eu.msg
+++ b/messages/uniworx/en-eu.msg
@@ -1063,6 +1063,7 @@ HelpSent: Your support request has been sent.
 
 InfoLecturerTitle: Information for lecturers
 
+SystemMessageNewsOnly: Only on "News"
 SystemMessageFrom: Visible from
 SystemMessageTo: Visible to
 SystemMessageAuthenticatedOnly: Only logged in users
diff --git a/models/system-messages.model b/models/system-messages.model
index f2692ab64..7722e9b85 100644
--- a/models/system-messages.model
+++ b/models/system-messages.model
@@ -1,6 +1,7 @@
 -- Messages shown to all users as soon as they visit the site/log in (i.e.: "System is going down for maintenance next sunday")
 -- Only administrators (of any school) should be able to create these via a web-interface
 SystemMessage
+    newsOnly            Bool default=False
     from                UTCTime Maybe -- Message is not shown before this date has passed (never shown, if null)
     to                  UTCTime Maybe -- Message is shown until this date has passed (shown forever, if null)
     authenticatedOnly   Bool -- Show message to all users upon visiting the site or only upon login?
diff --git a/src/Foundation.hs b/src/Foundation.hs
index cba51a599..350076572 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -1936,6 +1936,8 @@ applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
 applySystemMessages = liftHandler . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage
   where
     applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
+      guard $ not systemMessageNewsOnly
+      
       cID <- encrypt smId
       void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False
 
diff --git a/src/Handler/News.hs b/src/Handler/News.hs
index 9ae8ec113..19f579046 100644
--- a/src/Handler/News.hs
+++ b/src/Handler/News.hs
@@ -9,12 +9,18 @@ import Database.Esqueleto.Utils.TH
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 
+import qualified Data.Conduit.List as C (consume, mapMaybeM)
+import qualified Data.Conduit.Combinators as C
+
+
 getNewsR :: Handler Html
 getNewsR = do
   muid <- maybeAuthId
   defaultLayout $ do
     setTitleI MsgNewsHeading
 
+    newsSystemMessages
+
     when (is _Nothing muid) $
       notificationWidget NotificationBroad Info $(i18nWidgetFile "pitch")
   
@@ -26,6 +32,22 @@ getNewsR = do
         $(i18nWidgetFile "unauth-news")
 
 
+newsSystemMessages :: Widget
+newsSystemMessages = do
+  now <- liftIO getCurrentTime
+  
+  messages' <- liftHandler . runDB . runConduit $
+       selectKeys [] []
+    .| C.filterM (hasReadAccessTo . MessageR <=< encrypt)
+    .| C.mapMaybeM (\smId -> fmap (view _1 &&& systemMessageToTranslation smId) <$> getSystemMessage appLanguages smId)
+    .| C.filter (\(SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo)
+    .| C.consume
+  let messages = sortOn (\(SystemMessage{..}, _) -> (NTop systemMessageFrom, systemMessageSeverity)) messages'
+
+  unless (null messages)
+    $(widgetFile "news/system-messages")
+
+
 newsUpcomingSheets :: UserId -> Widget
 newsUpcomingSheets uid = do
   cTime <- liftIO getCurrentTime
diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs
index 28a9b94e9..c82faa5b0 100644
--- a/src/Handler/SystemMessage.hs
+++ b/src/Handler/SystemMessage.hs
@@ -28,13 +28,14 @@ postMessageR cID = do
     mkForm = do
       ((modifyRes, modifyView), modifyEnctype) <- runFormPost . identifyForm FIDSystemMessageModify . renderAForm FormStandard
         $ SystemMessage
-          <$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
-          <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
-          <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
+          <$> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just systemMessageNewsOnly)
+          <*> aopt  utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
+          <*> aopt  utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
+          <*> apopt checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
           <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity)
           <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageDefaultLanguage)
-          <*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageContent)
-          <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageSummary)
+          <*> areq  htmlField (fslI MsgSystemMessageContent) (Just systemMessageContent)
+          <*> aopt  htmlField (fslI MsgSystemMessageSummary) (Just systemMessageSummary)
 
       ts <- runDB $ selectList [ SystemMessageTranslationMessage ==. smId ] [Asc SystemMessageTranslationLanguage]
       let ts' = Map.fromList $ (systemMessageTranslationLanguage . entityVal &&& id) <$> ts
@@ -122,16 +123,8 @@ postMessageR cID = do
   siteLayout' (toWidget <$> summary)
     $(widgetFile "system-message")
   where
-    modifySystemMessage smId SystemMessage{..} = do
-      runDB $ update smId
-        [ SystemMessageFrom =. systemMessageFrom
-        , SystemMessageTo =. systemMessageTo
-        , SystemMessageAuthenticatedOnly =. systemMessageAuthenticatedOnly
-        , SystemMessageSeverity =. systemMessageSeverity
-        , SystemMessageDefaultLanguage =. systemMessageDefaultLanguage
-        , SystemMessageContent =. systemMessageContent
-        , SystemMessageSummary =. systemMessageSummary
-        ]
+    modifySystemMessage smId sm = do
+      runDB $ replace smId sm
       addMessageI Success MsgSystemMessageEditSuccess
       redirect $ MessageR cID
 
@@ -165,6 +158,7 @@ postMessageListR = do
       , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR ciphertext
       , sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
       , sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo
+      , sortable (Just "news-only") (i18nCell MsgSystemMessageNewsOnly) $ \DBRow { dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageNewsOnly
       , sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly
       , sortable (Just "severity") (i18nCell MsgSystemMessageSeverity) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> i18nCell systemMessageSeverity
       , sortable Nothing (i18nCell MsgSystemMessageSummaryContent) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, smT) } -> let
@@ -192,6 +186,9 @@ postMessageListR = do
       , ( "to"
         , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageTo
         )
+      , ( "news-only"
+        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageNewsOnly
+        )
       , ( "authenticated"
         , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageAuthenticatedOnly
         )
@@ -254,13 +251,14 @@ postMessageListR = do
 
   MsgRenderer mr <- getMsgRenderer
   ((addRes, addView), addEncoding) <- runFormPost . identifyForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
-    <$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing
-    <*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing
-    <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing
-    <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) Nothing
+    <$> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just False)
+    <*> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just Nothing)
+    <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just Nothing)
+    <*> apopt checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just False)
+    <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just Info)
     <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just $ NonEmpty.head appLanguages)
     <*> areq htmlField (fslI MsgSystemMessageContent) Nothing
-    <*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing
+    <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just Nothing)
 
   case addRes of
     FormMissing -> return ()
diff --git a/src/Utils/SystemMessage.hs b/src/Utils/SystemMessage.hs
index 8de3add92..713e2dd93 100644
--- a/src/Utils/SystemMessage.hs
+++ b/src/Utils/SystemMessage.hs
@@ -17,3 +17,15 @@ getSystemMessage appLanguages smId = runMaybeT $ do
     avL = NonEmpty.sortWith (\l -> NTop $ findIndex (langMatches l) $ NonEmpty.toList appLanguages) $ systemMessageDefaultLanguage :| map (systemMessageTranslationLanguage . entityVal) translations
   lang <- selectLanguage avL
   return (SystemMessage{..}, find (langMatches lang . systemMessageTranslationLanguage) $ map entityVal translations)
+
+systemMessageToTranslation :: SystemMessageId
+                           -> (SystemMessage, Maybe SystemMessageTranslation)
+                           -> SystemMessageTranslation
+systemMessageToTranslation systemMessageTranslationMessage (SystemMessage{..}, Nothing)
+  = SystemMessageTranslation
+      { systemMessageTranslationMessage
+      , systemMessageTranslationLanguage = systemMessageDefaultLanguage
+      , systemMessageTranslationContent  = systemMessageContent
+      , systemMessageTranslationSummary  = systemMessageSummary
+      }
+systemMessageToTranslation _ (_, Just t) = t
diff --git a/templates/news/system-messages.hamlet b/templates/news/system-messages.hamlet
new file mode 100644
index 000000000..b3e008779
--- /dev/null
+++ b/templates/news/system-messages.hamlet
@@ -0,0 +1,9 @@
+$newline never
+<section .news__system-messages>
+  $forall (SystemMessage{systemMessageSeverity}, SystemMessageTranslation{systemMessageTranslationSummary, systemMessageTranslationContent}) <- messages
+    <div .news__system-message .news__system-message--#{toPathPiece systemMessageSeverity}>
+      $maybe summary <- systemMessageTranslationSummary
+        <h2>#{summary}
+        #{systemMessageTranslationContent}
+      $nothing
+        <h2>#{systemMessageTranslationContent}
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index 26a0399fb..1e848143d 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -894,11 +894,12 @@ fillDb = do
   void . insert' $ Lecturer gkleen dbs CourseLecturer
   void . insert' $ Lecturer jost   dbs CourseAssistant
 
-  testMsg <- insert $ SystemMessage (Just now) Nothing False Success "de" "System-Nachrichten werden angezeigt" Nothing
+  testMsg <- insert $ SystemMessage False (Just now) Nothing False Success "de" "System-Nachrichten werden angezeigt" Nothing
   void . insert $ SystemMessageTranslation testMsg "en" "System messages may be translated" Nothing
-  void . insert $ SystemMessage (Just now) Nothing False Info "de" "System-Nachrichten können längeren Inhalt enthalten" (Just "System-Nachricht Zusammenfassung")
-  void . insert $ SystemMessage (Just now) (Just now) False Info "de" "System-Nachrichten haben Ablaufdaten" Nothing
-  void . insert $ SystemMessage Nothing Nothing False Error "de" "System-Nachrichten können Inaktiv sein" Nothing
+  void . insert $ SystemMessage False (Just now) Nothing False Info "de" "System-Nachrichten können längeren Inhalt enthalten" (Just "System-Nachricht Zusammenfassung")
+  void . insert $ SystemMessage False (Just now) (Just now) False Info "de" "System-Nachrichten haben Ablaufdaten" Nothing
+  void . insert $ SystemMessage False Nothing Nothing False Error "de" "System-Nachrichten können Inaktiv sein" Nothing
+  void . insert $ SystemMessage True (Just now) Nothing False Error "de" "System-Nachrichten können nur auf \"Aktuelles\" angezeigt werden" Nothing
 
 
   funAlloc <- insert' Allocation

From 19e5d1c05f60d33e21302eabce757812dfd0797a Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Thu, 9 Apr 2020 12:01:22 +0200
Subject: [PATCH 3/7] chore(release): 14.5.0

---
 CHANGELOG.md      | 10 ++++++++++
 package-lock.json |  2 +-
 package.json      |  2 +-
 package.yaml      |  2 +-
 4 files changed, 13 insertions(+), 3 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 28fc94b75..47b8ef38d 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -2,6 +2,16 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [14.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.4.0...v14.5.0) (2020-04-09)
+
+
+### Features
+
+* **news:** show system messages ([0d39924](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0d39924))
+* **tokens:** multiple authorities ([bc47dcf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bc47dcf))
+
+
+
 ## [14.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.1.1...v14.4.0) (2020-04-07)
 
 
diff --git a/package-lock.json b/package-lock.json
index 8047ddc19..18c0964a5 100644
--- a/package-lock.json
+++ b/package-lock.json
@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "14.4.0",
+  "version": "14.5.0",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {
diff --git a/package.json b/package.json
index bb1079892..1000885ae 100644
--- a/package.json
+++ b/package.json
@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "14.4.0",
+  "version": "14.5.0",
   "description": "",
   "keywords": [],
   "author": "",
diff --git a/package.yaml b/package.yaml
index 9ae53b290..5ef864bec 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
 name:    uniworx
-version: 14.4.0
+version: 14.5.0
 
 dependencies:
   - base

From 738ab7b738bf2264d74023aa90fa23461b21ac2c Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Thu, 9 Apr 2020 15:23:46 +0200
Subject: [PATCH 4/7] feat: admin interface to issue tokens

---
 messages/uniworx/de-de-formal.msg             |  19 ++++
 messages/uniworx/en-eu.msg                    |  19 ++++
 routes                                        |   1 +
 src/Foundation.hs                             |  13 ++-
 src/Handler/Admin.hs                          |   1 +
 src/Handler/Admin/Tokens.hs                   | 105 ++++++++++++++++++
 src/Handler/Course/LecturerInvite.hs          |   4 +-
 src/Handler/Course/ParticipantInvite.hs       |   4 +-
 src/Handler/Exam/CorrectorInvite.hs           |   4 +-
 src/Handler/Exam/RegistrationInvite.hs        |   4 +-
 src/Handler/ExamOffice/Users.hs               |   4 +-
 src/Handler/ExternalExam/StaffInvite.hs       |   4 +-
 src/Handler/Metrics.hs                        |   2 +-
 src/Handler/Sheet.hs                          |   3 +-
 src/Handler/Submission.hs                     |   4 +-
 src/Handler/Tutorial/TutorInvite.hs           |   4 +-
 src/Handler/Users.hs                          |   4 +-
 src/Handler/Utils/Invitations.hs              |   2 +-
 src/Jobs/Handler/ChangeUserDisplayEmail.hs    |   3 +-
 src/Jobs/Handler/SendNotification/Utils.hs    |   3 +-
 src/Jobs/Handler/SendPasswordReset.hs         |   3 +-
 src/Model/Tokens/Bearer.hs                    |  28 ++---
 src/Model/Types/Security.hs                   |   9 ++
 src/Utils/Tokens.hs                           |   6 +-
 templates/admin-tokens.hamlet                 |  10 ++
 .../massinput/token-restrictions/add.hamlet   |   7 ++
 .../massinput/token-restrictions/cell.hamlet  |   6 +
 .../token-restrictions/layout.hamlet          |  13 +++
 translate.hs                                  |   4 +-
 29 files changed, 252 insertions(+), 41 deletions(-)
 create mode 100644 src/Handler/Admin/Tokens.hs
 create mode 100644 templates/admin-tokens.hamlet
 create mode 100644 templates/widgets/massinput/token-restrictions/add.hamlet
 create mode 100644 templates/widgets/massinput/token-restrictions/cell.hamlet
 create mode 100644 templates/widgets/massinput/token-restrictions/layout.hamlet

diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg
index 8f0a55fa7..6367327a3 100644
--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@@ -1157,6 +1157,7 @@ MenuUserPassword: Passwort
 MenuAdminTest: Admin-Demo
 MenuMessageList: Systemnachrichten
 MenuAdminErrMsg: Fehlermeldung entschlüsseln
+MenuAdminTokens: Tokens ausstellen
 MenuProfileData: Persönliche Daten
 MenuTermCreate: Neues Semester anlegen
 MenuCourseNew: Neuen Kurs anlegen
@@ -2427,3 +2428,21 @@ AllocationUsersCount: Teilnehmer
 AllocationCoursesCount: Kurse
 
 CourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen}
+
+BearerTokenUsageWarning: Mit diesem Interface können quesi beliebige Rechte als Tokens kodiert und somit ohne wesentliche weitere Beschränkung frei übertragen werden. Benutzen Sie dieses Interface nur, wenn Sie von einem erfahrenen Entwickler über die Auswirkungen des konkreten Tokens, dass sie ausstellen möchten, beraten wurden!
+BearerTokenAuthorityGroups: Token-Authorität (Gruppen)
+BearerTokenAuthorityGroupsTip: Die primären Benutzer aller angegebenen Gruppen müssen Zugriff auf eine Route haben, damit das Token den Zugriff auf diese Route erlaubt.
+BearerTokenAuthorityUsers: Token-Authorität (Benutzer)
+BearerTokenAuthorityUsersTip: Alle angegebenen Benutzer müssen Zugriff auf eine Route haben, damit das Token den Zugriff auf diese Route erlaubt. Der Aussteller muss, bei mit diesem Benutzerinterface erzeugten Tokens, auch Zugriff auf die Route haben (er wird automatisch der Menge von Token-Authoritäten hinzugefügt).
+BearerTokenAuthorityUnknownUser email@UserEmail: Ein Nutzer mit E-Mail #{email} ist dem System nicht bekannt
+BearerTokenRoutes: Erlaubte Routen
+BearerTokenRoutesTip: Wenn die Token-Validität nach Routen eingeschränkt und keine Routen angegeben werden, ist das Token nirgends gültig.
+BearerTokenRestrictions: Routen-spezifische Einschränkungen
+BearerTokenRestrictRoutes: Token-Validität nach Routen einschränken
+BearerTokenAdditionalAuth: Zusätzliche Authorisierung
+BearerTokenAdditionalAuthTip: Wird hier nichts angegeben, werden keine Einschränkungen daran gesetzt, wer das Token verwenden kann. Es reicht dann der Besitz.
+BearerTokenOverrideExpiration: Ablaufzeitpunkt überschreiben
+BearerTokenExpires: Ablaufzeitpunkt
+BearerTokenExpiresTip: Wird der Ablaufzeitpunkt überschrieben und kein Ablaufzeitpunkt angegeben, ist das Token für immer gültig.
+BearerTokenOverrideStart: Startzeitpunkt
+BearerTokenOverrideStartTip: Wird kein Startzeitpunkt angegeben, wird bei Verwendung des Tokens nur der Ablaufzeitpunkt überprüft.
\ No newline at end of file
diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg
index 2d107c14b..3123c1649 100644
--- a/messages/uniworx/en-eu.msg
+++ b/messages/uniworx/en-eu.msg
@@ -1156,6 +1156,7 @@ MenuUserPassword: Password
 MenuAdminTest: Admin-demo
 MenuMessageList: System messages
 MenuAdminErrMsg: Decrypt error message
+MenuAdminTokens: Issue tokens
 MenuProfileData: Personal information
 MenuTermCreate: Create new semester 
 MenuCourseNew: Create new course
@@ -2427,3 +2428,21 @@ AllocationUsersCount: Participants
 AllocationCoursesCount: Courses
 
 CourseOption tid ssh coursen: #{tid} - #{ssh} - #{coursen}
+
+BearerTokenUsageWarning: Using this interface you are able to encode essentially arbitrary permissions inte bearer tokens. This allows you to freely hand permissions off arbitrarily and without relevant restrictions. Only use this interface if you have discussed the consequences of the specific token, that you want to issue, with an experienced developer!
+BearerTokenAuthorityGroups: Authority (groups)
+BearerTokenAuthorityGroupsTip: All primary users of the groups listed here need to have the requisite permissions to access a route in order for the created token to grant permission to do so as well.
+BearerTokenAuthorityUsers: Authority (users
+BearerTokenAuthorityUsersTip: All users listed here need to have the requisite permissions to access a route in order for the created token to grant permission to do so as well. The user issuing the token using this interface also needs to have permission to access that route (they are automatically added to the list of authorities).
+BearerTokenAuthorityUnknownUser email: Could not find any user with email #{email}
+BearerTokenRoutes: Permitted routes
+BearerTokenRoutesTip: If the token is restricted to certain routes and no routes are listed, the token is valid nowhere.
+BearerTokenRestrictions: Route-specific restrictions
+BearerTokenRestrictRoutes: Restrict token to certain routes
+BearerTokenAdditionalAuth: Additional authorisation
+BearerTokenAdditionalAuthTip: If nothing is entered, no additional authorisation will be performed when the token is used. Mere posession of the token will be sufficient.
+BearerTokenOverrideExpiration: Override expiration time
+BearerTokenExpires: Expiration time
+BearerTokenExpiresTip: If no expiration time is given, the token will not expire. It will be valid forever.
+BearerTokenOverrideStart: Start time
+BearerTokenOverrideStartTip: If no start time is given, only the expiration time will be checked when the token is used.
diff --git a/routes b/routes
index 125b6da56..fcd3c05b0 100644
--- a/routes
+++ b/routes
@@ -55,6 +55,7 @@
 /admin/features               AdminFeaturesR   GET POST
 /admin/test                   AdminTestR       GET POST
 /admin/errMsg                 AdminErrMsgR     GET POST
+/admin/tokens                 AdminTokensR     GET POST
 
 /health                       HealthR          GET             !free
 /instance                     InstanceR        GET             !free
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 350076572..d5a01d22d 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -328,13 +328,13 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
     validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
       guardMExceptT (maybe True (HashSet.member route) bearerRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
 
-      bearerAuthority' <- case bearerAuthority of
+      bearerAuthority' <- flip foldMapM bearerAuthority $ \case
         Left tVal
           | JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do
               Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active
               return $ Set.singleton userGroupMemberUser
           | otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue
-        Right uids -> return uids
+        Right uid -> return $ Set.singleton uid
 
       let
         -- Prevent infinite loops
@@ -2013,6 +2013,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb AdminFeaturesR   = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR 
   breadcrumb AdminTestR       = i18nCrumb MsgMenuAdminTest        $ Just AdminR
   breadcrumb AdminErrMsgR     = i18nCrumb MsgMenuAdminErrMsg      $ Just AdminR
+  breadcrumb AdminTokensR     = i18nCrumb MsgMenuAdminTokens      $ Just AdminR
   
   breadcrumb SchoolListR      = i18nCrumb MsgMenuSchoolList       $ Just AdminR
   breadcrumb (SchoolR ssh SchoolEditR) = maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
@@ -2482,6 +2483,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
               , navQuick'      = mempty
               , navForceActive = False
               }
+          , NavLink
+              { navLabel       = MsgMenuAdminTokens
+              , navRoute       = AdminTokensR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
           , NavLink
               { navLabel       = MsgMenuAdminTest
               , navRoute       = AdminTestR
diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index 0002200e8..0baadf2b8 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -9,6 +9,7 @@ import Handler.Utils
 import Handler.Admin.Test as Handler.Admin
 import Handler.Admin.ErrorMessage as Handler.Admin
 import Handler.Admin.StudyFeatures as Handler.Admin
+import Handler.Admin.Tokens as Handler.Admin
 
 
 getAdminR :: Handler Html
diff --git a/src/Handler/Admin/Tokens.hs b/src/Handler/Admin/Tokens.hs
new file mode 100644
index 000000000..9468bfca0
--- /dev/null
+++ b/src/Handler/Admin/Tokens.hs
@@ -0,0 +1,105 @@
+module Handler.Admin.Tokens
+  ( getAdminTokensR, postAdminTokensR
+  ) where
+
+import Import
+import Handler.Utils
+
+import qualified Data.HashSet as HashSet
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Set as Set
+
+import Control.Arrow (left)
+
+import Jose.Jwt (Jwt(..))
+
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Encode.Pretty as Aeson
+
+import Data.Map ((!), (!?))
+
+import qualified Data.Text as Text
+
+
+data BearerTokenForm = BearerTokenForm
+  { btfAuthority :: HashSet (Either UserGroupName UserId)
+  , btfRoutes    :: Maybe (HashSet (Route UniWorX))
+  , btfRestrict  :: HashMap (Route UniWorX) Value
+  , btfAddAuth   :: Maybe AuthDNF
+  , btfExpiresAt :: Maybe (Maybe UTCTime)
+  , btfStartsAt  :: Maybe UTCTime
+  }
+
+bearerTokenForm :: WForm Handler (FormResult BearerTokenForm)
+bearerTokenForm = do
+  muid <- maybeAuthId
+  
+  btfAuthorityGroups <- aFormToWForm $ HashSet.fromList . map Left <$> massInputListA pathPieceField (const "") (\p -> Just . SomeRoute $ AdminTokensR :#: p) ("token-groups" :: Text) (fslI MsgBearerTokenAuthorityGroups & setTooltip MsgBearerTokenAuthorityGroupsTip) False Nothing
+  btfAuthorityUsers <- fmap (fmap . ofoldMap $ HashSet.singleton . Right) <$> wopt (checkMap (foldMapM $ fmap Set.singleton . left MsgBearerTokenAuthorityUnknownUser) (Set.map Right) $ multiUserField False Nothing) (fslI MsgBearerTokenAuthorityUsers & setTooltip MsgBearerTokenAuthorityUsersTip) (Just $ Set.singleton <$> muid)
+  let btfAuthority' :: FormResult (HashSet (Either UserGroupName UserId))
+      btfAuthority'
+        = (<>) <$> btfAuthorityGroups <*> ((hoistMaybe =<< btfAuthorityUsers) <|> pure HashSet.empty)
+
+  let btfRoutesForm = HashSet.fromList <$> massInputListA routeField (const "") (\p -> Just . SomeRoute $ AdminTokensR :#: p) ("token-routes" :: Text) (fslI MsgBearerTokenRoutes & setTooltip MsgBearerTokenRoutesTip) True Nothing
+  btfRoutes' <- optionalActionW btfRoutesForm (fslI MsgBearerTokenRestrictRoutes) (Just True)
+
+  let btfRestrictForm = massInputAccumEditW miAdd' miCell' (\p -> Just . SomeRoute $ AdminTokensR :#: p) miLayout' ("token-restrictions" :: Text) (fslI MsgBearerTokenRestrictions) False Nothing
+        where miAdd' nudge = fmap (over (mapped . _1) tweakRes) . miForm nudge . Left
+                where tweakRes res = res <&> \(newRoute, newRestr) oldRestrs -> pure (bool [(newRoute, newRestr)] [] $ newRoute `HashMap.member` HashMap.fromList oldRestrs)
+              miCell' nudge = miForm nudge . Right
+              miForm :: (Text -> Text)
+                     -> Either (FieldView UniWorX) (Route UniWorX, Value)
+                     -> Form (Route UniWorX, Value)
+              miForm nudge mode csrf = do
+                (routeRes, routeView) <- mpreq routeField ("" & addName (nudge "route")) (mode ^? _Right . _1)
+                (restrRes, restrView) <- mpreq (checkMap (left Text.pack . Aeson.eitherDecode . encodeUtf8 . fromStrict . unTextarea) (Textarea . toStrict . decodeUtf8 . Aeson.encodePretty) $ textareaField) ("" & addName (nudge "restr")) (mode ^? _Right . _2)
+
+                return ((,) <$> routeRes <*> restrRes, case mode of
+                           Left btn -> $(widgetFile "widgets/massinput/token-restrictions/add")
+                           Right _  -> $(widgetFile "widgets/massinput/token-restrictions/cell")
+                       )
+
+              miLayout' :: MassInputLayout ListLength (Route UniWorX, Value) (Route UniWorX, Value)
+              miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/token-restrictions/layout")
+                
+  btfRestrict' <- fmap HashMap.fromList <$> btfRestrictForm
+
+  btfAddAuth' <- fmap (assertM $ not . Set.null . dnfTerms) <$> wopt pathPieceField (fslI MsgBearerTokenAdditionalAuth & setTooltip MsgBearerTokenAdditionalAuthTip) Nothing
+
+  btfExpiresAt' <- optionalActionW (aopt utcTimeField (fslI MsgBearerTokenExpires & setTooltip MsgBearerTokenExpiresTip) Nothing) (fslI MsgBearerTokenOverrideExpiration) (Just False)
+  btfStartsAt' <- wopt utcTimeField (fslI MsgBearerTokenOverrideStart & setTooltip MsgBearerTokenOverrideStartTip) Nothing
+
+  return $ BearerTokenForm
+    <$> btfAuthority'
+    <*> btfRoutes'
+    <*> btfRestrict'
+    <*> btfAddAuth'
+    <*> btfExpiresAt'
+    <*> btfStartsAt'
+
+
+getAdminTokensR, postAdminTokensR :: Handler Html
+getAdminTokensR = postAdminTokensR
+postAdminTokensR = do
+  ((bearerReq, bearerView), bearerEnc) <- runFormPost $ renderWForm FormStandard bearerTokenForm
+
+  mjwt <- formResultMaybe bearerReq $ \BearerTokenForm{..} -> do
+    uid <- requireAuthId
+    let btfAuthority' = btfAuthority
+          & HashSet.insert (Right uid)
+          & HashSet.map (left toJSON)
+
+    fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfRoutes btfAddAuth btfExpiresAt btfStartsAt
+    
+  siteLayoutMsg' MsgMenuAdminTokens $ do
+    setTitleI MsgMenuAdminTokens
+
+    let bearerForm = wrapForm bearerView def
+          { formMethod = POST
+          , formAction = Just $ SomeRoute AdminTokensR
+          , formEncoding = bearerEnc
+          }
+
+    warning <- notification NotificationBroad <$> messageI Warning MsgBearerTokenUsageWarning
+
+    $(widgetFile "admin-tokens")
diff --git a/src/Handler/Course/LecturerInvite.hs b/src/Handler/Course/LecturerInvite.hs
index ac1ab7480..53d7156ac 100644
--- a/src/Handler/Course/LecturerInvite.hs
+++ b/src/Handler/Course/LecturerInvite.hs
@@ -17,7 +17,7 @@ import Data.Aeson hiding (Result(..))
 
 import Text.Hamlet (ihamlet)
 
-import qualified Data.Set as Set
+import qualified Data.HashSet as HashSet
 
 
 instance IsInvitableJunction Lecturer where
@@ -67,7 +67,7 @@ lecturerInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandler $ toJunction <$> case mlType of
diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs
index d3e7cd5e9..c3d677382 100644
--- a/src/Handler/Course/ParticipantInvite.hs
+++ b/src/Handler/Course/ParticipantInvite.hs
@@ -29,6 +29,8 @@ import Control.Monad.Except (MonadError(..))
 
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 
+import qualified Data.HashSet as HashSet
+
 
 -- Invitations for ordinary participants of this course
 instance IsInvitableJunction CourseParticipant where
@@ -81,7 +83,7 @@ participantInvitationConfig = InvitationConfig{..}
     invitationHeading     (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
     invitationExplanation  _                    _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs
index 205c8bf0f..c55da69f2 100644
--- a/src/Handler/Exam/CorrectorInvite.hs
+++ b/src/Handler/Exam/CorrectorInvite.hs
@@ -16,7 +16,7 @@ import Text.Hamlet (ihamlet)
 
 import Data.Aeson hiding (Result(..))
 
-import qualified Data.Set as Set
+import qualified Data.HashSet as HashSet
 
   
 instance IsInvitableJunction ExamCorrector where
@@ -69,7 +69,7 @@ examCorrectorInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ _ _ = pure (JunctionExamCorrector, ())
diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs
index 1f55b34dd..68ad7cd72 100644
--- a/src/Handler/Exam/RegistrationInvite.hs
+++ b/src/Handler/Exam/RegistrationInvite.hs
@@ -20,6 +20,8 @@ import Text.Hamlet (ihamlet)
 import Data.Aeson hiding (Result(..))
 
 import Jobs.Queue
+
+import qualified Data.HashSet as HashSet
   
 
 instance IsInvitableJunction ExamRegistration where
@@ -77,7 +79,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
     invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       let itExpiresAt = Just $ Just invDBExamRegistrationDeadline
           itAddAuth
             | not invDBExamRegistrationCourseRegister
diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs
index ac7b110ba..9071b269f 100644
--- a/src/Handler/ExamOffice/Users.hs
+++ b/src/Handler/ExamOffice/Users.hs
@@ -19,6 +19,8 @@ import qualified Database.Esqueleto as E
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 import Data.Map ((!), (!?))
+
+import qualified Data.HashSet as HashSet
   
 
 instance IsInvitableJunction ExamOfficeUser where
@@ -67,7 +69,7 @@ examOfficeUserInvitationConfig = InvitationConfig{..}
       return . SomeMessage $ MsgExamOfficeUserInviteHeading userDisplayName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamOfficeUserInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       let itExpiresAt = Nothing
           itStartsAt = Nothing
           itAddAuth = Nothing
diff --git a/src/Handler/ExternalExam/StaffInvite.hs b/src/Handler/ExternalExam/StaffInvite.hs
index cdc2a464d..c594b613a 100644
--- a/src/Handler/ExternalExam/StaffInvite.hs
+++ b/src/Handler/ExternalExam/StaffInvite.hs
@@ -13,7 +13,7 @@ import Handler.Utils.Invitations
 import Text.Hamlet (ihamlet)
 import Data.Aeson hiding (Result(..))
 
-import qualified Data.Set as Set
+import qualified Data.HashSet as HashSet
 
 
 instance IsInvitableJunction ExternalExamStaff where
@@ -61,7 +61,7 @@ externalExamStaffInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ ExternalExam{..}) _ = return . SomeMessage $ MsgExternalExamStaffInviteHeading externalExamCourseName externalExamExamName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExternalExamStaffInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing (Just Nothing) Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ (InvDBDataExternalExamStaff, _) _ = pure (JunctionExternalExamStaff, ())
diff --git a/src/Handler/Metrics.hs b/src/Handler/Metrics.hs
index e49a57210..92bed0bc1 100644
--- a/src/Handler/Metrics.hs
+++ b/src/Handler/Metrics.hs
@@ -27,7 +27,7 @@ getMetricsR = selectRep $ do
         uid <- MaybeT maybeAuthId
         guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid
 
-        encodeBearer =<< bearerToken (Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
+        encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
   
       defaultLayout $ do
         setTitleI MsgTitleMetrics
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index f12c355f8..be86eca93 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -30,6 +30,7 @@ import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 -- import qualified Database.Esqueleto.Internal.Sql as E
 
+import qualified Data.HashSet as HashSet
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
@@ -881,7 +882,7 @@ correctorInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ())
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index d4c0ba631..7878ae211 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -37,6 +37,8 @@ import Text.Blaze (Markup)
 import Data.Aeson hiding (Result(..))
 import Text.Hamlet (ihamlet)
 
+import qualified Data.HashSet as HashSet
+
 -- import Colonnade hiding (bool, fromMaybe)
 -- import qualified Yesod.Colonnade as Yesod
 -- import qualified Text.Blaze.Html5.Attributes as HA
@@ -104,7 +106,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
     invitationTokenConfig (Entity _ Submission{..}) _ = do
       Sheet{..} <- getJust submissionSheet
       Course{..} <- getJust sheetCourse
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR)
       let itExpiresAt = Nothing
           itStartsAt = Nothing
diff --git a/src/Handler/Tutorial/TutorInvite.hs b/src/Handler/Tutorial/TutorInvite.hs
index e8688da59..725cc6e83 100644
--- a/src/Handler/Tutorial/TutorInvite.hs
+++ b/src/Handler/Tutorial/TutorInvite.hs
@@ -13,7 +13,7 @@ import Handler.Utils.Invitations
 import Data.Aeson hiding (Result(..))
 import Text.Hamlet (ihamlet)
 
-import qualified Data.Set as Set
+import qualified Data.HashSet as HashSet
 
 
 instance IsInvitableJunction Tutor where
@@ -66,7 +66,7 @@ tutorInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ _ _ = pure (JunctionTutor, ())
diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index a3d860a5e..ee0d67d85 100644
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@@ -36,6 +36,8 @@ import Handler.Users.Add as Handler.Users
 
 import qualified Data.Conduit.List as C
 
+import qualified Data.HashSet as HashSet
+
 
 hijackUserForm :: Form ()
 hijackUserForm csrf = do
@@ -571,7 +573,7 @@ functionInvitationConfig = InvitationConfig{..}
       MsgRenderer mr <- getMsgRenderer
       return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|]
     invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       let itExpiresAt = Just $ Just invDBUserFunctionDeadline
           itAddAuth = Nothing
           itStartsAt = Nothing
diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs
index 2537ace7d..47873d036 100644
--- a/src/Handler/Utils/Invitations.hs
+++ b/src/Handler/Utils/Invitations.hs
@@ -140,7 +140,7 @@ data InvitationConfig junction = forall formCtx. InvitationConfig
 
 -- | Additional configuration needed for an invocation of `bearerToken`
 data InvitationTokenConfig = InvitationTokenConfig
-  { itAuthority :: Either Value (Set UserId)
+  { itAuthority :: HashSet (Either Value UserId)
   , itAddAuth   :: Maybe AuthDNF
   , itExpiresAt :: Maybe (Maybe UTCTime)
   , itStartsAt  :: Maybe UTCTime
diff --git a/src/Jobs/Handler/ChangeUserDisplayEmail.hs b/src/Jobs/Handler/ChangeUserDisplayEmail.hs
index db9747729..0d256c0ca 100644
--- a/src/Jobs/Handler/ChangeUserDisplayEmail.hs
+++ b/src/Jobs/Handler/ChangeUserDisplayEmail.hs
@@ -7,13 +7,12 @@ import Import
 import Handler.Utils.Mail
 import qualified Data.HashSet as HashSet
 import qualified Data.CaseInsensitive as CI
-import qualified Data.Set as Set
 
 import Text.Hamlet
 
 dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> Handler ()
 dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = do
-  bearer <- bearerRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (Right $ Set.singleton jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
+  bearer <- bearerRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (HashSet.singleton $ Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
   jwt <- encodeBearer bearer
   let
     setDisplayEmailUrl :: SomeRoute UniWorX
diff --git a/src/Jobs/Handler/SendNotification/Utils.hs b/src/Jobs/Handler/SendNotification/Utils.hs
index ce234035f..e60d20cfd 100644
--- a/src/Jobs/Handler/SendNotification/Utils.hs
+++ b/src/Jobs/Handler/SendNotification/Utils.hs
@@ -8,7 +8,6 @@ import Import
 import Text.Hamlet
 
 import qualified Data.HashSet as HashSet
-import qualified Data.Set as Set
 
 
 ihamletSomeMessage :: HtmlUrlI18n UniWorXMessage (Route UniWorX) -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
@@ -17,7 +16,7 @@ ihamletSomeMessage f trans = f $ trans . SomeMessage
 mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
 mkEditNotifications uid = liftHandler $ do
   cID <- encrypt uid
-  jwt <- encodeBearer =<< bearerToken (Right $ Set.singleton uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
+  jwt <- encodeBearer =<< bearerToken (HashSet.singleton $ Right uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
   let
     editNotificationsUrl :: SomeRoute UniWorX
     editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])
diff --git a/src/Jobs/Handler/SendPasswordReset.hs b/src/Jobs/Handler/SendPasswordReset.hs
index 504d0d2ce..352b37b7f 100644
--- a/src/Jobs/Handler/SendPasswordReset.hs
+++ b/src/Jobs/Handler/SendPasswordReset.hs
@@ -10,7 +10,6 @@ import Handler.Utils.Users
 import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteArray as BA
 import qualified Data.HashSet as HashSet
-import qualified Data.Set as Set
 
 import Text.Hamlet
 
@@ -30,7 +29,7 @@ dispatchJobSendPasswordReset jRecipient = userMailT jRecipient $ do
       LTUUnique utc' _ -> utc'
       _other           -> UTCTime (addDays 2 $ utctDay now) 0
 
-  resetBearer' <- bearerToken (Right $ Set.singleton jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
+  resetBearer' <- bearerToken (HashSet.singleton $ Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
   let resetBearer = resetBearer'
         & bearerRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
   encodedBearer <- encodeBearer resetBearer
diff --git a/src/Model/Tokens/Bearer.hs b/src/Model/Tokens/Bearer.hs
index 3dc7413f8..807dad35b 100644
--- a/src/Model/Tokens/Bearer.hs
+++ b/src/Model/Tokens/Bearer.hs
@@ -24,6 +24,7 @@ import qualified Jose.Jwt as Jose
 
 import Jose.Jwt.Instances ()
 
+import qualified Data.HashSet as HashSet
 import qualified Data.HashMap.Strict as HashMap
 import Data.Time.Clock.Instances ()
 
@@ -39,15 +40,13 @@ import Data.Binary (Binary)
 
 import qualified Data.CryptoID.Class.ImplicitNamespace as I
 
-import qualified Data.Set as Set
-
 
 
 -- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
 data BearerToken site = BearerToken
   { bearerIdentifier   :: TokenId
     -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
-  , bearerAuthority    :: Either Value (Set (AuthId site))
+  , bearerAuthority    :: HashSet (Either Value (AuthId site))
     -- ^ Tokens only grant rights the `bearerAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `bearerAuthority`)
   , bearerRoutes       :: Maybe (HashSet (Route site))
     -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
@@ -65,10 +64,10 @@ data BearerToken site = BearerToken
   } 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), Ord (AuthId site)) => Read (BearerToken site)
-deriving instance (Show (AuthId site), Show (Route site), Ord (AuthId site)) => Show (BearerToken site)
+deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site), Hashable (AuthId site), Eq (AuthId site)) => Read (BearerToken site)
+deriving instance (Show (AuthId site), Show (Route site), Hashable (AuthId site)) => Show (BearerToken site)
 
-instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site)) => Binary (BearerToken site)
+instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site), Hashable (AuthId site), Eq (AuthId site)) => Binary (BearerToken site)
 
 makeLenses_ ''BearerToken
 instance HasTokenIdentifier (BearerToken site) TokenId where
@@ -111,7 +110,7 @@ bearerToJSON :: forall m.
 --
 -- Monadic context is needed because `AuthId`s are encrypted during encoding
 bearerToJSON BearerToken{..} = do
-  cID <- either (return . Left) (fmap Right . foldMapM (fmap Set.singleton . I.encrypt)) bearerAuthority :: m (Either Value (Set (CryptoUUID (AuthId (HandlerSite m)))))
+  cID <- foldMapM (fmap HashSet.singleton . either (return . Left) (fmap Right . I.encrypt)) bearerAuthority :: m (HashSet (Either Value (CryptoUUID (AuthId (HandlerSite m)))))
   let stdPayload = Jose.JwtClaims
         { jwtIss = Just $ toPathPiece bearerIssuedBy
         , jwtSub = Nothing
@@ -122,9 +121,8 @@ bearerToJSON BearerToken{..} = do
         , jwtJti = Just $ toPathPiece bearerIdentifier
         }
 
-      authorityToJSON (Left  v  ) = v
-      authorityToJSON (Right ids) | [uid] <- toList ids = toJSON uid
-                                  | otherwise           = toJSON ids
+      authorityToJSON auths | [auth] <- otoList auths = either toJSON toJSON auth
+                            | otherwise = toJSON $ HashSet.map (either toJSON toJSON) auths
   return . JSON.object $
     catMaybes [ Just $ "authority" .= authorityToJSON cID
               , ("routes" .=) <$> bearerRoutes
@@ -134,7 +132,7 @@ bearerToJSON BearerToken{..} = do
     ++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
 
 bearerParseJSON :: forall site.
-                  ( Ord (AuthId site)
+                  ( Hashable (AuthId site), Eq (AuthId site)
                   , HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
                   , ParseRoute site
                   , Hashable (Route site)
@@ -147,8 +145,12 @@ bearerParseJSON :: forall site.
 --
 -- It's usually easier to use `Utils.Tokens.bearerParseJSON'`
 bearerParseJSON v@(Object o) = do
-  bearerAuthority' <- lift $ (Right <$> o .: "authority") <|> (Right . Set.singleton <$> o .: "authority") <|> (Left <$> o .: "authority") :: ReaderT CryptoIDKey Parser (Either Value (Set (CryptoUUID (AuthId site))))
-  bearerAuthority <- either (return . Left) (fmap Right . foldMapM (fmap Set.singleton . I.decrypt)) bearerAuthority'
+  bearerAuthority' <- lift $ asum
+    [ HashSet.singleton . Right <$> o .: "authority"
+    , (o .: "authority" :: Parser (HashSet Value)) >>= foldMapM (\v' -> fmap HashSet.singleton $ (Right <$> parseJSON v') <|> return (Left v'))
+    , HashSet.singleton . Left  <$> o .: "authority"
+    ] :: ReaderT CryptoIDKey Parser (HashSet (Either Value (CryptoUUID (AuthId site))))
+  bearerAuthority <- foldMapM (fmap HashSet.singleton . either (return . Left) (fmap Right . I.decrypt)) bearerAuthority'
 
   bearerRoutes        <- lift $ o .:? "routes"
   bearerAddAuth       <- lift $ o .:? "add-auth"
diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs
index 71e35fbdf..ad6a4c8dc 100644
--- a/src/Model/Types/Security.hs
+++ b/src/Model/Types/Security.hs
@@ -12,6 +12,7 @@ module Model.Types.Security
 import Import.NoModel
 
 import qualified Data.Text as Text
+import qualified Data.Set as Set
 
 import qualified Data.HashMap.Strict as HashMap
 
@@ -24,6 +25,8 @@ import qualified Data.CaseInsensitive as CI
 import Model.Types.TH.PathPiece
 import Database.Persist.Sql
 
+import Utils.Lens.TH
+
 
 data AuthenticationMode = AuthLDAP
                         | AuthPWHash { authPWHash :: Text }
@@ -149,6 +152,10 @@ instance (Ord a, Binary a) => Binary (PredDNF a) where
   get = PredDNF <$> Binary.get
   put = Binary.put . dnfTerms
 
+instance (Ord a, PathPiece a) => PathPiece (PredDNF a) where
+  toPathPiece = Text.unwords . map (Text.intercalate "AND") . map (map toPathPiece . otoList) . otoList . dnfTerms
+  fromPathPiece = fmap (PredDNF . Set.fromList) . mapM (fromNullable <=< foldMapM (fmap Set.singleton . fromPathPiece) . Text.splitOn "AND") . concatMap (Text.splitOn "OR") . Text.words
+
 type AuthLiteral = PredLiteral AuthTag
 
 type AuthDNF = PredDNF AuthTag
@@ -158,6 +165,7 @@ data UserGroupName
   = UserGroupMetrics
   | UserGroupCustom { userGroupCustomName :: CI Text }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Hashable)
 
 instance PathPiece UserGroupName where
   toPathPiece UserGroupMetrics = "metrics"
@@ -171,3 +179,4 @@ instance PathPiece UserGroupName where
 
 pathPieceJSON ''UserGroupName
 derivePersistFieldPathPiece' (sqlType (Proxy @(CI Text))) ''UserGroupName
+makeLenses_ ''UserGroupName
diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs
index 0e05629aa..f290261fc 100644
--- a/src/Utils/Tokens.hs
+++ b/src/Utils/Tokens.hs
@@ -33,7 +33,7 @@ import Text.Blaze (Markup)
 
 
 bearerParseJSON' :: forall m.
-                  ( Ord (AuthId (HandlerSite m))
+                  ( Hashable (AuthId (HandlerSite m)), Eq (AuthId (HandlerSite m))
                   , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
                   , ParseRoute (HandlerSite m)
                   , Hashable (Route (HandlerSite m))
@@ -54,7 +54,7 @@ bearerToken :: forall m.
                , HasClusterID (HandlerSite m) ClusterId
                , HasAppSettings (HandlerSite m)
                )
-            => Either Value (Set (AuthId (HandlerSite m)))
+            => HashSet (Either Value (AuthId (HandlerSite m)))
             -> Maybe (HashSet (Route (HandlerSite m)))
             -> Maybe AuthDNF
             -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
@@ -109,7 +109,7 @@ instance Exception BearerTokenException
 decodeBearer :: forall m.
                ( MonadHandler m
                , HasJSONWebKeySet (HandlerSite m) JwkSet
-               , Ord (AuthId (HandlerSite m))
+               , Hashable (AuthId (HandlerSite m)), Eq (AuthId (HandlerSite m))
                , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
                , MonadCryptoKey m ~ CryptoIDKey
                , MonadCrypto m
diff --git a/templates/admin-tokens.hamlet b/templates/admin-tokens.hamlet
new file mode 100644
index 000000000..d0cf294e3
--- /dev/null
+++ b/templates/admin-tokens.hamlet
@@ -0,0 +1,10 @@
+$newline never
+^{warning}
+  
+$maybe (Jwt bs) <- mjwt
+  <section>
+    <pre style="white-space: pre-wrap; line-break: anywhere;">
+      #{decodeUtf8 bs}
+
+<section>
+  ^{bearerForm}
diff --git a/templates/widgets/massinput/token-restrictions/add.hamlet b/templates/widgets/massinput/token-restrictions/add.hamlet
new file mode 100644
index 000000000..1ffbf19f8
--- /dev/null
+++ b/templates/widgets/massinput/token-restrictions/add.hamlet
@@ -0,0 +1,7 @@
+$newline never
+<td>
+  #{csrf}
+  ^{fvInput routeView}<br />
+  ^{fvInput restrView}
+<td>
+  ^{fvInput btn}
diff --git a/templates/widgets/massinput/token-restrictions/cell.hamlet b/templates/widgets/massinput/token-restrictions/cell.hamlet
new file mode 100644
index 000000000..af5b0462b
--- /dev/null
+++ b/templates/widgets/massinput/token-restrictions/cell.hamlet
@@ -0,0 +1,6 @@
+$newline never
+<td>
+  #{csrf}
+  ^{fvInput routeView}<br />
+  ^{fvInput restrView}
+<td>
diff --git a/templates/widgets/massinput/token-restrictions/layout.hamlet b/templates/widgets/massinput/token-restrictions/layout.hamlet
new file mode 100644
index 000000000..f1842a72f
--- /dev/null
+++ b/templates/widgets/massinput/token-restrictions/layout.hamlet
@@ -0,0 +1,13 @@
+$newline never
+<table>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
+        ^{cellWdgts ! coord}
+        <td>
+          $maybe delButton <- delButtons !? coord
+            ^{fvInput delButton}
+  $maybe addWdgt <- addWdgts !? (0, 0)
+    <tfoot>
+      <tr .massinput__cell.massinput__cell--add>
+        ^{addWdgt}
diff --git a/translate.hs b/translate.hs
index eadb44621..cc81b6fa4 100755
--- a/translate.hs
+++ b/translate.hs
@@ -254,7 +254,9 @@ combine f1 f2 = insertMissing f1 f2 >> insertMissing f2 f1
       unless (null missing) $ do
         response <- runUserEditor (mkTemplate "msg") query
         let responseMsgs = readMsgText "" response
-        insertIntoFile f2' f1' responseMsgs
+            responseMsgs' = responseMsgs { msgDefinitions = map stripTypes $ msgDefinitions responseMsgs }
+            stripTypes defn = defn { msgArgs = map (\(n, _) -> (n, Nothing)) $ msgArgs defn }
+        insertIntoFile f2' f1' responseMsgs'
 
 
 normalizeLang :: Bool -> String -> String

From d87e8b7142d879eb0a5d320332e967e1c19a1b33 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Thu, 9 Apr 2020 15:26:12 +0200
Subject: [PATCH 5/7] fix: fix course duplicate message & name -> title for
 courses

---
 messages/uniworx/de-de-formal.msg | 6 +++---
 messages/uniworx/en-eu.msg        | 4 ++--
 2 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg
index 6367327a3..26d14e41a 100644
--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@@ -122,8 +122,8 @@ CourseExam: Prüfung
 CourseSecretWrong: Falsches Passwort
 CourseSecret: Zugangspasswort
 CourseEditOk       tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} wurde erfolgreich geändert.
-CourseNewDupShort  tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester und Institut.
-CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester und Institut.
+CourseNewDupShort  tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem selben Kürzel oder Titel in diesem Semester und Institut.
+CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem selben Kürzel oder Titel in diesem Semester und Institut.
 FFSheetName: Name
 TermCourseListHeading tid@TermId: Kursübersicht #{tid}
 TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{tid} für #{school}
@@ -139,7 +139,7 @@ CourseAssociatedWith: assoziiert mit
 CourseMembersCount n@Int: #{n}
 CourseMembersCountLimited n@Int max@Int: #{n}/#{max}
 CourseMembersCountOf n@Int mbNum@IntMaybe: #{n} Kursanmeldungen #{maybeToMessage " von " mbNum " möglichen"}
-CourseName: Name
+CourseName: Kurstitel
 CourseDescription: Beschreibung
 CourseHomepageExternal: Externe Homepage
 CourseShorthand: Kürzel
diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg
index 3123c1649..cbf7f0a62 100644
--- a/messages/uniworx/en-eu.msg
+++ b/messages/uniworx/en-eu.msg
@@ -122,8 +122,8 @@ CourseExam: Exam
 CourseSecretWrong: Wrong password
 CourseSecret: Access password
 CourseEditOk tid ssh csh: Successfully edited course #{tid}-#{ssh}-#{csh} 
-CourseNewDupShort tid ssh csh: Could not create course #{tid}-#{ssh}-#{csh}. Another course with shorthand #{csh} already exists for the given semester and school.
-CourseEditDupShort tid ssh csh: Could not edit course #{tid}-#{ssh}-#{csh}. Another course with shorthand #{csh} already exists for the given semester and school.
+CourseNewDupShort tid ssh csh: Could not create course #{tid}-#{ssh}-#{csh}. Another course with the same shorthand or title already exists for the given semester and school.
+CourseEditDupShort tid ssh csh: Could not edit course #{tid}-#{ssh}-#{csh}. Another course with the same shorthand or title already exists for the given semester and school.
 FFSheetName: Name
 TermCourseListHeading tid: Courses #{tid}
 TermSchoolCourseListHeading tid school: Courses #{tid}, #{school}

From 908e6def80d8ac2b65e6d5722607db7571c007ea Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Thu, 9 Apr 2020 15:37:18 +0200
Subject: [PATCH 6/7] fix: hlint

---
 src/Handler/Admin/Tokens.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Handler/Admin/Tokens.hs b/src/Handler/Admin/Tokens.hs
index 9468bfca0..0e3d595e4 100644
--- a/src/Handler/Admin/Tokens.hs
+++ b/src/Handler/Admin/Tokens.hs
@@ -52,7 +52,7 @@ bearerTokenForm = do
                      -> Form (Route UniWorX, Value)
               miForm nudge mode csrf = do
                 (routeRes, routeView) <- mpreq routeField ("" & addName (nudge "route")) (mode ^? _Right . _1)
-                (restrRes, restrView) <- mpreq (checkMap (left Text.pack . Aeson.eitherDecode . encodeUtf8 . fromStrict . unTextarea) (Textarea . toStrict . decodeUtf8 . Aeson.encodePretty) $ textareaField) ("" & addName (nudge "restr")) (mode ^? _Right . _2)
+                (restrRes, restrView) <- mpreq (checkMap (left Text.pack . Aeson.eitherDecode . encodeUtf8 . fromStrict . unTextarea) (Textarea . toStrict . decodeUtf8 . Aeson.encodePretty) textareaField) ("" & addName (nudge "restr")) (mode ^? _Right . _2)
 
                 return ((,) <$> routeRes <*> restrRes, case mode of
                            Left btn -> $(widgetFile "widgets/massinput/token-restrictions/add")

From b2512c2d987b461eac9a94b659b26efc46165d1d Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Thu, 9 Apr 2020 15:40:01 +0200
Subject: [PATCH 7/7] chore(release): 14.6.0

---
 CHANGELOG.md      | 15 +++++++++++++++
 package-lock.json |  2 +-
 package.json      |  2 +-
 package.yaml      |  2 +-
 4 files changed, 18 insertions(+), 3 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 47b8ef38d..085f42778 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -2,6 +2,21 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [14.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.5.0...v14.6.0) (2020-04-09)
+
+
+### Bug Fixes
+
+* fix course duplicate message & name -> title for courses ([d87e8b7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d87e8b7))
+* hlint ([908e6de](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/908e6de))
+
+
+### Features
+
+* admin interface to issue tokens ([738ab7b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/738ab7b))
+
+
+
 ## [14.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.4.0...v14.5.0) (2020-04-09)
 
 
diff --git a/package-lock.json b/package-lock.json
index 18c0964a5..7d9519f0a 100644
--- a/package-lock.json
+++ b/package-lock.json
@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "14.5.0",
+  "version": "14.6.0",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {
diff --git a/package.json b/package.json
index 1000885ae..2c13cfc2f 100644
--- a/package.json
+++ b/package.json
@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "14.5.0",
+  "version": "14.6.0",
   "description": "",
   "keywords": [],
   "author": "",
diff --git a/package.yaml b/package.yaml
index 5ef864bec..d8d33fa25 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
 name:    uniworx
-version: 14.5.0
+version: 14.6.0
 
 dependencies:
   - base