fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(tokens): multiple authorities

Browse Source
This commit is contained in:
Gregor Kleen 2020-04-09 10:30:25 +02:00
parent 81b5e0fdd2
commit bc47dcf43f
19 changed files with 59 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/de-de-formal.msg
View File

@ -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.

1
messages/uniworx/en-eu.msg
View File

@ -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.

21
src/Foundation.hs
View File

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

4
src/Handler/Course/LecturerInvite.hs
View File

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

2
src/Handler/Course/ParticipantInvite.hs
View File

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

4
src/Handler/Exam/CorrectorInvite.hs
View File

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

2
src/Handler/Exam/RegistrationInvite.hs
View File

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

2
src/Handler/ExamOffice/Users.hs
View File

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

4
src/Handler/ExternalExam/StaffInvite.hs
View File

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

2
src/Handler/Sheet.hs
View File

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

2
src/Handler/Submission.hs
View File

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

4
src/Handler/Tutorial/TutorInvite.hs
View File

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

2
src/Handler/Users.hs
View File

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

2
src/Handler/Utils/Invitations.hs
View File

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

3
src/Jobs/Handler/ChangeUserDisplayEmail.hs
View File

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

3
src/Jobs/Handler/SendNotification/Utils.hs
View File

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

3
src/Jobs/Handler/SendPasswordReset.hs
View File

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

25
src/Model/Tokens/Bearer.hs
View File

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

6
src/Utils/Tokens.hs
View File

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