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

feat: usergroups & metrics usergroup

Browse Source 
Fixes #538
This commit is contained in:
Gregor Kleen 2019-11-21 18:41:21 +01:00
parent ad96830a99
commit 9204565cac
23 changed files with 126 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -386,6 +386,8 @@ 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.
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.
UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden.
UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.

9
models/users.model
View File

@ -83,3 +83,12 @@ StudyTermCandidate -- No one at LMU is willing and able to tell us the meanin
key Int -- a possible key for the studyTermName
name Text -- studyTermName as plain text from LDAP
deriving Show Eq Ord
UserGroupMember
group UserGroupName
user UserId
primary Checkmark nullable
UniquePrimaryUserGroupMember group primary !force
UniqueUserGroupMember group user

2
package.yaml
View File

@ -240,7 +240,7 @@ executables:
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
- -with-rtsopts="-N -T"
dependencies:
- uniworx
when:

12
src/Foundation.hs
View File

@ -360,7 +360,15 @@ validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo vali
validateToken' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority
tokenAuthority' <- case tokenAuthority of
Left tVal
| JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do
Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active
return userGroupMemberUser
| otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue
Right uid -> return uid
User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority'
guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
let
@ -370,7 +378,7 @@ validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo vali
authorityVal <- do
dnf <- either throwM return $ routeAuthTags route
fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just tokenAuthority) route isWrite
fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just tokenAuthority') route isWrite
guardExceptT (is _Authorized authorityVal) authorityVal
whenIsJust tokenAddAuth $ \addDNF -> do

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

@ -66,7 +66,7 @@ lecturerInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> 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

@ -83,7 +83,7 @@ participantInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do

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

@ -67,7 +67,7 @@ examCorrectorInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> 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 <- liftHandler requireAuthId
itAuthority <- Right <$> 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 <- liftHandler requireAuthId
itAuthority <- Right <$> liftHandler requireAuthId
let itExpiresAt = Nothing
itStartsAt = Nothing
itAddAuth = Nothing

8
src/Handler/Metrics.hs
View File

@ -8,6 +8,7 @@ import Prometheus
import qualified Network.Wai.Middleware.Prometheus as Prometheus
import qualified Data.Text as Text
import qualified Data.HashSet as HashSet
getMetricsR :: Handler TypedContent
@ -19,6 +20,13 @@ getMetricsR = selectRep $ do
metricsHtml :: Handler Html
metricsHtml = do
samples <- collectMetrics
metricsToken <- runMaybeT . hoist runDB $ do
uid <- MaybeT maybeAuthId
guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid
encodeToken =<< bearerToken (Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
defaultLayout $ do
setTitleI MsgTitleMetrics
$(widgetFile "metrics")

2
src/Handler/Sheet.hs
View File

@ -888,7 +888,7 @@ correctorInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> 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

@ -107,7 +107,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
invitationTokenConfig (Entity _ Submission{..}) _ = do
Sheet{..} <- getJust submissionSheet
Course{..} <- getJust sheetCourse
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> liftHandler requireAuthId
itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR)
let itExpiresAt = Nothing
itStartsAt = Nothing

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

@ -64,7 +64,7 @@ tutorInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure (JunctionTutor, ())

2
src/Handler/Users.hs
View File

@ -572,7 +572,7 @@ functionInvitationConfig = InvitationConfig{..}
MsgRenderer mr <- getMsgRenderer
return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|]
invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> liftHandler requireAuthId
let itExpiresAt = Just $ Just invDBUserFunctionDeadline
itAddAuth = Nothing
itStartsAt = Nothing

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

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

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

