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

fix(firm): set supervisor field not all fields required

Browse Source
This commit is contained in:
Steffen Jost 2023-12-05 12:12:51 +01:00
parent 3acb847915
commit 9878956716
2 changed files with 12 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
src/Handler/Firm.hs
View File

@ -520,15 +520,15 @@ mkFirmAllTable isAdmin uid = do
, single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
(usr :& usrCmp) <- E.from $ E.table @User (usr :& usrCmp) <- E.from $ E.table @User
`E.leftJoin` E.table @UserCompany `E.leftJoin` E.table @UserCompany
`E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser)
E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion)
E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion)
) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.? . UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId)
E.||. E.exists (do E.||. E.exists (do
usrSpr <- E.from $ E.table @UserSupervisor usrSpr <- E.from $ E.table @UserSupervisor
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
E.&& E.exists (do E.&&. E.exists (do
usrSub <- E.from $ E.table @UserCompany usrSub <- E.from $ E.table @UserCompany
E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser
E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
@ -638,8 +638,8 @@ data FirmUserActionData = FirmUserActNotifyData
-- , firmUserActResetMutualSupervision :: Maybe Bool -- , firmUserActResetMutualSupervision :: Maybe Bool
} }
| FirmUserActSetSupervisorData | FirmUserActSetSupervisorData
{ firmUserActSetSuperNames :: Set Text { firmUserActSetSuperNames :: Maybe (Set Text)
, firmUserActSetSuperIds :: [UserId] , firmUserActSetSuperIds :: Maybe [UserId]
, firmUserActSetSuperReroute :: Bool , firmUserActSetSuperReroute :: Bool
, firmUserActSetSuperKeep :: Bool , firmUserActSetSuperKeep :: Bool
} }
@ -798,10 +798,10 @@ mkFirmUserTable isAdmin cid = do
<$> 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 )
, singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> apopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing <*> aopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False)
, singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
<$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
, singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
@ -887,10 +887,10 @@ postFirmUsersR fsh = do
addMessageI Info $ MsgFirmResetSupervision delSupers newSupers addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
(FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do (FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmUserActSetSuperNames avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ maybeMonoid firmUserActSetSuperNames
let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
usersFound = mapMaybe snd usersFound' usersFound = mapMaybe snd usersFound'
newSupers = Set.toList $ Set.fromList firmUserActSetSuperIds <> Set.fromList usersFound newSupers = Set.toList $ Set.fromList (maybeMonoid firmUserActSetSuperIds) <> Set.fromList usersFound
nrSupers = fromIntegral $ length newSupers nrSupers = fromIntegral $ length newSupers
nrUsers = fromIntegral $ length uids nrUsers = fromIntegral $ length uids
unless (null usersNotFound) $ unless (null usersNotFound) $

1
src/Utils.hs
View File

@ -626,6 +626,7 @@ guardMonoid True x = x
assertMonoid :: Monoid m => (m -> Bool) -> m -> m assertMonoid :: Monoid m => (m -> Bool) -> m -> m
assertMonoid f x = guardMonoid (f x) x assertMonoid f x = guardMonoid (f x) x
-- fold would also do, but is more risky if the Folable isn't Maybe
maybeMonoid :: Monoid m => Maybe m -> m maybeMonoid :: Monoid m => Maybe m -> m
-- ^ Identify `Nothing` with `mempty` -- ^ Identify `Nothing` with `mempty`
maybeMonoid = fromMaybe mempty maybeMonoid = fromMaybe mempty