diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs
index 73302520b..384db461f 100644
--- a/src/Handler/Firm.hs
+++ b/src/Handler/Firm.hs
@@ -56,7 +56,7 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU
data FirmAction = FirmActNotify
| FirmActResetSupervision
- -- | FirmActAddSupervisors
+ | FirmActAddSupervisors
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite)
@@ -68,11 +68,11 @@ data FirmActionData = FirmActNotifyData
{ firmActResetKeepOldSupers :: Maybe Bool
, firmActResetMutualSupervision :: Maybe Bool
}
- -- | FirmActAddSupervisorsData
- -- { firmActAddSupervisorIds :: Set Text
- -- , firmActAddSupervisorReroute :: Bool
- -- , firmActAddSupervisorPostal :: Maybe Bool
- -- }
+ | FirmActAddSupervisorsData
+ { firmActAddSupervisorIds :: Set Text
+ , firmActAddSupervisorReroute :: Bool
+ , firmActAddSupervisorPostal :: Maybe Bool
+ }
deriving (Eq, Ord, Read, Show, Generic)
firmActionMap :: [FirmAction] -> Map FirmAction (AForm Handler FirmActionData)
@@ -82,10 +82,10 @@ firmActionMap acts = mconcat (mkAct <$> acts)
mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
<*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
- -- mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData
- -- <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (Just mempty)
- -- <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True)
- -- <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (Just Nothing)
+ mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData
+ <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
+ <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True)
+ <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) Nothing
firmActionForm :: [FirmAction] -> AForm Handler FirmActionData
firmActionForm acts = multiActionA (firmActionMap acts) (fslI MsgTableAction) Nothing
@@ -123,28 +123,28 @@ firmActionHandler route = flip formResult faHandler
cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser]
redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
- -- faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do
- -- avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds
- -- let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
- -- usersFound = mapMaybe snd usersFound'
- -- unless (null usersNotFound) $
- -- let msgContent = [whamlet|
- -- $newline never
- --
- -- $forall (usr,_) <- usersNotFound
- -- - #{usr}
- -- |]
- -- in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
- -- when (null usersFound) $ do
- -- addMessageI Warning MsgASReqEmpty
- -- reloadKeepGetParams route
- -- runDB $ do
- -- putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound]
- -- whenIsJust firmActAddSupervisorPostal $ \prefPostal ->
- -- updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
- -- addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal
- -- redirect route
- -- faHandler _ = addMessageI Error MsgErrorUnknownFormAction
+ faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do
+ avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds
+ let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
+ usersFound = mapMaybe snd usersFound'
+ unless (null usersNotFound) $
+ let msgContent = [whamlet|
+ $newline never
+
+ $forall (usr,_) <- usersNotFound
+ - #{usr}
+ |]
+ in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
+ when (null usersFound) $ do
+ addMessageI Warning MsgASReqEmpty
+ reloadKeepGetParams route
+ runDB $ do
+ putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound]
+ whenIsJust firmActAddSupervisorPostal $ \prefPostal ->
+ updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
+ addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal
+ redirect route
+ faHandler _ = addMessageI Error MsgErrorUnknownFormAction
runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget
@@ -554,25 +554,14 @@ mkFirmAllTable isAdmin uid = do
, prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
- acts :: Map FirmAction (AForm Handler FirmActionData)
- acts = mconcat
- [ singletonMap FirmActNotify $ pure FirmActNotifyData
- , singletonMap FirmActResetSupervision $ FirmActResetSupervisionData
- <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
- ]
-
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
-- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision]
- -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just
- -- <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing
- , dbParamsFormAdditional
- = renderAForm FormStandard $ (, mempty) . First . Just
- <$> multiActionA acts (fslI MsgTableAction) Nothing
+ , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just
+ <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
@@ -602,32 +591,7 @@ postFirmAllR = do
uid <- requireAuthId
isAdmin <- hasReadAccessTo AdminR
(firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
- -- firmActionHandler FirmAllR firmRes
- formResult firmRes $ \case
- (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected
-
- (FirmActResetSupervisionData{..}, fids) -> do
- runDB $ do
- delSupers <- if firmActResetKeepOldSupers == Just False
- then E.deleteCount $ do
- spr <- E.from $ E.table @UserSupervisor
- E.where_ $ E.exists $ do
- usr <- E.from $ E.table @UserCompany
- E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
- E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
- else return 0
- newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids
- addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
- reloadKeepGetParams FirmAllR -- reload to reflect changes
-
- (FirmActNotifyData , Set.toList -> fids) -> do
- usrs <- runDB $ E.select $ E.distinct $ do
- (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
- E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids
- return $ usr E.^. UserId
- cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser]
- redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
-
+ firmActionHandler FirmAllR firmRes
siteLayoutMsg MsgMenuFirms $ do
setTitleI MsgMenuFirms
$(i18nWidgetFile "firm-all")
@@ -818,8 +782,8 @@ mkFirmUserTable isAdmin cid = do
acts = mconcat
[ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
, singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
- <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
- -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
+ <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False)
+ -- <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True )
, singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
<$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
]
@@ -848,7 +812,7 @@ mkFirmUserTable isAdmin cid = do
let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m
return (act, s)
- -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData))
+ -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData))
resultDBTableValidator = def
& defaultSorting [SortAscBy "user-name"]
over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
@@ -917,8 +881,7 @@ postFirmUsersR fsh = do
, formSubmit = FormSubmit
, formAnchor = Just addFormAnchor
}
- formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=fucrPAddr} -> do
- -- let fucrPAddr = canonical fucrPAddr' TODO
+ formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=(canonical -> fucrPAddr)} -> do
when (isJust fucrPPref || isJust fucrPAddr) $ do
let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPPref <>
foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPAddr -- seems weird, but: Nothing means no change, and not delete address!
@@ -1146,7 +1109,7 @@ postFirmSupersR fsh = do
cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
- formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActNotify, FirmActResetSupervision] -- TODO ,FirmActAddSupervisors]
+ formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupervisors, FirmActResetSupervision]
((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def)
let addSuperAnchor = "add-supervisors-form" :: Text