@ -12,7 +12,7 @@ import Text.Hamlet
dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> Handler ()
dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = do
token <- tokenRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken jUser (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
token <- tokenRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
jwt <- encodeToken token
let
setDisplayEmailUrl :: SomeRoute UniWorX

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

@ -16,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 <- encodeToken =<< bearerToken uid (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
jwt <- encodeToken =<< bearerToken (Right uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
let
editNotificationsUrl :: SomeRoute UniWorX
editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])

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

@ -29,7 +29,7 @@ dispatchJobSendPasswordReset jRecipient = userMailT jRecipient $ do
LTUUnique utc' _ -> utc'
_other -> UTCTime (addDays 2 $ utctDay now) 0
resetToken' <- bearerToken jRecipient (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
resetToken' <- bearerToken (Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
let resetToken = resetToken'
& tokenRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
encodedToken <- encodeToken resetToken

10
src/Model/Tokens.hs
View File

@ -46,7 +46,7 @@ import Data.Binary (Binary)
data BearerToken site = BearerToken
{ tokenIdentifier :: TokenId
-- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
, tokenAuthority :: AuthId site
, tokenAuthority :: Either Value (AuthId site)
-- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
, tokenRoutes :: Maybe (HashSet (Route site))
-- ^ Tokens can optionally be restricted to only be usable on a subset of routes
@ -97,7 +97,7 @@ tokenToJSON :: forall m.
--
-- Monadic context is needed because `AuthId`s are encrypted during encoding
tokenToJSON BearerToken{..} = do
cID <- encrypt tokenAuthority :: m (CryptoUUID (AuthId (HandlerSite m)))
cID <- either (return . Left) (fmap Right . encrypt) tokenAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m))))
let stdPayload = Jose.JwtClaims
{ jwtIss = Just $ toPathPiece tokenIssuedBy
, jwtSub = Nothing
@ -108,7 +108,7 @@ tokenToJSON BearerToken{..} = do
, jwtJti = Just $ toPathPiece tokenIdentifier
}
return . JSON.object $
catMaybes [ Just $ "authority" .= cID
catMaybes [ Just $ "authority" .= either id toJSON cID
, ("routes" .=) <$> tokenRoutes
, ("add-auth" .=) <$> tokenAddAuth
, ("restrictions" .=) <$> assertM' (not . HashMap.null) tokenRestrictions
@ -128,8 +128,8 @@ tokenParseJSON :: forall site.
--
-- It's usually easier to use `Utils.Tokens.tokenParseJSON'`
tokenParseJSON v@(Object o) = do
tokenAuthority' <- lift (o .: "authority") :: ReaderT CryptoIDKey Parser (CryptoUUID (AuthId site))
tokenAuthority <- decrypt tokenAuthority'
tokenAuthority' <- lift $ (Right <$> o .: "authority") <|> (Left <$> o .: "authority") :: ReaderT CryptoIDKey Parser (Either Value (CryptoUUID (AuthId site)))
tokenAuthority <- either (return . Left) (fmap Right . decrypt) tokenAuthority'
tokenRoutes <- lift $ o .:? "routes"
tokenAddAuth <- lift $ o .:? "add-auth"

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

@ -21,6 +21,11 @@ import qualified Data.Aeson.Types as Aeson
import qualified Data.Binary as Binary
import qualified Data.CaseInsensitive as CI
import Model.Types.TH.PathPiece
import Database.Persist.Sql
data AuthenticationMode = AuthLDAP
| AuthPWHash { authPWHash :: Text }
@ -152,3 +157,21 @@ instance (Ord a, Binary a) => Binary (PredDNF a) where
type AuthLiteral = PredLiteral AuthTag
type AuthDNF = PredDNF AuthTag
data UserGroupName
= UserGroupMetrics
| UserGroupCustom { userGroupCustomName :: CI Text }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance PathPiece UserGroupName where
toPathPiece UserGroupMetrics = "metrics"
toPathPiece (UserGroupCustom t) = CI.original t
fromPathPiece t = Just $ if
| "metrics" `ciEq` t -> UserGroupMetrics
| otherwise -> UserGroupCustom $ CI.mk t
where
ciEq = (==) `on` CI.mk
pathPieceJSON ''UserGroupName
derivePersistFieldPathPiece' (sqlType (Proxy @(CI Text))) ''UserGroupName

15
src/Model/Types/TH/PathPiece.hs
View File

@ -1,5 +1,6 @@
module Model.Types.TH.PathPiece
( derivePersistFieldPathPiece
, derivePersistFieldPathPiece'
) where
import ClassyPrelude.Yesod
@ -13,7 +14,10 @@ import Language.Haskell.TH.Datatype
derivePersistFieldPathPiece :: Name -> DecsQ
derivePersistFieldPathPiece tName = do
derivePersistFieldPathPiece = derivePersistFieldPathPiece' SqlString
derivePersistFieldPathPiece' :: SqlType -> Name -> DecsQ
derivePersistFieldPathPiece' sType tName = do
DatatypeInfo{..} <- reifyDatatype tName
vars <- forM datatypeVars (const $ newName "a")
let t = foldl (\t' n' -> t' `appT` varT n') (conT tName) vars
@ -32,15 +36,18 @@ derivePersistFieldPathPiece tName = do
[ do
bs <- newName "bs"
clause [[p|PersistByteString $(varP bs)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistByteString") Right $ fromPathPiece =<< either (const Nothing) Just (Text.decodeUtf8' $(varE bs))|]) []
, do
bs <- newName "bs"
clause [[p|PersistDbSpecific $(varP bs)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistDbSpecific") Right $ fromPathPiece =<< either (const Nothing) Just (Text.decodeUtf8' $(varE bs))|]) []
, do
text <- newName "text"
clause [[p|PersistText $(varP text)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistTetx") Right $ fromPathPiece $(varE text)|]) []
, clause [wildP] (normalB [e|Left "PathPiece values must be converted from PersistText or PersistByteString"|]) []
clause [[p|PersistText $(varP text)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistText") Right $ fromPathPiece $(varE text)|]) []
, clause [wildP] (normalB [e|Left "PathPiece values must be converted from PersistText, PersistByteString, or PersistDbSpecific"|]) []
]
]
, instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
[ funD 'sqlType
[ clause [wildP] (normalB [e|SqlString|]) []
[ clause [wildP] (normalB [e|sType|]) []
]
]
]

2
src/Utils/Tokens.hs
View File

@ -58,7 +58,7 @@ bearerToken :: forall m.
, HasInstanceID (HandlerSite m) InstanceId
, HasAppSettings (HandlerSite m)
)
=> AuthId (HandlerSite m)
=> Either Value (AuthId (HandlerSite m))
-> Maybe (HashSet (Route (HandlerSite m)))
-> Maybe AuthDNF
-> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically

81
templates/metrics.hamlet
View File

@ -1,41 +1,46 @@
$newline never
<dl .deflist>
$forall SampleGroup Info{..} _ mSamples <- samples
<dt .deflist__dt>
<div>#{metricName}
<p style="font-weight: 600; color: var(--color-fontsec); font-size: 0.9rem; margin-top: 7px">
#{metricHelp}
<dd .deflist__dd style="overflow: auto; max-height: 50vh">
$case mSamples
$of []
<p style="font-style: italic">_{MsgMetricNoSamples}
$of _
$maybe (lPairs, sValue) <- singleSample metricName mSamples
<p>
#{decodeUtf8 sValue}
$case lPairs
$of []
$of _
<ul .list-inline .list--comma-separated>
$forall (lName, lValue) <- lPairs
<li>#{lName}=#{lValue}
$nothing
$with allLabels <- getLabels mSamples
<table .table .table--striped .table--hover>
<thead>
<tr .table__row .table__row--head>
<th .table__th>_{MsgMetricName}
$forall l <- allLabels
<th .table__th style="font-family: monospace">#{l}
<th .table__th>_{MsgMetricValue}
<tbody>
$forall Sample sName lPairs sValue <- mSamples
<tr .table__row>
<td .table__td title=#{sName}>
#{metricBasename metricName sName}
$maybe t <- metricsToken
<section>
<pre style="font-family: monospace; white-space: pre-wrap; word-break: break-all;">
#{toPathPiece t}
<section>
<dl .deflist>
$forall SampleGroup Info{..} _ mSamples <- samples
<dt .deflist__dt>
<div>#{metricName}
<p style="font-weight: 600; color: var(--color-fontsec); font-size: 0.9rem; margin-top: 7px">
#{metricHelp}
<dd .deflist__dd style="overflow: auto; max-height: 50vh">
$case mSamples
$of []
<p style="font-style: italic">_{MsgMetricNoSamples}
$of _
$maybe (lPairs, sValue) <- singleSample metricName mSamples
<p>
#{decodeUtf8 sValue}
$case lPairs
$of []
$of _
<ul .list-inline .list--comma-separated>
$forall (lName, lValue) <- lPairs
<li>#{lName}=#{lValue}
$nothing
$with allLabels <- getLabels mSamples
<table .table .table--striped .table--hover>
<thead>
<tr .table__row .table__row--head>
<th .table__th>_{MsgMetricName}
$forall l <- allLabels
<th .table__th style="font-family: monospace">#{l}
<th .table__th>_{MsgMetricValue}
<tbody>
$forall Sample sName lPairs sValue <- mSamples
<tr .table__row>
<td .table__td title=#{sName}>
#{metricBasename metricName sName}
$forall l <- allLabels
<td .table__td>
$maybe lValue <- lookup l lPairs
#{lValue}
<td .table__td>
$maybe lValue <- lookup l lPairs
#{lValue}
<td .table__td>
#{decodeUtf8 sValue}
#{decodeUtf8 sValue}