|
|
|
|
@ -48,12 +48,134 @@ decryptUser = decrypt
|
|
|
|
|
encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser
|
|
|
|
|
encryptUser = encrypt
|
|
|
|
|
|
|
|
|
|
postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool
|
|
|
|
|
postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged
|
|
|
|
|
|
|
|
|
|
---------------------------------
|
|
|
|
|
-- General firm affecting actions
|
|
|
|
|
|
|
|
|
|
data FirmAction = FirmActNotify
|
|
|
|
|
| FirmActResetSupervision
|
|
|
|
|
-- | FirmActAddSupervisors
|
|
|
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
|
|
|
|
|
|
nullaryPathPiece ''FirmAction $ camelToPathPiece' 3
|
|
|
|
|
embedRenderMessage ''UniWorX ''FirmAction id
|
|
|
|
|
|
|
|
|
|
data FirmActionData = FirmActNotifyData
|
|
|
|
|
| FirmActResetSupervisionData
|
|
|
|
|
{ firmActResetKeepOldSupers :: Maybe Bool
|
|
|
|
|
, firmActResetMutualSupervision :: Maybe Bool
|
|
|
|
|
}
|
|
|
|
|
-- | FirmActAddSupervisorsData
|
|
|
|
|
-- { firmActAddSupervisorIds :: Set Text
|
|
|
|
|
-- , firmActAddSupervisorReroute :: Bool
|
|
|
|
|
-- , firmActAddSupervisorPostal :: Maybe Bool
|
|
|
|
|
-- }
|
|
|
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
|
|
|
|
|
|
firmActionMap :: [FirmAction] -> Map FirmAction (AForm Handler FirmActionData)
|
|
|
|
|
firmActionMap acts = mconcat (mkAct <$> acts)
|
|
|
|
|
where
|
|
|
|
|
mkAct FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData
|
|
|
|
|
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)
|
|
|
|
|
|
|
|
|
|
firmActionForm :: [FirmAction] -> AForm Handler FirmActionData
|
|
|
|
|
firmActionForm acts = multiActionA (firmActionMap acts) (fslI MsgTableAction) Nothing
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
makeFirmActionForm :: CompanyId -> [FirmAction] -> Form (FirmActionData, Set CompanyId)
|
|
|
|
|
makeFirmActionForm cid acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm acts
|
|
|
|
|
|
|
|
|
|
-- makeFirmActionTableForm :: Monoid t => [FirmAction] -> Text.Blaze.Internal.Markup -> Control.Monad.Trans.RWS.Lazy.RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints Handler (FormResult (First FirmActionData, t), WidgetFor UniWorX ())
|
|
|
|
|
-- makeFirmActionTableForm acts = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm acts
|
|
|
|
|
|
|
|
|
|
firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler ()
|
|
|
|
|
firmActionHandler route = flip formResult faHandler
|
|
|
|
|
where
|
|
|
|
|
faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
|
|
|
|
|
faHandler (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 route -- reload to reflect changes
|
|
|
|
|
|
|
|
|
|
faHandler (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])
|
|
|
|
|
|
|
|
|
|
-- 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
|
|
|
|
|
-- <ul>
|
|
|
|
|
-- $forall (usr,_) <- usersNotFound
|
|
|
|
|
-- <li>#{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
|
|
|
|
|
runFirmActionFormPost cid route acts = do
|
|
|
|
|
-- ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid acts
|
|
|
|
|
((faRes, faWgt), faEnctype) <- runFormPost $ makeFirmActionForm cid acts
|
|
|
|
|
let faAnchor = "firm-action-form" :: Text
|
|
|
|
|
faRoute = route :#: faAnchor
|
|
|
|
|
faForm = wrapForm faWgt FormSettings
|
|
|
|
|
{ formMethod = POST
|
|
|
|
|
, formAction = Just . SomeRoute $ faRoute
|
|
|
|
|
, formEncoding = faEnctype
|
|
|
|
|
, formAttrs = []
|
|
|
|
|
, formSubmit = FormSubmit
|
|
|
|
|
, formAnchor = Just faAnchor
|
|
|
|
|
}
|
|
|
|
|
firmActionHandler route faRes
|
|
|
|
|
return [whamlet|
|
|
|
|
|
<section>
|
|
|
|
|
<h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
|
|
|
|
|
_{MsgFirmAction}
|
|
|
|
|
<div>
|
|
|
|
|
^{faForm}
|
|
|
|
|
|]
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
---------------------------
|
|
|
|
|
-- Firm specific utilities
|
|
|
|
|
-- for filters and counts also see before FirmAllR Handlers
|
|
|
|
|
|
|
|
|
|
postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool
|
|
|
|
|
postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- remove supervisors:
|
|
|
|
|
deleteSupervisors :: NonEmpty UserId -> DB Int64
|
|
|
|
|
@ -315,7 +437,7 @@ resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool
|
|
|
|
|
resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget)
|
|
|
|
|
mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget)
|
|
|
|
|
mkFirmAllTable isAdmin uid = do
|
|
|
|
|
-- now <- liftIO getCurrentTime
|
|
|
|
|
let
|
|
|
|
|
@ -432,21 +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 FirmAllAction (AForm Handler FirmAllActionData)
|
|
|
|
|
acts = mconcat
|
|
|
|
|
[ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData
|
|
|
|
|
, singletonMap FirmAllActResetSupervision $ FirmAllActResetSupervisionData
|
|
|
|
|
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False)
|
|
|
|
|
<*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True )
|
|
|
|
|
]
|
|
|
|
|
dbtParams = DBParamsForm
|
|
|
|
|
{ dbParamsFormMethod = POST
|
|
|
|
|
, dbParamsFormAction = Nothing
|
|
|
|
|
, dbParamsFormAttrs = []
|
|
|
|
|
, dbParamsFormSubmit = FormSubmit
|
|
|
|
|
, dbParamsFormAdditional
|
|
|
|
|
= renderAForm FormStandard $ (, mempty) . First . Just
|
|
|
|
|
<$> multiActionA acts (fslI MsgTableAction) Nothing
|
|
|
|
|
-- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision]
|
|
|
|
|
, dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just
|
|
|
|
|
<$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing
|
|
|
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
|
|
|
, dbParamsFormResult = id
|
|
|
|
|
, dbParamsFormIdent = def
|
|
|
|
|
@ -457,14 +572,14 @@ mkFirmAllTable isAdmin uid = do
|
|
|
|
|
dbtCsvDecode = Nothing
|
|
|
|
|
dbtExtraReps = []
|
|
|
|
|
|
|
|
|
|
postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool AllCompanyTableData)
|
|
|
|
|
-> FormResult ( FirmAllActionData, Set CompanyId)
|
|
|
|
|
postprocess :: FormResult (First FirmActionData, DBFormResult CompanyId Bool AllCompanyTableData)
|
|
|
|
|
-> FormResult ( FirmActionData, Set CompanyId)
|
|
|
|
|
postprocess inp = do
|
|
|
|
|
(First (Just act), cmpMap) <- inp
|
|
|
|
|
let cmpSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) cmpMap
|
|
|
|
|
return (act, cmpSet)
|
|
|
|
|
|
|
|
|
|
-- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData))
|
|
|
|
|
-- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData))
|
|
|
|
|
resultDBTableValidator = def
|
|
|
|
|
& defaultSorting [SortAscBy "short"]
|
|
|
|
|
over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
|
|
|
|
|
@ -475,32 +590,8 @@ getFirmAllR = postFirmAllR
|
|
|
|
|
postFirmAllR = do
|
|
|
|
|
uid <- requireAuthId
|
|
|
|
|
isAdmin <- hasReadAccessTo AdminR
|
|
|
|
|
(firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
|
|
|
|
|
formResult firmRes $ \case
|
|
|
|
|
(_, fids) | null fids -> addMessageI Error MsgNoCompanySelected
|
|
|
|
|
|
|
|
|
|
(FirmAllActResetSupervisionData{..}, fids) -> do
|
|
|
|
|
runDB $ do
|
|
|
|
|
delSupers <- if firmAllActResetKeepOldSupers == 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 (firmAllActResetMutualSupervision /= Just False) fids
|
|
|
|
|
addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
|
|
|
|
|
reloadKeepGetParams FirmAllR -- reload to reflect changes
|
|
|
|
|
|
|
|
|
|
(FirmAllActNotifyData , 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])
|
|
|
|
|
|
|
|
|
|
(_firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
|
|
|
|
|
-- firmActionHandler FirmAllR firmRes
|
|
|
|
|
siteLayoutMsg MsgMenuFirms $ do
|
|
|
|
|
setTitleI MsgMenuFirms
|
|
|
|
|
$(i18nWidgetFile "firm-all")
|
|
|
|
|
@ -1019,6 +1110,8 @@ 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]
|
|
|
|
|
|
|
|
|
|
((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def)
|
|
|
|
|
let addSuperAnchor = "add-supervisors-form" :: Text
|
|
|
|
|
routeAddSuperForm = FirmSupersR fsh :#: addSuperAnchor
|
|
|
|
|
@ -1056,7 +1149,11 @@ postFirmSupersR fsh = do
|
|
|
|
|
setTitle $ citext2Html $ fsh <> " Supers"
|
|
|
|
|
let firmContactInfo = $(widgetFile "firm-contact-info")
|
|
|
|
|
$(i18nWidgetFile "firm-supervisors")
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
------------------------
|
|
|
|
|
-- Firm Communications
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html
|
|
|
|
|
getFirmCommR = postFirmCommR
|
|
|
|
|
|
