feat: admin interface to issue tokens

messages/uniworx/de-de-formal.msg

@@ -1157,6 +1157,7 @@ MenuUserPassword: Passwort
 MenuAdminTest: Admin-Demo
 MenuMessageList: Systemnachrichten
 MenuAdminErrMsg: Fehlermeldung entschlüsseln
+MenuAdminTokens: Tokens ausstellen
 MenuProfileData: Persönliche Daten
 MenuTermCreate: Neues Semester anlegen
 MenuCourseNew: Neuen Kurs anlegen
@@ -2427,3 +2428,21 @@ AllocationUsersCount: Teilnehmer
 AllocationCoursesCount: Kurse
 
 CourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen}
+
+BearerTokenUsageWarning: Mit diesem Interface können quesi beliebige Rechte als Tokens kodiert und somit ohne wesentliche weitere Beschränkung frei übertragen werden. Benutzen Sie dieses Interface nur, wenn Sie von einem erfahrenen Entwickler über die Auswirkungen des konkreten Tokens, dass sie ausstellen möchten, beraten wurden!
+BearerTokenAuthorityGroups: Token-Authorität (Gruppen)
+BearerTokenAuthorityGroupsTip: Die primären Benutzer aller angegebenen Gruppen müssen Zugriff auf eine Route haben, damit das Token den Zugriff auf diese Route erlaubt.
+BearerTokenAuthorityUsers: Token-Authorität (Benutzer)
+BearerTokenAuthorityUsersTip: Alle angegebenen Benutzer müssen Zugriff auf eine Route haben, damit das Token den Zugriff auf diese Route erlaubt. Der Aussteller muss, bei mit diesem Benutzerinterface erzeugten Tokens, auch Zugriff auf die Route haben (er wird automatisch der Menge von Token-Authoritäten hinzugefügt).
+BearerTokenAuthorityUnknownUser email@UserEmail: Ein Nutzer mit E-Mail #{email} ist dem System nicht bekannt
+BearerTokenRoutes: Erlaubte Routen
+BearerTokenRoutesTip: Wenn die Token-Validität nach Routen eingeschränkt und keine Routen angegeben werden, ist das Token nirgends gültig.
+BearerTokenRestrictions: Routen-spezifische Einschränkungen
+BearerTokenRestrictRoutes: Token-Validität nach Routen einschränken
+BearerTokenAdditionalAuth: Zusätzliche Authorisierung
+BearerTokenAdditionalAuthTip: Wird hier nichts angegeben, werden keine Einschränkungen daran gesetzt, wer das Token verwenden kann. Es reicht dann der Besitz.
+BearerTokenOverrideExpiration: Ablaufzeitpunkt überschreiben
+BearerTokenExpires: Ablaufzeitpunkt
+BearerTokenExpiresTip: Wird der Ablaufzeitpunkt überschrieben und kein Ablaufzeitpunkt angegeben, ist das Token für immer gültig.
+BearerTokenOverrideStart: Startzeitpunkt
+BearerTokenOverrideStartTip: Wird kein Startzeitpunkt angegeben, wird bei Verwendung des Tokens nur der Ablaufzeitpunkt überprüft.

messages/uniworx/en-eu.msg

@@ -1156,6 +1156,7 @@ MenuUserPassword: Password
 MenuAdminTest: Admin-demo
 MenuMessageList: System messages
 MenuAdminErrMsg: Decrypt error message
+MenuAdminTokens: Issue tokens
 MenuProfileData: Personal information
 MenuTermCreate: Create new semester 
 MenuCourseNew: Create new course
@@ -2427,3 +2428,21 @@ AllocationUsersCount: Participants
 AllocationCoursesCount: Courses
 
 CourseOption tid ssh coursen: #{tid} - #{ssh} - #{coursen}
