1259 lines
67 KiB
Haskell
1259 lines
67 KiB
Haskell
-- SPDX-FileCopyrightText: 2023 Steffen Jost <S.Jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports -Wno-unused-binds #-} -- TODO: remove me, for debugging only
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Handler.Firm
|
|
( getFirmAllR , postFirmAllR
|
|
, getFirmR , postFirmR
|
|
, getFirmUsersR , postFirmUsersR
|
|
, getFirmSupersR, postFirmSupersR
|
|
, getFirmCommR , postFirmCommR
|
|
, getFirmsCommR, postFirmsCommR
|
|
)
|
|
where
|
|
|
|
import Import
|
|
|
|
-- import Jobs
|
|
import Handler.Utils
|
|
import Handler.Utils.Communication
|
|
import Handler.Utils.Avs (guessAvsUser)
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
-- import qualified Data.Csv as Csv
|
|
-- import qualified Data.Text as T
|
|
import qualified Data.CaseInsensitive as CI
|
|
-- import qualified Data.Conduit.List as C
|
|
import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
|
|
import Database.Esqueleto.Experimental ((:&)(..))
|
|
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
|
import qualified Database.Esqueleto.Legacy as EL (from, on)
|
|
import qualified Database.Esqueleto.PostgreSQL as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
|
|
-- avoids repetition of local definitions
|
|
single :: (k,a) -> Map k a
|
|
single = uncurry Map.singleton
|
|
|
|
decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId
|
|
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
|
|
|
|
|
|
|
|
-- remove supervisors:
|
|
deleteSupervisors :: NonEmpty UserId -> DB Int64
|
|
deleteSupervisors usrs = deleteWhereCount [UserSupervisorUser <-. toList usrs]
|
|
|
|
-- reset supervisors given employees of a company to default company supervision, deleting all other supervisors
|
|
resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
|
|
resetSupervisors cid employees = do
|
|
nr_del <- deleteSupervisors employees
|
|
nr_add <- addDefaultSupervisors cid employees
|
|
return $ max nr_del nr_add
|
|
|
|
-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
|
|
addDefaultSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
|
|
addDefaultSupervisors cid employees = do
|
|
E.insertSelectWithConflictCount UniqueUserSupervisor
|
|
(do
|
|
(spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
|
|
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
|
|
E.&&. spr E.^. UserCompanySupervisor
|
|
return $ UserSupervisor
|
|
E.<# (spr E.^. UserCompanyUser)
|
|
E.<&> usr
|
|
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
|
)
|
|
(\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications])
|
|
|
|
-- like `addDefaultSupervisors`, but selects all employees of given companies from database
|
|
addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64
|
|
addDefaultSupervisorsAll mutualSupervision cids = do
|
|
E.insertSelectWithConflictCount UniqueUserSupervisor
|
|
(do
|
|
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
|
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
|
[ E.not_ $ usr E.^. UserCompanySupervisor ]
|
|
<> [ spr E.^. UserCompanySupervisor
|
|
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
|
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
|
]
|
|
return $ UserSupervisor
|
|
E.<# (spr E.^. UserCompanyUser)
|
|
E.<&> (usr E.^. UserCompanyUser)
|
|
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
|
)
|
|
(\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] )
|
|
|
|
|
|
------------------------------
|
|
-- repeatedly useful queries
|
|
|
|
fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery ()
|
|
fromUserCompany mbFltr cmpy = do
|
|
usrCmpy <- E.from $ E.table @UserCompany
|
|
let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
|
|
E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr
|
|
|
|
firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountUsers = E.subSelectCount . fromUserCompany Nothing
|
|
|
|
firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
|
|
-- firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
-- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do
|
|
-- usrCmpy <- E.from $ E.table @UserCompany
|
|
-- E.where_ $ (usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId)
|
|
-- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true)
|
|
-- return $ usrCmpy E.^. UserCompanyUser
|
|
|
|
firmHasSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool)
|
|
firmHasSupervisors = E.exists . fromUserCompany (Just (E.^. UserCompanySupervisor))
|
|
|
|
|
|
firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute))
|
|
|
|
firmHasDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool)
|
|
firmHasDefaultReroutes = E.exists . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute))
|
|
|
|
firmCountEmployeeSupervised :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr)
|
|
where
|
|
fltr :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)
|
|
fltr usrc = E.exists $ do
|
|
usrSuper <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser
|
|
|
|
firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr)
|
|
where
|
|
fltr usrc = E.exists $ do
|
|
usrSuper <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser
|
|
E.&&. usrSuper E.^. UserSupervisorRerouteNotifications
|
|
|
|
firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr)
|
|
where
|
|
fltr usrc = E.exists $ do
|
|
(usrSuper :& usr) <-
|
|
E.from $ E.table @UserSupervisor
|
|
`E.innerJoin` E.table @User
|
|
`E.on` (\(usrSuper :& usr) -> usrSuper E.^. UserSupervisorSupervisor E.==. usr E.^. UserId)
|
|
E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser
|
|
E.&&. usrSuper E.^. UserSupervisorRerouteNotifications
|
|
E.&&. usr E.^. UserPrefersPostal
|
|
E.&&. E.isJust (usr E.^. UserPostAddress)
|
|
|
|
|
|
-- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
-- firmCountForeignSupervisors cmpy = E.coalesceDefault
|
|
-- [E.subSelect $ do
|
|
-- usrSuper <- E.from $ E.table @UserSupervisor
|
|
-- E.groupBy (usrSuper E.^. UserSupervisorSupervisor)
|
|
-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
|
|
-- E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
|
|
-- return E.countRows
|
|
-- ] (E.val 0)
|
|
|
|
firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do
|
|
usrSuper <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
|
|
E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
|
|
pure $ usrSuper E.^. UserSupervisorSupervisor
|
|
|
|
-- firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
-- firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do
|
|
-- usrSuper <- E.from $ E.table @UserSupervisor
|
|
-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
|
|
-- E.&&. usrSuper E.^. UserSupervisorRerouteNotifications
|
|
-- pure $ usrSuper E.^. UserSupervisorSupervisor
|
|
|
|
firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
firmCountActiveReroutes cmpy = E.subSelectCount $ do
|
|
usrSuper <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
|
|
E.&&. usrSuper E.^. UserSupervisorRerouteNotifications
|
|
|
|
firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery ()
|
|
firmQuerySupervisedBy cid mbFltr usr = do
|
|
(usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor
|
|
`E.innerJoin` E.table @UserCompany
|
|
`E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser)
|
|
let basecond = usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
|
|
E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid
|
|
E.where_ $ maybe basecond ((basecond E.&&.).($ usrSpr)) mbFltr
|
|
|
|
firmCountForSupervisor :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Word64)
|
|
firmCountForSupervisor = ((E.subSelectCount .) .) . firmQuerySupervisedBy
|
|
|
|
firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64)
|
|
firmCountUserSupervisors usrCmp = E.subSelectCount $ do
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser
|
|
|
|
firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64)
|
|
firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser
|
|
E.&&. usrSpr E.^. UserSupervisorRerouteNotifications
|
|
|
|
|
|
------------------
|
|
-- Debug Handler
|
|
|
|
getFirmR, postFirmR :: CompanyShorthand -> Handler Html
|
|
getFirmR = postFirmR
|
|
postFirmR fsh = do
|
|
let cid = CompanyKey fsh
|
|
cusers <- runDB $ do
|
|
cusers <- selectList [UserCompanyCompany ==. cid] []
|
|
selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName]
|
|
csuper <- runDB $ do
|
|
csuper <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] []
|
|
selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName]
|
|
cactSuper <- runDB $ E.select $ do
|
|
(usr :& spr :& scmpy) <- E.from $
|
|
E.table @User
|
|
`E.innerJoin` E.table @UserSupervisor
|
|
`E.on` (\(usr :& spr ) -> spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId)
|
|
`E.leftJoin` E.table @UserCompany
|
|
`E.on` (\(_ :& spr :& scmpy) -> spr E.^. UserSupervisorSupervisor E.=?. scmpy E.?. UserCompanyUser)
|
|
E.where_ $ (spr E.^. UserSupervisorUser) `E.in_` E.valList (entityKey <$> cusers)
|
|
E.groupBy (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany)
|
|
E.orderBy [E.asc $ usr E.^. UserId, E.asc $ usr E.^. UserDisplayName, E.asc $ usr E.^. UserSurname, E.asc $ scmpy E.?. UserCompanyCompany]
|
|
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
|
|
return (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany, countRows', usr E.^. UserPrefersPostal)
|
|
|
|
siteLayoutMsg (SomeMessage fsh) $ do
|
|
setTitle $ citext2Html fsh
|
|
[whamlet|
|
|
<h2>PROVISORISCHE DEBUG SEITE
|
|
<p>Diese Seite wird in der finalen Version nicht mehr enthalten sein.
|
|
|
|
<h3>#{length csuper} Company Default Supervisors (non-foreign only)
|
|
<ul>
|
|
$forall u <- csuper
|
|
<li>^{linkUserWidget ForProfileDataR u}
|
|
|
|
<h3>#{length cactSuper} Active Supervisors for Employees
|
|
<ul>
|
|
$forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr, E.Value prefPost) <- cactSuper
|
|
<li>#{nr} Employees supervised by ^{nameWidget dn sn} #
|
|
#{iconLetterOrEmail prefPost} #
|
|
$maybe csh <- mbCsh
|
|
$if csh /= cid
|
|
from foreign company #{unCompanyKey csh}
|
|
$else
|
|
from this company
|
|
$nothing
|
|
having no associated company
|
|
|
|
<h3>#{length cusers} Employees
|
|
<ul>
|
|
$forall u <- cusers
|
|
<li>^{linkUserWidget ForProfileDataR u}
|
|
|
|
In the end, this needs to be a dbTable, of course!
|
|
|]
|
|
|
|
|
|
-----------------------
|
|
-- All Firms Table
|
|
|
|
data FirmAllAction = FirmAllActNotify
|
|
| FirmAllActResetSupervision
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3
|
|
embedRenderMessage ''UniWorX ''FirmAllAction id
|
|
|
|
data FirmAllActionData = FirmAllActNotifyData
|
|
| FirmAllActResetSupervisionData
|
|
{ firmAllActResetKeepOldSupers :: Maybe Bool
|
|
, firmAllActResetMutualSupervision :: Maybe Bool
|
|
}
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
-- just in case for future extensions
|
|
type AllCompanyTableExpr = E.SqlExpr (Entity Company)
|
|
queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company)
|
|
queryAllCompany = id
|
|
|
|
type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Bool, E.Value Bool)
|
|
resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company)
|
|
resultAllCompanyEntity = _dbrOutput . _1
|
|
|
|
resultAllCompany :: Lens' AllCompanyTableData Company
|
|
resultAllCompany = resultAllCompanyEntity . _entityVal
|
|
|
|
resultAllCompanyUsers :: Lens' AllCompanyTableData Word64
|
|
resultAllCompanyUsers = _dbrOutput . _2 . _unValue
|
|
|
|
resultAllCompanySupervisors :: Lens' AllCompanyTableData Bool
|
|
resultAllCompanySupervisors = _dbrOutput . _3 . _unValue
|
|
|
|
resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool
|
|
resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue
|
|
|
|
|
|
mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget)
|
|
mkFirmAllTable isAdmin uid = do
|
|
-- now <- liftIO getCurrentTime
|
|
let
|
|
resultDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery cmpy = do
|
|
unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies
|
|
usrCmpy <- E.from $ E.table @UserCompany
|
|
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
|
|
E.&&. ((usrCmpy E.^. UserCompanyUser E.==. E.val uid E.&&. usrCmpy E.^. UserCompanySupervisor)
|
|
E.||. E.exists (do
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmpy E.^. UserCompanyUser
|
|
E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid
|
|
))
|
|
return ( cmpy -- 1
|
|
, cmpy & firmCountUsers -- 2
|
|
, cmpy & firmHasSupervisors -- 3
|
|
, cmpy & firmHasDefaultReroutes -- 4
|
|
-- , cmpy & firmCountEmployeeSupervised -- 4
|
|
-- , cmpy & firmCountEmployeeRerouted -- 5
|
|
-- , cmpy & firmCountEmployeeRerPost -- 6
|
|
-- , cmpy & firmCountForeignSupervisors -- 7
|
|
-- , cmpy & firmCountActiveReroutes -- 9
|
|
-- , cmpy & firmCountActiveReroutes' -- 10
|
|
)
|
|
dbtRowKey = (E.^. CompanyId)
|
|
dbtProj = dbtProjId
|
|
dbtColonnade = formColonnade $ mconcat
|
|
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey))
|
|
, sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) ->
|
|
anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm
|
|
, sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) ->
|
|
let fsh = companyShorthand firm
|
|
in anchorCell (FirmUsersR fsh) $ toWgt fsh
|
|
, sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) ->
|
|
anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm
|
|
, sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr
|
|
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row ->
|
|
anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors
|
|
, sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> ok) -> tickmarkCell ok
|
|
-- , sortable (Just "emp-supervised")(i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultAllCompanyEmployeeSupervised -> nr) -> wgtCell $ word2widget nr
|
|
-- , sortable (Just "emp-rerouted") (i18nCell MsgTableCompanyNrEmpRerouted) $ \(view resultAllCompanyEmployeeRerouted -> nr) -> wgtCell $ word2widget nr
|
|
-- , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr
|
|
-- , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr
|
|
-- , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr
|
|
-- , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr
|
|
, sortable (Just "postal-pref") (i18nCell MsgTableCompanyPostalPreference) $ \(view $ resultAllCompany . _companyPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
|
|
]
|
|
dbtSorting = mconcat
|
|
[ singletonMap "name" $ SortColumn (E.^. CompanyName)
|
|
, singletonMap "short" $ SortColumn (E.^. CompanyShorthand)
|
|
, singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId)
|
|
, singletonMap "postal-pref" $ SortColumn (E.^. CompanyPrefersPostal)
|
|
, singletonMap "users" $ SortColumn firmCountUsers
|
|
, singletonMap "supervisors" $ SortColumn firmHasSupervisors
|
|
-- , singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised
|
|
-- , singletonMap "emp-rerouted" $ SortColumn firmCountEmployeeRerouted
|
|
-- , singletonMap "emp-rer-post" $ SortColumn firmCountEmployeeRerPost
|
|
, singletonMap "reroute-def" $ SortColumn firmHasDefaultReroutes
|
|
-- , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors
|
|
-- , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes
|
|
-- , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes'
|
|
]
|
|
dbtFilter = mconcat
|
|
[ single $ fltrCompanyNameNr queryAllCompany
|
|
, single ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId)))
|
|
, single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
|
|
(usr :& usrCmp) <- E.from $ E.table @User
|
|
`E.innerJoin` E.table @UserCompany
|
|
`E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser)
|
|
E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
|
|
E.&&. ( (usr E.^. UserDisplayName `E.hasInfix` E.val criterion)
|
|
E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
|
|
E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion)
|
|
)
|
|
)
|
|
, single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) ->
|
|
-- let checkSuper = do -- expensive
|
|
-- usrSpr <- E.from $ E.table @UserSupervisor
|
|
-- E.where_ $ E.notExists (do
|
|
-- spr <- E.from $ E.table @UserCompany
|
|
-- E.where_ $ spr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
|
|
-- E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor
|
|
-- ) E.&&. E.exists (do
|
|
-- usr <- E.from $ E.table @UserCompany
|
|
-- E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
|
|
-- E.&&. usr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser
|
|
-- )
|
|
let checkSuper = do
|
|
usr <- E.from $ E.table @UserCompany
|
|
E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
|
|
E.&&. E.exists (do
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser
|
|
E.&&. E.notExists (do
|
|
sprCmp <- E.from $ E.table @UserCompany
|
|
E.where_ $ sprCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
|
|
E.&&. sprCmp E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor
|
|
)
|
|
)
|
|
in case criterion of
|
|
Nothing -> E.true
|
|
Just True -> E.exists checkSuper
|
|
Just False -> E.notExists checkSuper
|
|
)
|
|
, single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress)))
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ fltrCompanyNameUI mPrev
|
|
, prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo)
|
|
, prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
|
|
, prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor)
|
|
, 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
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
dbtIdent :: Text
|
|
dbtIdent = "firm"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
|
|
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 FirmActionData, DBFormResult CompanyId Bool FirmActionData))
|
|
resultDBTableValidator = def
|
|
& defaultSorting [SortAscBy "short"]
|
|
over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
|
|
|
|
|
|
getFirmAllR, postFirmAllR :: Handler Html
|
|
getFirmAllR = postFirmAllR
|
|
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])
|
|
|
|
siteLayoutMsg MsgMenuFirms $ do
|
|
setTitleI MsgMenuFirms
|
|
$(i18nWidgetFile "firm-all")
|
|
|
|
|
|
-----------------------
|
|
-- Firm Users Table
|
|
|
|
data FirmUserChangeRequest = FirmUserChangeRequest
|
|
{ fucrPostalPref :: Maybe Bool
|
|
, fucrPostalAddr :: Maybe StoredMarkup
|
|
}
|
|
deriving (Eq, Ord, Show, Generic)
|
|
|
|
instance Default FirmUserChangeRequest where
|
|
def = FirmUserChangeRequest
|
|
{ fucrPostalPref = Nothing
|
|
, fucrPostalAddr = Nothing
|
|
}
|
|
|
|
makeFirmUserChangeRequestForm :: Maybe FirmUserChangeRequest -> Form FirmUserChangeRequest
|
|
makeFirmUserChangeRequestForm template html = do
|
|
flip (renderAForm FormStandard) html $ FirmUserChangeRequest
|
|
<$> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (fucrPostalPref <$> template)
|
|
<*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (fucrPostalAddr <$> template)
|
|
|
|
|
|
data FirmUserAction = FirmUserActNotify
|
|
| FirmUserActResetSupervision
|
|
| FirmUserActMkSuper
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''FirmUserAction $ camelToPathPiece' 3
|
|
embedRenderMessage ''UniWorX ''FirmUserAction id
|
|
|
|
data FirmUserActionData = FirmUserActNotifyData
|
|
| FirmUserActResetSupervisionData
|
|
{ firmUserActResetKeepOldSupers :: Maybe Bool
|
|
-- , firmUserActResetMutualSupervision :: Maybe Bool
|
|
}
|
|
| FirmUserActMkSuperData
|
|
{ firmUserActMkSuperReroute :: Maybe Bool }
|
|
|
|
deriving (Eq, Ord, Show, Generic)
|
|
|
|
type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany)
|
|
|
|
queryUserUser :: UserCompanyTableExpr -> E.SqlExpr (Entity User)
|
|
queryUserUser = $(sqlIJproj 2 1)
|
|
|
|
queryUserUserCompany :: UserCompanyTableExpr -> E.SqlExpr (Entity UserCompany)
|
|
queryUserUserCompany = $(sqlIJproj 2 2)
|
|
|
|
type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64)
|
|
|
|
resultUserUser :: Lens' UserCompanyTableData (Entity User)
|
|
resultUserUser = _dbrOutput . _1
|
|
|
|
resultUserUserCompany :: Lens' UserCompanyTableData (Entity UserCompany)
|
|
resultUserUserCompany = _dbrOutput . _2
|
|
|
|
resultUserCompanySupervisors :: Lens' UserCompanyTableData Word64
|
|
resultUserCompanySupervisors = _dbrOutput . _3 . _unValue
|
|
|
|
resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64
|
|
resultUserCompanyReroutes = _dbrOutput . _4 . _unValue
|
|
|
|
instance HasEntity UserCompanyTableData User where
|
|
hasEntity = resultUserUser
|
|
|
|
instance HasUser UserCompanyTableData where
|
|
hasUser = resultUserUser . _entityVal
|
|
|
|
|
|
mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget)
|
|
mkFirmUserTable isAdmin cid = do
|
|
let
|
|
mkSprOption (E.Value uid, E.Value udn) = do
|
|
uuid <- toPathPiece <$> encryptUser uid
|
|
return Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }
|
|
procOptions = fmap mkOptionList . traverse mkSprOption
|
|
|
|
rawSupers <- E.select $ do
|
|
usr <- E.from $ E.table @User
|
|
E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr
|
|
return (usr E.^. UserId, usr E.^. UserDisplayName)
|
|
let
|
|
-- supervisorField :: Field Handler UserId
|
|
supervisorField = selectField $ procOptions rawSupers
|
|
supervisorsField = multiSelectField $ procOptions rawSupers
|
|
|
|
fsh = unCompanyKey cid
|
|
resultDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do
|
|
EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
|
|
E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid
|
|
return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp)
|
|
dbtRowKey = queryUserUser >>> (E.^. UserId)
|
|
dbtProj = dbtProjId
|
|
dbtColonnade = formColonnade $ mconcat
|
|
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey))
|
|
, colUserNameModalHdr MsgTableCompanyUser ForProfileDataR
|
|
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr
|
|
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t
|
|
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr
|
|
, sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr
|
|
, sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
|
|
, colUserEmail
|
|
, sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr
|
|
]
|
|
dbtSorting = mconcat
|
|
[ single $ sortUserNameLink queryUserUser
|
|
, single $ sortUserEmail queryUserUser
|
|
, singletonMap "postal-pref" $ SortColumn $ queryUserUser >>> (E.^. UserPrefersPostal)
|
|
, singletonMap "matriculation" $ SortColumn $ queryUserUser >>> (E.^. UserMatrikelnummer)
|
|
, singletonMap "personal-number" $ SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber)
|
|
, singletonMap "supervisors" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors
|
|
, singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute
|
|
]
|
|
dbtFilter = mconcat
|
|
[ single $ fltrUserNameEmail queryUserUser
|
|
, singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
let checkSuper = do
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
in case criterion of
|
|
Nothing -> E.true
|
|
Just True -> E.exists checkSuper
|
|
Just False -> E.notExists checkSuper
|
|
, singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
let checkSuper = do
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
E.&&. E.exists (do
|
|
spr <- E.from $ E.table @UserCompany
|
|
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
|
|
E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor
|
|
)
|
|
in case criterion of
|
|
Nothing -> E.true
|
|
Just True -> E.exists checkSuper
|
|
Just False -> E.notExists checkSuper
|
|
, singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
let checkSuper = do
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
E.&&. E.notExists (do
|
|
spr <- E.from $ E.table @UserCompany
|
|
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
|
|
E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor
|
|
)
|
|
in case criterion of
|
|
Nothing -> E.true
|
|
Just True -> E.exists checkSuper
|
|
Just False -> E.notExists checkSuper
|
|
, singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
case criterion of
|
|
Just uid -> do
|
|
-- uid <- decryptUser uuid
|
|
E.exists $ do
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid
|
|
_otherwise -> E.true
|
|
, singletonMap "supervisors-are" $ FilterColumn $ \row criteria ->
|
|
case criteria of
|
|
_ | Set.null criteria -> E.true
|
|
| otherwise -> do
|
|
-- uids <- traverse decryptUser criteria
|
|
E.exists $ do
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria
|
|
]
|
|
-- superField = selectField $ ????
|
|
dbtFilterUI mPrev = mconcat
|
|
[ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
|
|
, prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor)
|
|
, prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor)
|
|
, prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor)
|
|
, prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh)
|
|
, prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh)
|
|
]
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
acts :: Map FirmUserAction (AForm Handler FirmUserActionData)
|
|
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 )
|
|
, singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
|
|
<$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
|
|
]
|
|
dbtParams = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Nothing
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional
|
|
= renderAForm FormStandard $ (, mempty) . First . Just
|
|
<$> multiActionA acts (fslI MsgTableAction) Nothing
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
dbtIdent :: Text
|
|
dbtIdent = "firm-users"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
|
|
postprocess :: FormResult (First FirmUserActionData, DBFormResult UserId Bool UserCompanyTableData)
|
|
-> FormResult ( FirmUserActionData, Set UserId)
|
|
postprocess inp = do
|
|
(First (Just act), m) <- inp
|
|
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 = def
|
|
& defaultSorting [SortAscBy "user-name"]
|
|
over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
|
|
|
|
|
|
getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
|
|
getFirmUsersR = postFirmUsersR
|
|
postFirmUsersR fsh = do
|
|
isAdmin <- hasReadAccessTo AdminR
|
|
let cid = CompanyKey fsh
|
|
(( Entity{entityVal=Company{..}}
|
|
, E.Value nrCompanyUsers
|
|
, E.Value nrCompanySupervisors
|
|
, E.Value nrCompanyForeignSupers
|
|
, E.Value nrCompanyEmployeeSupervised
|
|
, E.Value nrCompanyEmployeeRerouted
|
|
, E.Value nrCompanyEmployeeRerPost
|
|
, E.Value nrCompanyDefaultReroutes
|
|
, E.Value nrCompanyActiveReroutes
|
|
) , (fusrRes, fusrTable)) <- runDB $ (,)
|
|
<$> fromMaybeM notFound (E.selectOne $ do
|
|
cmpy <- E.from $ E.table @Company
|
|
E.where_ $ cmpy E.^. CompanyId E.==. E.val cid
|
|
return ( cmpy
|
|
, cmpy & firmCountUsers
|
|
, cmpy & firmCountSupervisors
|
|
, cmpy & firmCountForeignSupervisors
|
|
, cmpy & firmCountEmployeeSupervised
|
|
, cmpy & firmCountEmployeeRerouted
|
|
, cmpy & firmCountEmployeeRerPost
|
|
, cmpy & firmCountDefaultReroutes
|
|
, cmpy & firmCountActiveReroutes
|
|
))
|
|
-- superVs <- E.select $ do
|
|
-- usr <- E.from $ E.table @User
|
|
-- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr
|
|
-- return usr
|
|
<*> mkFirmUserTable isAdmin cid
|
|
|
|
formResult fusrRes $ \case
|
|
(_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
|
|
(FirmUserActMkSuperData{..}, Set.toList -> uids) -> do
|
|
nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
|
|
addMessageI Info $ MsgASReqSetSupers nrMkSuper Nothing
|
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
|
(FirmUserActNotifyData , uids) -> do
|
|
cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
|
|
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
|
(FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do -- set guaranteed to be non-empty due to first case clause
|
|
runDB $ do
|
|
delSupers <- if firmUserActResetKeepOldSupers == Just False
|
|
then deleteSupervisors uids
|
|
else return 0
|
|
newSupers <- addDefaultSupervisors cid uids
|
|
addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
|
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
|
|
|
((fucrRes, fucrWgt), fucrEnctype) <- runFormPost . identifyForm FIDFirmUserChangeRequest $ makeFirmUserChangeRequestForm (Just def)
|
|
let addFormAnchor = "firm-user-change-form" :: Text
|
|
routeForm = FirmUsersR fsh :#: addFormAnchor
|
|
fucrForm = wrapForm fucrWgt FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ routeForm
|
|
, formEncoding = fucrEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just addFormAnchor
|
|
}
|
|
formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=fucrPAddr} -> do
|
|
-- let fucrPAddr = canonical fucrPAddr' TODO
|
|
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!
|
|
nrChanged <- runDB $ E.updateCount $ \usr -> do
|
|
E.set usr changes
|
|
E.where_ $ E.exists $ do
|
|
usrCmpy <- E.from $ E.table @UserCompany
|
|
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
|
|
E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId
|
|
addMessageI Info $ MsgFirmUserChanges nrChanged
|
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
|
|
|
siteLayout (citext2widget companyName) $ do
|
|
setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId
|
|
let firmContactInfo = $(widgetFile "firm-contact-info")
|
|
$(widgetFile "firm-users")
|
|
|
|
|
|
-----------------------------
|
|
-- Firm Supervisors Table
|
|
|
|
data FirmSuperAction = FirmSuperActNotify
|
|
| FirmSuperActRMSuperDef
|
|
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''FirmSuperAction $ camelToPathPiece' 3
|
|
embedRenderMessage ''UniWorX ''FirmSuperAction id
|
|
|
|
data FirmSuperActionData = FirmSuperActNotifyData
|
|
| FirmSuperActRMSuperDefData
|
|
{ firmSuperActRMSuperActive :: Maybe Bool }
|
|
|
|
deriving (Eq, Ord, Show, Generic)
|
|
|
|
|
|
data AddSupervisorRequest = AddSupervisorRequest
|
|
{ asReqSupers :: Set Text
|
|
, asReqReroute :: Bool
|
|
, asReqPostal :: Maybe Bool
|
|
} deriving (Eq, Ord, Show, Generic)
|
|
|
|
instance Default AddSupervisorRequest where
|
|
def = AddSupervisorRequest
|
|
{ asReqSupers = mempty
|
|
, asReqReroute = True
|
|
, asReqPostal = Nothing
|
|
}
|
|
|
|
makeAddSupervisorForm :: Maybe AddSupervisorRequest -> Form AddSupervisorRequest
|
|
makeAddSupervisorForm template html = do
|
|
flip (renderAForm FormStandard) html $ AddSupervisorRequest
|
|
<$> areq (textField & cfAnySeparatedSet)
|
|
(fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (asReqSupers <$> template)
|
|
<*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (asReqReroute <$> template)
|
|
<*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (asReqPostal <$> template)
|
|
|
|
|
|
type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany))
|
|
|
|
querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User)
|
|
querySuperUser = $(sqlLOJproj 2 1)
|
|
|
|
querySuperUserCompany :: SuperCompanyTableExpr -> E.SqlExpr (Maybe (Entity UserCompany))
|
|
querySuperUserCompany = $(sqlLOJproj 2 2)
|
|
|
|
type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64
|
|
, [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]
|
|
, E.Value (Maybe Bool), E.Value (Maybe Bool) -- Maybe (Entity UserCompany)
|
|
)
|
|
|
|
resultSuperUser :: Lens' SuperCompanyTableData (Entity User)
|
|
resultSuperUser = _dbrOutput . _1
|
|
|
|
resultSuperCompanySupervised :: Lens' SuperCompanyTableData Word64
|
|
resultSuperCompanySupervised = _dbrOutput . _2 . _unValue
|
|
|
|
resultSuperCompanyReroutes :: Lens' SuperCompanyTableData Word64
|
|
resultSuperCompanyReroutes = _dbrOutput . _3 . _unValue
|
|
|
|
resultSuperCompanies :: Lens' SuperCompanyTableData [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]
|
|
resultSuperCompanies = _dbrOutput . _4
|
|
|
|
resultSuperCompanyDefaultSuper :: Lens' SuperCompanyTableData (Maybe Bool)
|
|
resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue
|
|
|
|
resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool)
|
|
resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue
|
|
|
|
instance HasEntity SuperCompanyTableData User where
|
|
hasEntity = resultSuperUser
|
|
|
|
instance HasUser SuperCompanyTableData where
|
|
hasUser = resultSuperUser . _entityVal
|
|
|
|
|
|
mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget)
|
|
mkFirmSuperTable isAdmin cid = do
|
|
let
|
|
-- fsh = unCompanyKey cid
|
|
resultDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do
|
|
EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid
|
|
E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
|
|
E.||. E.exists (firmQuerySupervisedBy cid Nothing usr)
|
|
return ( usr
|
|
, usr & firmCountForSupervisor cid Nothing
|
|
, usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
|
|
, usrCmp E.?. UserCompanySupervisor
|
|
, usrCmp E.?. UserCompanySupervisorReroute
|
|
)
|
|
dbtRowKey = querySuperUser >>> (E.^. UserId)
|
|
dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> do
|
|
cmps <- E.select $ do
|
|
(cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
|
|
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr)
|
|
E.orderBy [E.asc $ cmp E.^. CompanyName]
|
|
return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor)
|
|
return (usr, supervised, rerouted, cmps, supervisor, reroute)
|
|
dbtColonnade = formColonnade $ mconcat
|
|
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey))
|
|
, colUserNameModalHdr MsgTableSupervisor ForProfileDataR
|
|
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinked entUsr
|
|
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) ->
|
|
intercalate semicolonCell [companyCell cmpShort cmpName isSuper | (E.Value cmpName, E.Value cmpShort, E.Value isSuper) <- cmps]
|
|
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultSuperUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t
|
|
, sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultSuperUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
|
|
, colUserEmail
|
|
, sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr
|
|
, sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr
|
|
, sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell }
|
|
, sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True)
|
|
, sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr
|
|
]
|
|
dbtSorting = mconcat
|
|
[ single $ sortUserNameLink querySuperUser
|
|
, single $ sortUserEmail querySuperUser
|
|
, singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer)
|
|
, singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber)
|
|
, singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal)
|
|
, singletonMap "supervised" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid Nothing
|
|
, singletonMap "rerouted" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
|
|
, singletonMap "user-company" $ SortColumn (\row -> E.subSelect $ do
|
|
(cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
|
|
E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySuperUser row E.^. UserId
|
|
E.orderBy [E.asc $ cmp E.^. CompanyName]
|
|
return (cmp E.^. CompanyName)
|
|
)
|
|
, singletonMap "def-super" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisor)
|
|
, singletonMap "def-reroute" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisorReroute)
|
|
]
|
|
dbtFilter = mconcat
|
|
[ single $ fltrUserNameEmail querySuperUser
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev
|
|
]
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData)
|
|
acts = mconcat
|
|
[ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData
|
|
, singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData
|
|
<$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True)
|
|
]
|
|
dbtParams = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Nothing
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional
|
|
= renderAForm FormStandard $ (, mempty) . First . Just
|
|
<$> multiActionA acts (fslI MsgTableAction) Nothing
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
dbtIdent :: Text
|
|
dbtIdent = "firm-supervisors"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
|
|
postprocess :: FormResult (First FirmSuperActionData, DBFormResult UserId Bool SuperCompanyTableData)
|
|
-> FormResult ( FirmSuperActionData, Set UserId)
|
|
postprocess inp = do
|
|
(First (Just act), m) <- inp
|
|
let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m
|
|
return (act, s)
|
|
|
|
resultDBTableValidator = def
|
|
& defaultSorting [SortAscBy "user-name"]
|
|
over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
|
|
|
|
|
|
getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html
|
|
getFirmSupersR = postFirmSupersR
|
|
postFirmSupersR fsh = do
|
|
isAdmin <- hasReadAccessTo AdminR
|
|
let cid = CompanyKey fsh
|
|
(Company{..},(fsprRes,fsprTable)) <- runDB $ (,)
|
|
<$> get404 cid
|
|
<*> mkFirmSuperTable isAdmin cid
|
|
|
|
formResult fsprRes $ \case
|
|
(_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
|
|
(FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do
|
|
(nrRmSuper,nrRmActual) <- runDB $ (,)
|
|
<$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]
|
|
<*> if firmSuperActRMSuperActive /= Just True
|
|
then return 0
|
|
else E.deleteCount $ do
|
|
spr <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ spr E.^. UserSupervisorSupervisor `E.in_` E.vals uids
|
|
E.&&. E.exists (do
|
|
usr <- E.from $ E.table @UserCompany
|
|
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
|
|
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
|
)
|
|
addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual
|
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
|
|
|
(FirmSuperActNotifyData , uids) -> 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
|
|
addSuperForm = wrapForm asReqWgt FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ routeAddSuperForm
|
|
, formEncoding = asReqEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just addSuperAnchor
|
|
}
|
|
formResult asReqRes $ \AddSupervisorRequest{..} -> do
|
|
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser asReqSupers
|
|
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
|
|
redirect routeAddSuperForm
|
|
runDB $ do
|
|
putMany [UserCompany uid cid True asReqReroute | uid <- usersFound]
|
|
whenIsJust asReqPostal $ \prefPostal ->
|
|
updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
|
|
addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) asReqPostal
|
|
redirect $ FirmSupersR fsh
|
|
|
|
siteLayout (citext2widget fsh) $ do
|
|
setTitle $ citext2Html $ fsh <> " Supers"
|
|
let firmContactInfo = $(widgetFile "firm-contact-info")
|
|
$(i18nWidgetFile "firm-supervisors")
|
|
|
|
|
|
------------------------
|
|
-- Firm Communications
|
|
|
|
|
|
getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html
|
|
getFirmCommR = postFirmCommR
|
|
postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) [fsh]
|
|
|
|
|
|
getFirmsCommR, postFirmsCommR :: Companies -> Handler Html
|
|
getFirmsCommR = postFirmsCommR
|
|
postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR)
|
|
|
|
|
|
handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html
|
|
handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."]
|
|
handleFirmCommR ultDest cs = do
|
|
let
|
|
queryGiven :: [UserId] -> E.SqlQuery (E.SqlExpr (Entity User)) -- get users from a list of UserIds
|
|
queryGiven usrs = do
|
|
usr <- E.from $ E.table @User
|
|
E.where_ $ usr E.^. UserId `E.in_` E.valList usrs
|
|
return usr
|
|
mkCompanyUsrList :: [(E.Value (Maybe CompanyId), E.Value UserId)] -> Map.Map (Maybe CompanyId) [UserId]
|
|
mkCompanyUsrList l = Map.fromAscListWith (++) [(c,[u]) | (E.Value c, E.Value u) <- l]
|
|
toGrp = maybe RGFirmIndependent (RGFirmSupervisor . unCompanyKey)
|
|
csKeys = CompanyKey <$> cs
|
|
mbUser <- maybeAuthId
|
|
-- get employees of chosen companies
|
|
empys <- mkCompanyUsrList <$> runDB (E.select $ do
|
|
(emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser)
|
|
E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys
|
|
E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany]
|
|
return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId)
|
|
)
|
|
-- get supervisors of employees
|
|
sprs <- mkCompanyUsrList <$> runDB (E.select $ do
|
|
(spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser)
|
|
E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys)
|
|
E.||. (spr E.^. UserId E.=?. E.val mbUser)
|
|
E.||. E.exists (do
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId
|
|
E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList (concat $ Map.elems empys)
|
|
)
|
|
E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany]
|
|
return (cmp E.?. UserCompanyCompany, spr E.^. UserId)
|
|
)
|
|
|
|
commR CommunicationRoute
|
|
{ crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification }
|
|
, crTitle = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle }
|
|
, crUltDest = ultDest
|
|
, crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
|
, crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
|
, crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult
|
|
, crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))]
|
|
[(toGrp acid, queryGiven usrs) | (acid, usrs) <- Map.toAscList sprs ] ++
|
|
[(RGFirmEmployees $ unCompanyKey acid, queryGiven usrs) | (Just acid, usrs) <- Map.toAscList empys ]
|
|
}
|
|
|
|
{- Auswahlbox für Mitteilung:
|
|
Wenn Firma gewählt, dann zeige:
|
|
Alle Supervisor von Leuten in X, gruppiert nach deren Firma
|
|
Alle Teilnehmer von X
|
|
Wenn keine Firma gewählt, dann zeige:
|
|
Alle Supervisor von gewählten Leuten, gruppiert nach deren Firma
|
|
Alle gewählten Personen, gruppiert nach deren Firma
|
|
-}
|