feat(tokens): multiple authorities

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.

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.

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
+        Right uids -> return uids
-        
-      User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get bearerAuthority'
-      guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
 
       let
         -- Prevent infinite loops
         noTokenAuth :: AuthDNF -> AuthDNF
         noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
 
-      authorityVal <- do
+      guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority
-        dnf <- either throwM return $ routeAuthTags route
+
-        fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just bearerAuthority') route isWrite
+      forM_ bearerAuthority' $ \uid -> do
-      guardExceptT (is _Authorized authorityVal) authorityVal
+        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

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

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

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

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

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

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

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

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

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

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

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

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

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)])

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

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 (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)) => Show (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' <- 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 . I.decrypt) bearerAuthority'
+  bearerAuthority <- either (return . Left) (fmap Right . foldMapM (fmap Set.singleton . I.decrypt)) bearerAuthority'
 
   bearerRoutes        <- lift $ o .:? "routes"
   bearerAddAuth       <- lift $ o .:? "add-auth"

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