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

feat: admin interface to issue tokens

Browse Source
This commit is contained in:
Gregor Kleen 2020-04-09 15:23:46 +02:00
parent 19e5d1c05f
commit 738ab7b738
29 changed files with 252 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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

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

1
routes
View File

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

13
src/Foundation.hs
View File

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

1
src/Handler/Admin.hs
View File

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

105
src/Handler/Admin/Tokens.hs Normal file
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

2
src/Handler/Metrics.hs
View File

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

3
src/Handler/Sheet.hs
View File

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

4
src/Handler/Submission.hs
View File

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

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

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

4
src/Handler/Users.hs
View File

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

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 (Set UserId)
{ itAuthority :: HashSet (Either Value UserId)
, itAddAuth :: Maybe AuthDNF
, itExpiresAt :: Maybe (Maybe UTCTime)
, itStartsAt :: Maybe UTCTime

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

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

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

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

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

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

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

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

9
src/Model/Types/Security.hs
View File

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

6
src/Utils/Tokens.hs
View File

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

10
templates/admin-tokens.hamlet Normal file
View File

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

7
templates/widgets/massinput/token-restrictions/add.hamlet Normal file
View File

@ -0,0 +1,7 @@
$newline never
<td>
#{csrf}
^{fvInput routeView}<br />
^{fvInput restrView}
<td>
^{fvInput btn}

6
templates/widgets/massinput/token-restrictions/cell.hamlet Normal file
View File

@ -0,0 +1,6 @@
$newline never
<td>
#{csrf}
^{fvInput routeView}<br />
^{fvInput restrView}
<td>

13
templates/widgets/massinput/token-restrictions/layout.hamlet Normal file
View File

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

4
translate.hs
View File

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