From bc47dcf43f08fdc6e9b52dc205fbabea1893259f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 9 Apr 2020 10:30:25 +0200 Subject: [PATCH] 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