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

feat: don't redirect monitoring routes & crontab tokens

Browse Source
This commit is contained in:
Gregor Kleen 2020-12-09 15:33:54 +01:00
parent c5ee5b26d5
commit 3a106d1ee5
3 changed files with 47 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/Foundation/Yesod/Middleware.hs
View File

@ -138,6 +138,13 @@ yesodMiddleware = cacheControlMiddleware . storeBearerMiddleware . csrfMiddlewar
normalizeApprootMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a normalizeApprootMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
normalizeApprootMiddleware handler = maybeT handler $ do normalizeApprootMiddleware handler = maybeT handler $ do
route <- MaybeT getCurrentRoute route <- MaybeT getCurrentRoute
case route of
MetricsR -> mzero
HealthR -> mzero
InstanceR -> mzero
_other -> return ()
reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest
let rApproot = authoritiveApproot route let rApproot = authoritiveApproot route
app <- getYesod app <- getYesod

59
src/Handler/Admin/Crontab.hs
View File

@ -14,6 +14,9 @@ import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder')
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1 { constructorTagModifier = camelToPathPiece' 1
@ -30,33 +33,45 @@ getAdminCrontabR = do
let mCrontab = mCrontab' <&> _2 %~ filter (hasn't $ _3 . _MatchNone) let mCrontab = mCrontab' <&> _2 %~ filter (hasn't $ _3 . _MatchNone)
selectRep $ do selectRep $ do
provideRep $ provideRep $ do
crontabBearer <- runMaybeT . hoist runDB $ do
uid <- MaybeT maybeAuthId
guardM . lift . existsBy $ UniqueUserGroupMember UserGroupCrontab uid
encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupCrontab) Nothing (HashMap.singleton BearerTokenRouteEval $ HashSet.singleton AdminCrontabR) Nothing (Just Nothing) Nothing
siteLayoutMsg MsgMenuAdminCrontab $ do siteLayoutMsg MsgMenuAdminCrontab $ do
setTitleI MsgMenuAdminCrontab setTitleI MsgMenuAdminCrontab
[whamlet| [whamlet|
$newline never $newline never
$maybe (genTime, crontab) <- mCrontab $maybe t <- crontabBearer
<p> <section>
^{formatTimeW SelFormatDateTime genTime} <pre .token>
<table .table .table--striped .table--hover> #{toPathPiece t}
$forall (job, lExec, match) <- crontab <section>
<tr .table__row> $maybe (genTime, crontab) <- mCrontab
<td .table__td> <p>
$case match ^{formatTimeW SelFormatDateTime genTime}
$of MatchAsap <table .table .table--striped .table--hover>
_{MsgCronMatchAsap} $forall (job, lExec, match) <- crontab
$of MatchNone <tr .table__row>
_{MsgCronMatchNone} <td .table__td>
$of MatchAt t $case match
^{formatTimeW SelFormatDateTime t} $of MatchAsap
<td .table__td> _{MsgCronMatchAsap}
$maybe lT <- lExec $of MatchNone
^{formatTimeW SelFormatDateTime lT} _{MsgCronMatchNone}
<td .table__td> $of MatchAt t
<pre> ^{formatTimeW SelFormatDateTime t}
<td .table__td>
$maybe lT <- lExec
^{formatTimeW SelFormatDateTime lT}
<td .table__td .json>
#{doEnc job} #{doEnc job}
$nothing $nothing
_{MsgAdminCrontabNotGenerated} <p .explanation>
_{MsgAdminCrontabNotGenerated}
|] |]
provideJson mCrontab' provideJson mCrontab'
provideRep . return . Text.Builder.toLazyText $ doEnc mCrontab' provideRep . return . Text.Builder.toLazyText $ doEnc mCrontab'

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

@ -245,16 +245,18 @@ predDNFEntail = over _dnfTerms $ ofoldl' entail Set.empty
data UserGroupName data UserGroupName
= UserGroupMetrics = UserGroupMetrics | UserGroupCrontab
| UserGroupCustom { userGroupCustomName :: CI Text } | UserGroupCustom { userGroupCustomName :: CI Text }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (Hashable) deriving anyclass (Hashable)
instance PathPiece UserGroupName where instance PathPiece UserGroupName where
toPathPiece UserGroupMetrics = "metrics" toPathPiece UserGroupMetrics = "metrics"
toPathPiece UserGroupCrontab = "crontab"
toPathPiece (UserGroupCustom t) = CI.original t toPathPiece (UserGroupCustom t) = CI.original t
fromPathPiece t = Just $ if fromPathPiece t = Just $ if
| "metrics" `ciEq` t -> UserGroupMetrics | "metrics" `ciEq` t -> UserGroupMetrics
| "crontab" `ciEq` t -> UserGroupCrontab
| otherwise -> UserGroupCustom $ CI.mk t | otherwise -> UserGroupCustom $ CI.mk t
where where
ciEq :: Text -> Text -> Bool ciEq :: Text -> Text -> Bool