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

chore(firm): limit firm action access to admins

Browse Source
This commit is contained in:
Steffen Jost 2023-11-24 17:44:27 +01:00
parent 2636c9d41a
commit 212cb71807
2 changed files with 33 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
routes
View File

@ -115,9 +115,9 @@
/firms FirmAllR GET POST !supervisor /firms FirmAllR GET POST !supervisor
/firms/comm/+Companies FirmsCommR GET POST /firms/comm/+Companies FirmsCommR GET POST
/firm/#CompanyShorthand FirmR GET POST /firm/#CompanyShorthand/debug FirmR GET POST
/firm/#CompanyShorthand/comm FirmCommR GET POST /firm/#CompanyShorthand/comm FirmCommR GET POST
/firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor /firm/#CompanyShorthand FirmUsersR GET POST !supervisor
/firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor /firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor
/exam-office ExamOfficeR !exam-office: /exam-office ExamOfficeR !exam-office:

61
src/Handler/Firm.hs
View File

@ -62,7 +62,7 @@ data FirmAction = FirmActNotify
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite)
nullaryPathPiece ''FirmAction $ camelToPathPiece' 2 nullaryPathPiece ''FirmAction $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''FirmAction id embedRenderMessage ''UniWorX ''FirmAction id
data FirmActionData = FirmActNotifyData data FirmActionData = FirmActNotifyData
@ -86,28 +86,29 @@ data FirmActionData = FirmActNotifyData
} }
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
firmActionMap :: _ -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) firmActionMap :: _ -> Bool -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData)
firmActionMap mr acts = mconcat (mkAct <$> acts) firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
where where
mkAct FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData mkAct True FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData
mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData mkAct _ FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
<*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
mkAct FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData mkAct _ FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData
<$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True)
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
mkAct FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData
<$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing
<*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail) Nothing <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail) Nothing
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
<* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive))
mkAct FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData
<$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
mkAct _ _ = mempty
firmActionForm :: _ -> [FirmAction] -> AForm Handler FirmActionData firmActionForm :: () -> Bool -> [FirmAction] -> AForm Handler FirmActionData
firmActionForm mr acts = multiActionA (firmActionMap mr acts) (fslI MsgTableAction) Nothing firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing
makeFirmActionForm :: CompanyId -> _ -> [FirmAction] -> Form (FirmActionData, Set CompanyId) makeFirmActionForm :: CompanyId -> _ -> [FirmAction] -> Form (FirmActionData, Set CompanyId)
makeFirmActionForm cid mr acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr acts makeFirmActionForm cid mr acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr acts
@ -189,10 +190,10 @@ firmActionHandler route = flip formResult faHandler
faHandler _ = addMessageI Error MsgErrorUnknownFormAction faHandler _ = addMessageI Error MsgErrorUnknownFormAction
runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget runFirmActionFormPost :: CompanyId -> Route UniWorX -> Bool -> [FirmAction] -> Handler Widget
runFirmActionFormPost cid route acts = do runFirmActionFormPost cid route isAdmin acts = do
mr <- getMessageRender mr <- getMessageRender
((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr acts ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr isAdmin acts
let faAnchor = "firm-action-form" :: Text let faAnchor = "firm-action-form" :: Text
faRoute = route :#: faAnchor faRoute = route :#: faAnchor
faForm = wrapForm faWgt FormSettings faForm = wrapForm faWgt FormSettings
@ -590,7 +591,7 @@ mkFirmAllTable isAdmin uid = do
, dbParamsFormAction = Nothing , dbParamsFormAction = Nothing
, dbParamsFormAttrs = [] , dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit , dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr [FirmActNotify, FirmActResetSupervision] , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr isAdmin [FirmActNotify, FirmActResetSupervision]
, dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id , dbParamsFormResult = id
, dbParamsFormIdent = def , dbParamsFormIdent = def
@ -618,7 +619,7 @@ getFirmAllR, postFirmAllR :: Handler Html
getFirmAllR = postFirmAllR getFirmAllR = postFirmAllR
postFirmAllR = do postFirmAllR = do
uid <- requireAuthId uid <- requireAuthId
isAdmin <- hasReadAccessTo AdminR isAdmin <- checkAdmin
(firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
firmActionHandler FirmAllR firmRes firmActionHandler FirmAllR firmRes
siteLayoutMsg MsgMenuFirms $ do siteLayoutMsg MsgMenuFirms $ do
@ -839,7 +840,7 @@ mkFirmUserTable isAdmin cid = do
getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
getFirmUsersR = postFirmUsersR getFirmUsersR = postFirmUsersR
postFirmUsersR fsh = do postFirmUsersR fsh = do
isAdmin <- hasReadAccessTo AdminR isAdmin <- checkAdmin
let cid = CompanyKey fsh let cid = CompanyKey fsh
(( Entity{entityVal=Company{..}} (( Entity{entityVal=Company{..}}
, E.Value nrCompanyUsers , E.Value nrCompanyUsers
@ -897,7 +898,7 @@ postFirmUsersR fsh = do
addMessageI Success $ MsgFirmUserChanges nrChanged addMessageI Success $ MsgFirmUserChanges nrChanged
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser] formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser]
siteLayout (citext2widget companyName) $ do siteLayout (citext2widget companyName) $ do
setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId
@ -1064,7 +1065,7 @@ mkFirmSuperTable isAdmin cid = do
getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html
getFirmSupersR = postFirmSupersR getFirmSupersR = postFirmSupersR
postFirmSupersR fsh = do postFirmSupersR fsh = do
isAdmin <- hasReadAccessTo AdminR isAdmin <- checkAdmin
let cid = CompanyKey fsh let cid = CompanyKey fsh
(Company{..},(fsprRes,fsprTable)) <- runDB $ (,) (Company{..},(fsprRes,fsprTable)) <- runDB $ (,)
<$> get404 cid <$> get404 cid
@ -1092,7 +1093,7 @@ postFirmSupersR fsh = do
cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm] formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm]
siteLayout (citext2widget fsh) $ do siteLayout (citext2widget fsh) $ do
setTitle $ citext2Html $ fsh <> " Supers" setTitle $ citext2Html $ fsh <> " Supers"