103 lines
5.2 KiB
Haskell
103 lines
5.2 KiB
Haskell
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 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
|
|
mr <- getMessageRender
|
|
|
|
btfAuthorityGroups <- aFormToWForm $ HashSet.fromList . map Left <$> massInputListA pathPieceField (const "") MsgBearerTokenAuthorityGroupMissing (\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) (fslpI MsgBearerTokenAuthorityUsers (mr MsgLdapIdentificationOrEmail) & 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 "") MsgBearerTokenRouteMissing (\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 (fslI MsgBearerTokenRestrictRoute & addName (nudge "route")) (mode ^? _Right . _1)
|
|
(restrRes, restrView) <- mpreq (checkMap (left Text.pack . Aeson.eitherDecode . encodeUtf8 . fromStrict . unTextarea) (Textarea . toStrict . decodeUtf8 . Aeson.encodePretty) textareaField) (fslI MsgBearerTokenRestrictValue & 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")
|