+
+BearerTokenUsageWarning: Using this interface you are able to encode essentially arbitrary permissions inte bearer tokens. This allows you to freely hand permissions off arbitrarily and without relevant restrictions. Only use this interface if you have discussed the consequences of the specific token, that you want to issue, with an experienced developer!
+BearerTokenAuthorityGroups: Authority (groups)
+BearerTokenAuthorityGroupsTip: All primary users of the groups listed here need to have the requisite permissions to access a route in order for the created token to grant permission to do so as well.
+BearerTokenAuthorityUsers: Authority (users
+BearerTokenAuthorityUsersTip: All users listed here need to have the requisite permissions to access a route in order for the created token to grant permission to do so as well. The user issuing the token using this interface also needs to have permission to access that route (they are automatically added to the list of authorities).
+BearerTokenAuthorityUnknownUser email: Could not find any user with email #{email}
+BearerTokenRoutes: Permitted routes
+BearerTokenRoutesTip: If the token is restricted to certain routes and no routes are listed, the token is valid nowhere.
+BearerTokenRestrictions: Route-specific restrictions
+BearerTokenRestrictRoutes: Restrict token to certain routes
+BearerTokenAdditionalAuth: Additional authorisation
+BearerTokenAdditionalAuthTip: If nothing is entered, no additional authorisation will be performed when the token is used. Mere posession of the token will be sufficient.
+BearerTokenOverrideExpiration: Override expiration time
+BearerTokenExpires: Expiration time
+BearerTokenExpiresTip: If no expiration time is given, the token will not expire. It will be valid forever.
+BearerTokenOverrideStart: Start time
+BearerTokenOverrideStartTip: If no start time is given, only the expiration time will be checked when the token is used.

routes

@@ -55,6 +55,7 @@
 /admin/features               AdminFeaturesR   GET POST
 /admin/test                   AdminTestR       GET POST
 /admin/errMsg                 AdminErrMsgR     GET POST
+/admin/tokens                 AdminTokensR     GET POST
 
 /health                       HealthR          GET             !free
 /instance                     InstanceR        GET             !free

src/Foundation.hs

@@ -328,13 +328,13 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
     validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
       guardMExceptT (maybe True (HashSet.member route) bearerRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
 
-      bearerAuthority' <- case bearerAuthority of
+      bearerAuthority' <- flip foldMapM bearerAuthority $ \case
         Left tVal
           | JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do
               Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active
               return $ Set.singleton userGroupMemberUser
           | otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue
-        Right uids -> return uids
+        Right uid -> return $ Set.singleton uid
 
       let
         -- Prevent infinite loops
@@ -2013,6 +2013,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb AdminFeaturesR   = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR 
   breadcrumb AdminTestR       = i18nCrumb MsgMenuAdminTest        $ Just AdminR
   breadcrumb AdminErrMsgR     = i18nCrumb MsgMenuAdminErrMsg      $ Just AdminR
+  breadcrumb AdminTokensR     = i18nCrumb MsgMenuAdminTokens      $ Just AdminR
   
   breadcrumb SchoolListR      = i18nCrumb MsgMenuSchoolList       $ Just AdminR
   breadcrumb (SchoolR ssh SchoolEditR) = maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
@@ -2482,6 +2483,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
               , navQuick'      = mempty
               , navForceActive = False
               }
+          , NavLink
+              { navLabel       = MsgMenuAdminTokens
+              , navRoute       = AdminTokensR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
           , NavLink
               { navLabel       = MsgMenuAdminTest
               , navRoute       = AdminTestR

src/Handler/Admin.hs

@@ -9,6 +9,7 @@ import Handler.Utils
 import Handler.Admin.Test as Handler.Admin
 import Handler.Admin.ErrorMessage as Handler.Admin
 import Handler.Admin.StudyFeatures as Handler.Admin
+import Handler.Admin.Tokens as Handler.Admin
 
 
 getAdminR :: Handler Html

src/Handler/Admin/Tokens.hs

@@ -0,0 +1,105 @@
+module Handler.Admin.Tokens
+  ( getAdminTokensR, postAdminTokensR
+  ) where
+
+import Import
+import Handler.Utils
+
+import qualified Data.HashSet as HashSet
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Set as Set
+
+import Control.Arrow (left)
+
+import Jose.Jwt (Jwt(..))
+
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Encode.Pretty as Aeson
+
+import Data.Map ((!), (!?))
+
+import qualified Data.Text as Text
+
+
+data BearerTokenForm = BearerTokenForm
+  { btfAuthority :: HashSet (Either UserGroupName UserId)
+  , btfRoutes    :: Maybe (HashSet (Route UniWorX))
+  , btfRestrict  :: HashMap (Route UniWorX) Value
+  , btfAddAuth   :: Maybe AuthDNF
+  , btfExpiresAt :: Maybe (Maybe UTCTime)
+  , btfStartsAt  :: Maybe UTCTime
+  }
+
+bearerTokenForm :: WForm Handler (FormResult BearerTokenForm)
+bearerTokenForm = do
+  muid <- maybeAuthId
+  
+  btfAuthorityGroups <- aFormToWForm $ HashSet.fromList . map Left <$> massInputListA pathPieceField (const "") (\p -> Just . SomeRoute $ AdminTokensR :#: p) ("token-groups" :: Text) (fslI MsgBearerTokenAuthorityGroups & setTooltip MsgBearerTokenAuthorityGroupsTip) False Nothing
+  btfAuthorityUsers <- fmap (fmap . ofoldMap $ HashSet.singleton . Right) <$> wopt (checkMap (foldMapM $ fmap Set.singleton . left MsgBearerTokenAuthorityUnknownUser) (Set.map Right) $ multiUserField False Nothing) (fslI MsgBearerTokenAuthorityUsers & setTooltip MsgBearerTokenAuthorityUsersTip) (Just $ Set.singleton <$> muid)
+  let btfAuthority' :: FormResult (HashSet (Either UserGroupName UserId))
+      btfAuthority'
+        = (<>) <$> btfAuthorityGroups <*> ((hoistMaybe =<< btfAuthorityUsers) <|> pure HashSet.empty)
+
+  let btfRoutesForm = HashSet.fromList <$> massInputListA routeField (const "") (\p -> Just . SomeRoute $ AdminTokensR :#: p) ("token-routes" :: Text) (fslI MsgBearerTokenRoutes & setTooltip MsgBearerTokenRoutesTip) True Nothing
+  btfRoutes' <- optionalActionW btfRoutesForm (fslI MsgBearerTokenRestrictRoutes) (Just True)
+
+  let btfRestrictForm = massInputAccumEditW miAdd' miCell' (\p -> Just . SomeRoute $ AdminTokensR :#: p) miLayout' ("token-restrictions" :: Text) (fslI MsgBearerTokenRestrictions) False Nothing
+        where miAdd' nudge = fmap (over (mapped . _1) tweakRes) . miForm nudge . Left
+                where tweakRes res = res <&> \(newRoute, newRestr) oldRestrs -> pure (bool [(newRoute, newRestr)] [] $ newRoute `HashMap.member` HashMap.fromList oldRestrs)
+              miCell' nudge = miForm nudge . Right
+              miForm :: (Text -> Text)
+                     -> Either (FieldView UniWorX) (Route UniWorX, Value)
+                     -> Form (Route UniWorX, Value)
+              miForm nudge mode csrf = do
+                (routeRes, routeView) <- mpreq routeField ("" & addName (nudge "route")) (mode ^? _Right . _1)
+                (restrRes, restrView) <- mpreq (checkMap (left Text.pack . Aeson.eitherDecode . encodeUtf8 . fromStrict . unTextarea) (Textarea . toStrict . decodeUtf8 . Aeson.encodePretty) $ textareaField) ("" & addName (nudge "restr")) (mode ^? _Right . _2)
+
+                return ((,) <$> routeRes <*> restrRes, case mode of
+                           Left btn -> $(widgetFile "widgets/massinput/token-restrictions/add")
+                           Right _  -> $(widgetFile "widgets/massinput/token-restrictions/cell")
+                       )
+
+              miLayout' :: MassInputLayout ListLength (Route UniWorX, Value) (Route UniWorX, Value)
+              miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/token-restrictions/layout")
+                
+  btfRestrict' <- fmap HashMap.fromList <$> btfRestrictForm
+
+  btfAddAuth' <- fmap (assertM $ not . Set.null . dnfTerms) <$> wopt pathPieceField (fslI MsgBearerTokenAdditionalAuth & setTooltip MsgBearerTokenAdditionalAuthTip) Nothing
+
+  btfExpiresAt' <- optionalActionW (aopt utcTimeField (fslI MsgBearerTokenExpires & setTooltip MsgBearerTokenExpiresTip) Nothing) (fslI MsgBearerTokenOverrideExpiration) (Just False)
+  btfStartsAt' <- wopt utcTimeField (fslI MsgBearerTokenOverrideStart & setTooltip MsgBearerTokenOverrideStartTip) Nothing
+
+  return $ BearerTokenForm
+    <$> btfAuthority'
+    <*> btfRoutes'
+    <*> btfRestrict'
+    <*> btfAddAuth'
+    <*> btfExpiresAt'
+    <*> btfStartsAt'
+
+
+getAdminTokensR, postAdminTokensR :: Handler Html
+getAdminTokensR = postAdminTokensR
+postAdminTokensR = do
+  ((bearerReq, bearerView), bearerEnc) <- runFormPost $ renderWForm FormStandard bearerTokenForm
+
+  mjwt <- formResultMaybe bearerReq $ \BearerTokenForm{..} -> do
+    uid <- requireAuthId
+    let btfAuthority' = btfAuthority
+          & HashSet.insert (Right uid)
+          & HashSet.map (left toJSON)
+
+    fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfRoutes btfAddAuth btfExpiresAt btfStartsAt
+    
+  siteLayoutMsg' MsgMenuAdminTokens $ do
+    setTitleI MsgMenuAdminTokens
+
+    let bearerForm = wrapForm bearerView def
+          { formMethod = POST
+          , formAction = Just $ SomeRoute AdminTokensR
+          , formEncoding = bearerEnc
+          }
+
+    warning <- notification NotificationBroad <$> messageI Warning MsgBearerTokenUsageWarning
+
+    $(widgetFile "admin-tokens")

src/Handler/Course/LecturerInvite.hs

@@ -17,7 +17,7 @@ import Data.Aeson hiding (Result(..))
 
 import Text.Hamlet (ihamlet)
 
-import qualified Data.Set as Set
+import qualified Data.HashSet as HashSet
 
 
 instance IsInvitableJunction Lecturer where
@@ -67,7 +67,7 @@ lecturerInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandler $ toJunction <$> case mlType of

src/Handler/Course/ParticipantInvite.hs

@@ -29,6 +29,8 @@ import Control.Monad.Except (MonadError(..))
 
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 
+import qualified Data.HashSet as HashSet
+
 
 -- Invitations for ordinary participants of this course
 instance IsInvitableJunction CourseParticipant where
@@ -81,7 +83,7 @@ participantInvitationConfig = InvitationConfig{..}
     invitationHeading     (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
     invitationExplanation  _                    _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do

src/Handler/Exam/CorrectorInvite.hs

@@ -16,7 +16,7 @@ import Text.Hamlet (ihamlet)
 
 import Data.Aeson hiding (Result(..))
 
-import qualified Data.Set as Set
+import qualified Data.HashSet as HashSet
 
   
 instance IsInvitableJunction ExamCorrector where
@@ -69,7 +69,7 @@ examCorrectorInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ _ _ = pure (JunctionExamCorrector, ())

src/Handler/Exam/RegistrationInvite.hs

@@ -21,6 +21,8 @@ import Data.Aeson hiding (Result(..))
 
 import Jobs.Queue
 
+import qualified Data.HashSet as HashSet
+  
 
 instance IsInvitableJunction ExamRegistration where
   type InvitationFor ExamRegistration = Exam
@@ -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

src/Handler/ExamOffice/Users.hs

@@ -20,6 +20,8 @@ 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
   type InvitationFor ExamOfficeUser = User
@@ -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

src/Handler/ExternalExam/StaffInvite.hs

@@ -13,7 +13,7 @@ import Handler.Utils.Invitations
 import Text.Hamlet (ihamlet)
 import Data.Aeson hiding (Result(..))
 
-import qualified Data.Set as Set
+import qualified Data.HashSet as HashSet
 
 
 instance IsInvitableJunction ExternalExamStaff where
@@ -61,7 +61,7 @@ externalExamStaffInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ ExternalExam{..}) _ = return . SomeMessage $ MsgExternalExamStaffInviteHeading externalExamCourseName externalExamExamName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExternalExamStaffInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing (Just Nothing) Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ (InvDBDataExternalExamStaff, _) _ = pure (JunctionExternalExamStaff, ())

src/Handler/Metrics.hs

@@ -27,7 +27,7 @@ getMetricsR = selectRep $ do
         uid <- MaybeT maybeAuthId
         guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid
 
-        encodeBearer =<< bearerToken (Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
+        encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
   
       defaultLayout $ do
         setTitleI MsgTitleMetrics

src/Handler/Sheet.hs

@@ -30,6 +30,7 @@ import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 -- import qualified Database.Esqueleto.Internal.Sql as E
 
+import qualified Data.HashSet as HashSet
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
@@ -881,7 +882,7 @@ correctorInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ())

src/Handler/Submission.hs

@@ -37,6 +37,8 @@ import Text.Blaze (Markup)
 import Data.Aeson hiding (Result(..))
 import Text.Hamlet (ihamlet)
 
+import qualified Data.HashSet as HashSet
+
 -- import Colonnade hiding (bool, fromMaybe)
 -- import qualified Yesod.Colonnade as Yesod
 -- import qualified Text.Blaze.Html5.Attributes as HA
@@ -104,7 +106,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
     invitationTokenConfig (Entity _ Submission{..}) _ = do
       Sheet{..} <- getJust submissionSheet
       Course{..} <- getJust sheetCourse
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR)
       let itExpiresAt = Nothing
           itStartsAt = Nothing

src/Handler/Tutorial/TutorInvite.hs

@@ -13,7 +13,7 @@ import Handler.Utils.Invitations
 import Data.Aeson hiding (Result(..))
 import Text.Hamlet (ihamlet)
 
-import qualified Data.Set as Set
+import qualified Data.HashSet as HashSet
 
 
 instance IsInvitableJunction Tutor where
@@ -66,7 +66,7 @@ tutorInvitationConfig = InvitationConfig{..}
     invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
     invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
     invitationTokenConfig _ _ = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
     invitationForm _ _ _ = pure (JunctionTutor, ())

src/Handler/Users.hs

@@ -36,6 +36,8 @@ import Handler.Users.Add as Handler.Users
 
 import qualified Data.Conduit.List as C
 
+import qualified Data.HashSet as HashSet
+
 
 hijackUserForm :: Form ()
 hijackUserForm csrf = do
@@ -571,7 +573,7 @@ functionInvitationConfig = InvitationConfig{..}
       MsgRenderer mr <- getMsgRenderer
       return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|]
     invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do
-      itAuthority <- Right . Set.singleton <$> liftHandler requireAuthId
+      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       let itExpiresAt = Just $ Just invDBUserFunctionDeadline
           itAddAuth = Nothing
           itStartsAt = Nothing

src/Handler/Utils/Invitations.hs

@@ -140,7 +140,7 @@ data InvitationConfig junction = forall formCtx. InvitationConfig
 
 -- | Additional configuration needed for an invocation of `bearerToken`
 data InvitationTokenConfig = InvitationTokenConfig
-  { itAuthority :: Either Value (Set UserId)
+  { itAuthority :: HashSet (Either Value UserId)
   , itAddAuth   :: Maybe AuthDNF
   , itExpiresAt :: Maybe (Maybe UTCTime)
   , itStartsAt  :: Maybe UTCTime

src/Jobs/Handler/ChangeUserDisplayEmail.hs

@@ -7,13 +7,12 @@ import Import
 import Handler.Utils.Mail
 import qualified Data.HashSet as HashSet
 import qualified Data.CaseInsensitive as CI
-import qualified Data.Set as Set
 
 import Text.Hamlet
 
 dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> Handler ()
 dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = do
-  bearer <- bearerRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (Right $ Set.singleton jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
+  bearer <- bearerRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (HashSet.singleton $ Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
   jwt <- encodeBearer bearer
   let
     setDisplayEmailUrl :: SomeRoute UniWorX

src/Jobs/Handler/SendNotification/Utils.hs

@@ -8,7 +8,6 @@ import Import
 import Text.Hamlet
 
 import qualified Data.HashSet as HashSet
-import qualified Data.Set as Set
 
 
 ihamletSomeMessage :: HtmlUrlI18n UniWorXMessage (Route UniWorX) -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
@@ -17,7 +16,7 @@ ihamletSomeMessage f trans = f $ trans . SomeMessage
 mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
 mkEditNotifications uid = liftHandler $ do
   cID <- encrypt uid
-  jwt <- encodeBearer =<< bearerToken (Right $ Set.singleton uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
+  jwt <- encodeBearer =<< bearerToken (HashSet.singleton $ Right uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
   let
     editNotificationsUrl :: SomeRoute UniWorX
     editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])

src/Jobs/Handler/SendPasswordReset.hs

@@ -10,7 +10,6 @@ import Handler.Utils.Users
 import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteArray as BA
 import qualified Data.HashSet as HashSet
-import qualified Data.Set as Set
 
 import Text.Hamlet
 
@@ -30,7 +29,7 @@ dispatchJobSendPasswordReset jRecipient = userMailT jRecipient $ do
       LTUUnique utc' _ -> utc'
       _other           -> UTCTime (addDays 2 $ utctDay now) 0
 
-  resetBearer' <- bearerToken (Right $ Set.singleton jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
+  resetBearer' <- bearerToken (HashSet.singleton $ Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
   let resetBearer = resetBearer'
         & bearerRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
   encodedBearer <- encodeBearer resetBearer

src/Model/Tokens/Bearer.hs

@@ -24,6 +24,7 @@ import qualified Jose.Jwt as Jose
 
 import Jose.Jwt.Instances ()
 
+import qualified Data.HashSet as HashSet
 import qualified Data.HashMap.Strict as HashMap
 import Data.Time.Clock.Instances ()
 
@@ -39,15 +40,13 @@ import Data.Binary (Binary)
 
 import qualified Data.CryptoID.Class.ImplicitNamespace as I
 
-import qualified Data.Set as Set
-
 
 
 -- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
 data BearerToken site = BearerToken
   { bearerIdentifier   :: TokenId
     -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
-  , bearerAuthority    :: Either Value (Set (AuthId site))
+  , bearerAuthority    :: HashSet (Either Value (AuthId site))
     -- ^ Tokens only grant rights the `bearerAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `bearerAuthority`)
   , bearerRoutes       :: Maybe (HashSet (Route site))
     -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
@@ -65,10 +64,10 @@ data BearerToken site = BearerToken
   } deriving (Generic, Typeable)
 
 deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
-deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site), Ord (AuthId site)) => Read (BearerToken site)
+deriving instance (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), Ord (AuthId site)) => Show (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 auths | [auth] <- otoList auths = either toJSON toJSON auth
-      authorityToJSON (Right ids) | [uid] <- toList ids = toJSON uid
+                            | otherwise = toJSON $ HashSet.map (either toJSON toJSON) auths
-                                  | otherwise           = toJSON ids
   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' <- lift $ asum
-  bearerAuthority <- either (return . Left) (fmap Right . foldMapM (fmap Set.singleton . I.decrypt)) bearerAuthority'
+    [ 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"

src/Model/Types/Security.hs

@@ -12,6 +12,7 @@ module Model.Types.Security
 import Import.NoModel
 
 import qualified Data.Text as Text
+import qualified Data.Set as Set
 
 import qualified Data.HashMap.Strict as HashMap
 
@@ -24,6 +25,8 @@ import qualified Data.CaseInsensitive as CI
 import Model.Types.TH.PathPiece
 import Database.Persist.Sql
 
+import Utils.Lens.TH
+
 
 data AuthenticationMode = AuthLDAP
                         | AuthPWHash { authPWHash :: Text }
@@ -149,6 +152,10 @@ instance (Ord a, Binary a) => Binary (PredDNF a) where
   get = PredDNF <$> Binary.get
   put = Binary.put . dnfTerms
 
+instance (Ord a, PathPiece a) => PathPiece (PredDNF a) where
+  toPathPiece = Text.unwords . map (Text.intercalate "AND") . map (map toPathPiece . otoList) . otoList . dnfTerms
+  fromPathPiece = fmap (PredDNF . Set.fromList) . mapM (fromNullable <=< foldMapM (fmap Set.singleton . fromPathPiece) . Text.splitOn "AND") . concatMap (Text.splitOn "OR") . Text.words
+
 type AuthLiteral = PredLiteral AuthTag
 
 type AuthDNF = PredDNF AuthTag
@@ -158,6 +165,7 @@ data UserGroupName
   = UserGroupMetrics
   | UserGroupCustom { userGroupCustomName :: CI Text }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Hashable)
 
 instance PathPiece UserGroupName where
   toPathPiece UserGroupMetrics = "metrics"
@@ -171,3 +179,4 @@ instance PathPiece UserGroupName where
 
 pathPieceJSON ''UserGroupName
 derivePersistFieldPathPiece' (sqlType (Proxy @(CI Text))) ''UserGroupName
+makeLenses_ ''UserGroupName

src/Utils/Tokens.hs

@@ -33,7 +33,7 @@ import Text.Blaze (Markup)
 
 
 bearerParseJSON' :: forall m.
-                  ( Ord (AuthId (HandlerSite m))
+                  ( Hashable (AuthId (HandlerSite m)), Eq (AuthId (HandlerSite m))
                   , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
                   , ParseRoute (HandlerSite m)
                   , Hashable (Route (HandlerSite m))
@@ -54,7 +54,7 @@ bearerToken :: forall m.
                , HasClusterID (HandlerSite m) ClusterId
                , HasAppSettings (HandlerSite m)
                )
-            => Either Value (Set (AuthId (HandlerSite m)))
+            => HashSet (Either Value (AuthId (HandlerSite m)))
             -> Maybe (HashSet (Route (HandlerSite m)))
             -> Maybe AuthDNF
             -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
@@ -109,7 +109,7 @@ instance Exception BearerTokenException
 decodeBearer :: forall m.
                ( MonadHandler m
                , HasJSONWebKeySet (HandlerSite m) JwkSet
-               , Ord (AuthId (HandlerSite m))
+               , Hashable (AuthId (HandlerSite m)), Eq (AuthId (HandlerSite m))
                , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
                , MonadCryptoKey m ~ CryptoIDKey
                , MonadCrypto m

templates/admin-tokens.hamlet

@@ -0,0 +1,10 @@
+$newline never
+^{warning}
+  
+$maybe (Jwt bs) <- mjwt
+  <section>
+    <pre style="white-space: pre-wrap; line-break: anywhere;">
+      #{decodeUtf8 bs}
+
+<section>
+  ^{bearerForm}

templates/widgets/massinput/token-restrictions/add.hamlet

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

templates/widgets/massinput/token-restrictions/cell.hamlet

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

templates/widgets/massinput/token-restrictions/layout.hamlet

@@ -0,0 +1,13 @@
+$newline never
+<table>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
+        ^{cellWdgts ! coord}
+        <td>
+          $maybe delButton <- delButtons !? coord
+            ^{fvInput delButton}
+  $maybe addWdgt <- addWdgts !? (0, 0)
+    <tfoot>
+      <tr .massinput__cell.massinput__cell--add>
+        ^{addWdgt}

translate.hs

@@ -254,7 +254,9 @@ combine f1 f2 = insertMissing f1 f2 >> insertMissing f2 f1
       unless (null missing) $ do
         response <- runUserEditor (mkTemplate "msg") query
         let responseMsgs = readMsgText "" response
-        insertIntoFile f2' f1' responseMsgs
+            responseMsgs' = responseMsgs { msgDefinitions = map stripTypes $ msgDefinitions responseMsgs }
+            stripTypes defn = defn { msgArgs = map (\(n, _) -> (n, Nothing)) $ msgArgs defn }
+        insertIntoFile f2' f1' responseMsgs'
 
 
 normalizeLang :: Bool -> String -> String