fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
6ea3a30afc
fradrive/src/Handler/Firm.hs

1431 lines
84 KiB
Haskell
Raw Blame History

-- SPDX-FileCopyrightText: 2023 Steffen Jost <S.Jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS -Wno-unused-top-binds #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
{-# LANGUAGE TypeApplications #-}
module Handler.Firm
( getFirmAllR , postFirmAllR
, 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.Persist.Postgresql
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as EL (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
| FirmActAddSupersvisors
| FirmActChangeContactFirm
| FirmActChangeContactUser
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite)
nullaryPathPiece ''FirmAction $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''FirmAction id
data FirmActionData = FirmActNotifyData
| FirmActResetSupervisionData
{ firmActResetKeepOldSupers :: Maybe Bool
, firmActResetMutualSupervision :: Maybe Bool
}
| FirmActAddSupersvisorsData
{ firmActAddSupervisorIds :: Set Text
, firmActAddSupervisorReroute :: Bool
, firmActAddSupervisorPostal :: Maybe Bool
}
| FirmActChangeContactFirmData
{ firmActCCFPostalAddr :: Maybe StoredMarkup
, firmActCCFEmail :: Maybe UserEmail
, firmActCCFPostalPref :: Maybe Bool
}
| FirmActChangeContactUserData
{ firmActCCUPostalAddr :: Maybe StoredMarkup
, firmActCCUPostalPref :: Maybe Bool
}
deriving (Eq, Ord, Read, Show, Generic)
firmActionMap :: (_ -> Text) -> Bool -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData)
firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
where
mkAct True 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 _ FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData
<$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> areq checkBoxField (fslI MsgTableIsDefaultReroute) (Just True)
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
<*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
<* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive))
mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
mkAct _ _ = mempty
firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData
firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing
makeFirmActionForm :: CompanyId -> _ -> Bool -> [FirmAction] -> Form (FirmActionData, Set CompanyId)
makeFirmActionForm cid mr isAdmin acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr isAdmin acts
firmActionHandler :: Route UniWorX -> Bool -> FormResult (FirmActionData, Set CompanyId) -> Handler ()
firmActionHandler route isAdmin = flip formResult faHandler
where
faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
faHandler (FirmActNotifyData, Set.toList -> fids) = do
usrs <- runDBRead $ 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 (FirmActResetSupervisionData{..}, fids) = do
madId <- bool maybeAuthId (return Nothing) isAdmin
let suprFltr = if
| isAdmin -> const E.true
| (Just suprId) <- madId -> \spr -> spr E.^. UserSupervisorSupervisor E.==. E.val suprId
| otherwise -> const E.false
runDB $ do
delSupers <- if firmActResetKeepOldSupers == Just False
then E.deleteCount $ do
spr <- E.from $ E.table @UserSupervisor
E.where_ $ suprFltr spr E.&&. 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 <- addDefaultSupervisorsFor madId (firmActResetMutualSupervision /= Just False) fids
addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
reloadKeepGetParams route -- reload to reflect changes
faHandler (FirmActAddSupersvisorsData{..}, 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 MsgFirmActAddSupersEmpty
reloadKeepGetParams route
runDB $ do
-- putMany [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] -- putMany always overwrites existing records, which would destroy priority and useCompanyAddress here
-- upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [copyField UserCompanySupervisor, copyField UserCompanySupervisorReroute] [] [] -- overwrite Supervisor and SupervisorReroute, keep priority and useCompanyAddress
upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute] [] -- identical to previous line, but perhaps more clear?
whenIsJust firmActAddSupervisorPostal $ \prefPostal ->
updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal
redirect route
faHandler (FirmActChangeContactFirmData{..}, Set.toList -> [cid]) =
let changes = catMaybes
[ (CompanyPostAddress =.) . Just <$> canonical firmActCCFPostalAddr
, (CompanyEmail =.) . Just <$> canonical firmActCCFEmail
, (CompanyPrefersPostal =.) <$> firmActCCFPostalPref
]
in unless (null changes) $ do
runDB $ update cid changes
addMessageI Success MsgFirmActChangeContactFirmResult
reloadKeepGetParams route
faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid]) =
let changes = catMaybes
[ (UserPostAddress E.=.) . E.justVal <$> canonical firmActCCUPostalAddr -- note that Nothing means no change and not delete address!
, (UserPrefersPostal E.=.) . E.val <$> firmActCCUPostalPref
]
in unless (null changes) $ do
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 Success $ MsgFirmUserChanges nrChanged
reloadKeepGetParams route -- reload to reflect changes
faHandler _ = addMessageI Error MsgErrorUnknownFormAction
runFirmActionFormPost :: CompanyId -> Route UniWorX -> Bool -> [FirmAction] -> Handler Widget
runFirmActionFormPost cid route isAdmin acts = do
mr <- getMessageRender
((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr isAdmin 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 isAdmin faRes
return [whamlet|
<section>
<h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
_{MsgFirmAction}
<div>
<p>
_{MsgFirmActionInfo}
<P>
^{faForm}
|]
---------------------------
-- Firm specific utilities
-- for filters and counts also see before FirmAllR Handlers
-- | remove supervisors for given users; maybe restricted to those linked to a given companies
deleteSupervisors :: NonEmpty UserId -> [CompanyId] -> DB Int64
deleteSupervisors usrs cids = deleteWhereCount $ (UserSupervisorUser <-. toList usrs) : restrictByCompany
where
restrictByCompany = guardMonoid (notNull cids) [UserSupervisorCompany <-. (Just <$> cids)]
-- reset supervisors given employees of a company to default company supervision, deleting all previous company-related supervisors
resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
resetSupervisors cid employees = do
nr_del <- deleteSupervisors employees [cid]
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
E.distinct $ return $ UserSupervisor
E.<# (spr E.^. UserCompanyUser)
E.<&> usr
E.<&> (spr E.^. UserCompanySupervisorReroute)
E.<&> E.justVal cid
E.<&> E.nothing
)
(\_old new ->
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
, UserSupervisorCompany E.=. E.justVal cid
-- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reason
])
-- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64
addDefaultSupervisorsFor mbSuperId 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 ]
<> maybeEmpty mbSuperId (\sprId -> [E.exists $ do
superv <- E.from $ E.table @UserSupervisor
E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId
E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser
])
<> [ spr E.^. UserCompanySupervisor
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
]
E.distinct $ return $ UserSupervisor
E.<# (spr E.^. UserCompanyUser)
E.<&> (usr E.^. UserCompanyUser)
E.<&> (spr E.^. UserCompanySupervisorReroute)
E.<&> E.just (spr E.^. UserCompanyCompany)
E.<&> E.nothing
)
(\_old new ->
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reaon
] )
-- 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
]
E.distinct $ return $ UserSupervisor
E.<# (spr E.^. UserCompanyUser)
E.<&> (usr E.^. UserCompanyUser)
E.<&> (spr E.^. UserCompanySupervisorReroute)
E.<&> E.just (spr E.^. UserCompanyCompany)
E.<&> E.nothing
)
(\_old new ->
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reaon
] )
------------------------------
-- repeatedly useful queries
usrPrimaryCompanies :: E.SqlExpr (Entity Company) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery ()
-- usrPrimaryCompanies :: E.SqlExpr (E.Value CompanyId) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery (Entity UserCompany) -- possible alternative
usrPrimaryCompanies cmp usr = do
othr <- E.from $ E.table @UserCompany
E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
E.&&. othr E.^. UserCompanyCompany E.!=. cmp E.^. CompanyId -- redundant due to > above, but likely performance improving
-- return othr
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
firmCountUsersPrimary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountUsersPrimary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
where
primFltr = E.notExists . usrPrimaryCompanies cmp
firmCountUsersSecondary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountUsersSecondary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
where
primFltr = E.exists . usrPrimaryCompanies cmp
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
-----------------------
-- All Firms Table
-- 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, E.Value Word64)
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
resultAllCompanyUsersSecondary :: Lens' AllCompanyTableData Word64
resultAllCompanyUsersSecondary = _dbrOutput . _5 . _unValue
mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget)
mkFirmAllTable isAdmin uid = do
now <- liftIO getCurrentTime
mr <- getMessageRender
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 & firmCountUsersSecondary -- 5
-- , cmpy & firmCountEmployeeSupervised
-- , cmpy & firmCountEmployeeRerouted
-- , cmpy & firmCountEmployeeRerPost
-- , cmpy & firmCountForeignSupervisors
-- , cmpy & firmCountActiveReroutes
-- , cmpy & firmCountActiveReroutes'
)
dbtRowKey = (E.^. CompanyId)
dbtProj = dbtProjFilteredPostId
dbtColonnade = formColonnade $ mconcat
[ 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 (FirmSupersR fsh) $ toWgt fsh
, sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> numCell $ companyAvsId firm
, sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr
, sortable (Just "secondary") (i18nCell MsgTableCompanyNrSecondaryUsers) $ \(view resultAllCompanyUsersSecondary -> 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 "secondary" $ SortColumn firmCountUsersSecondary
, 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-associate" , 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)
)
)
-- THIS WAS WAY TOO SLOW:
-- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow
-- (usr :& usrCmp) <- E.from $ E.table @User
-- `E.leftJoin` E.table @UserCompany
-- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser)
-- E.where_ $ ((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)
-- ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId)
-- E.||. E.exists (do
-- usrSpr <- E.from $ E.table @UserSupervisor
-- E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
-- E.&&. E.exists (do
-- usrSub <- E.from $ E.table @UserCompany
-- E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser
-- E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
-- )
-- )
-- )
-- )
-- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow
-- usr <- E.from $ E.table @User
-- E.where_ $ ((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)
-- ) E.&&. (E.exists (do
-- usrCmp <- E.from $ E.table @UserCompany
-- E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
-- E.&&. usrCmp E.^. UserCompanySupervisor
-- E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
-- ) E.||. E.exists (do
-- usrSpr <- E.from $ E.table @UserSupervisor
-- E.where_ $ usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
-- E.&&. E.exists (do
-- usrSub <- E.from $ E.table @UserCompany
-- E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser
-- E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
-- )
-- )
-- )
-- )
-- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow
-- usr <- E.from $ E.table @User
-- E.where_ $ ((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)
-- ) E.&&. E.exists (do
-- usrCmp <- E.from $ E.table @UserCompany
-- E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
-- E.&&. (( usrCmp E.^. UserCompanySupervisor
-- E.&&. usrCmp E.^. UserCompanyUser E.==. usr E.^. UserId
-- ) E.||. E.exists (do
-- usrSpr <- E.from $ E.table @UserSupervisor
-- E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser
-- E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
-- ))
-- )
-- )
-- , single ("is-supervisor", FilterColumn $ \row (getLast -> criterion) ->
-- case criterion of
-- Nothing -> E.true
-- (Just (crit::Text)) -> E.exists $ do
-- usr <- E.from $ E.table @User
-- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val crit)
-- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit))
-- E.||. (usr E.^. UserSurname `E.hasInfix` E.val crit)
-- ) E.&&. E.exists (do
-- usrCmp <- E.from $ E.table @UserCompany
-- E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
-- E.&&. (( usrCmp E.^. UserCompanySupervisor
-- E.&&. usrCmp E.^. UserCompanyUser E.==. usr E.^. UserId
-- ) E.||. E.exists (do
-- usrSpr <- E.from $ E.table @UserSupervisor
-- E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser
-- E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
-- ))
-- )
-- )
, single ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr ->
case criterion of
Nothing -> return True :: DB Bool
(Just (crit::Text)) -> do
critFirms <- memcachedBy (Just . Right $ 3 * diffMinute) ("SVR:"<>crit) $ fmap (Set.fromList . fmap E.unValue) $ E.select $ E.distinct $ do
(usr :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @Company
`E.on` (\(usr :& cmp) -> E.exists (do
usrCmp <- E.from $ E.table @UserCompany
E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
E.&&. usrCmp E.^. UserCompanySupervisor
E.&&. usrCmp E.^. UserCompanyCompany E.==. cmp E.^. CompanyId
) E.||. E.exists (do
usrSpr <- E.from $ E.table @UserSupervisor
E.where_ $ usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
E.&&. E.exists (do
usrSub <- E.from $ E.table @UserCompany
E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser
E.&&. usrSub E.^. UserCompanyCompany E.==. cmp E.^. CompanyId
)
))
E.where_ $ (usr E.^. UserDisplayName `E.hasInfix` E.val crit )
E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit))
E.||. (usr E.^. UserSurname `E.hasInfix` E.val crit )
-- E.orderBy [E.asc $ cmp E.^. CompanyId]
return $ cmp E.^. CompanyId
let cid = dbr ^. resultAllCompanyEntity . _entityKey
return $ Set.member cid critFirms
)
-- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow
-- (usr :& usrCmp) <- E.from $ E.table @User
-- `E.leftJoin` E.table @UserCompany
-- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser)
-- E.where_ $ ((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)
-- ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId)
-- E.||. E.exists (do
-- (usrSpr :& usrSub) <- E.from $ E.table @UserSupervisor `E.innerJoin` E.table @UserCompany `E.on` (\(usrSpr :& usrSub) -> usrSpr E.^. UserSupervisorUser E.==. usrSub E.^. UserCompanyUser)
-- E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
-- E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
-- )
-- )
-- )
, single ("is-default-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_ $ ((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)
) E.&&. usrCmp E.^. UserCompanySupervisor
E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
)
, 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)))
, single ("qualification" , FilterColumn . E.mkExistsFilter $ \row (CI.mk -> criterion :: CI Text) -> do
(usrCmp :& usrQual :& qual) <- E.from $ E.table @UserCompany
`E.innerJoin` E.table @QualificationUser
`E.on` (\(usrCmp :& usrQual) -> usrCmp E.^. UserCompanyUser E.==. usrQual E.^. QualificationUserUser)
`E.innerJoin` E.table @Qualification
`E.on` (\(_ :& usrQual :& qual) -> qual E.^. QualificationId E.==. usrQual E.^. QualificationUserQualification)
E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
E.&&. qual E.^. QualificationShorthand E.==. E.val criterion
E.&&. validQualification now usrQual
)
]
dbtFilterUI mPrev = mconcat
[ fltrCompanyNameUI mPrev
, prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo)
, prismAForm (singletonFilter "is-associate") mPrev $ aopt textField (fslI MsgTableCompanyUser)
-- , prismAForm (singletonFilter "is-supervisor0") mPrev $ aopt textField (fslI MsgTableSupervisor)
, prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
, prismAForm (singletonFilter "is-default-supervisor") mPrev $ aopt textField (fslI MsgFirmSuperDefault)
, 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)
, fltrQualificationHdrUI MsgFilterHasQualification mPrev
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr isAdmin [FirmActNotify, FirmActResetSupervision]
, 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 <- checkAdmin
(firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
firmActionHandler FirmAllR isAdmin firmRes
siteLayoutMsg MsgMenuFirms $ do
setTitleI MsgMenuFirms
$(i18nWidgetFile "firm-all")
-----------------------
-- Firm Users Table
data FirmUserAction = FirmUserActNotify
| FirmUserActResetSupervision
| FirmUserActSetSupervisor
| FirmUserActMkSuper
| FirmUserActChangeContact
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
}
| FirmUserActSetSupervisorData
{ firmUserActSetSuperNames :: Maybe (Set Text)
, firmUserActSetSuperIds :: Maybe [UserId]
, firmUserActSetSuperReroute :: Bool
, firmUserActSetSuperKeep :: Bool
}
| FirmUserActMkSuperData
{ firmUserActMkSuperReroute :: Maybe Bool }
| FirmUserActChangeContactData
{ firmUserActPostalAddr :: Maybe StoredMarkup
, firmUserActPostalPref :: 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) -- , E.Value Bool)
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
-- resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool
-- resultUserCompanyPrimary = _dbrOutput . _5 . _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
mr <- getMessageRender
let
mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr) = do
uuid <- toPathPiece <$> encryptUser uid
return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr)
procOptions rawSupers = do
procSupers <- traverse mkSprOption rawSupers
return $ mkOptionListGrouped $ filter (notNull . snd)
[ (mr MsgFirmSuperDefault , [opt | (opt, Just True ) <- procSupers])
, (mr MsgFirmSuperIrregular, [opt | (opt, Just False) <- procSupers])
, (mr MsgFirmSuperForeign , [opt | (opt, Nothing ) <- procSupers])
]
rawSupers <- E.select $ do
(usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany
`E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid)
E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
E.||. E.exists (firmQuerySupervisedBy cid Nothing usr)
return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor)
let
-- supervisorField :: Field Handler UserId
-- supervisorField = selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers
supervisorsField = multiSelectField' (Just $ SomeMessage MsgMultiNoSelection) $ 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
-- let isPrimary = E.notExists (do
-- other <- E.from $ E.table @UserCompany
-- E.where_ $ other E.^. UserCompanyUser E.==. usrCmp E.^. UserCompanyUser
-- E.&&. other E.^. UserCompanyPriority E.>. usrCmp E.^. UserCompanyPriority
-- )
return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp)
dbtRowKey = queryUserUser >>> (E.^. UserId)
dbtProj = dbtProjId
dbtColonnade = formColonnade $ mconcat
[ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey))
, colUserNameModalHdr MsgTableCompanyUser ForProfileDataR
, guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinkedAdmin 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
, singletonMap "is-primary-company" $ FilterColumn $ \row (getLast -> criterion) ->
let checkPrimary = do
other <- E.from $ E.table @UserCompany
E.where_ $ other E.^. UserCompanyUser E.==. queryUserUserCompany row E.^. UserCompanyUser
E.&&. other E.^. UserCompanyPriority E.>. queryUserUserCompany row E.^. UserCompanyPriority
in case criterion of
Nothing -> E.true
Just False -> E.exists checkPrimary
Just True -> E.notExists checkPrimary
]
-- 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 & setTooltip MsgMultiSelectTip)
, 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)
, prismAForm (singletonFilter "is-primary-company" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmPrimary)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
acts :: Map FirmUserAction (AForm Handler FirmUserActionData)
acts = mconcat
[ guardMonoid isAdmin $ 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 FirmUserActSetSupervisor $ FirmUserActSetSupervisorData
<$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> aopt supervisorsField (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip) Nothing
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False)
, singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
<$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
, singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
]
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 <- checkAdmin
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
(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
(FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ maybeMonoid firmUserActSetSuperNames
let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
usersFound = mapMaybe snd usersFound'
newSupers = Set.toList $ Set.fromList (maybeMonoid firmUserActSetSuperIds) <> Set.fromList usersFound
nrSupers = fromIntegral $ length newSupers
nrUsers = fromIntegral $ length uids
unless (null usersNotFound) $
let msgContent = [whamlet|
$newline never
<ul>
$forall (usr,_) <- usersNotFound
<li>#{usr}
|]
in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
delSupers <- runDB
$ bool (deleteSupervisors uids [cid]) (return 0) firmUserActSetSuperKeep
<* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) Nothing | u <- toList uids, s <- newSupers]
addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
(FirmUserActMkSuperData{..}, Set.toList -> uids) -> do
nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
(FirmUserActChangeContactData{..}, Set.toList -> uids) ->
let changes = catMaybes
[ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address!
, (UserPrefersPostal =.) <$> firmUserActPostalPref
]
in unless (null changes) $ do
nrChanged <- runDB $ updateWhereCount [UserId <-. uids] changes
addMessageI Success $ MsgFirmUserChanges nrChanged
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser]
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
| FirmSuperActSwitchSuper
| FirmSuperActRMSuperDef
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite)
nullaryPathPiece ''FirmSuperAction $ camelToPathPiece' 3
embedRenderMessage ''UniWorX ''FirmSuperAction id
data FirmSuperActionData = FirmSuperActNotifyData
| FirmSuperActSwitchSuperData
{ firmSuperActSwitchSuper :: Maybe Bool
, firmSuperActSwitchReroute :: Maybe Bool
}
| FirmSuperActRMSuperDefData
{ firmSuperActRMSuperActive :: Maybe Bool }
deriving (Eq, Ord, Show, Generic)
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)
, E.Value Bool
)
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
resultSuperCompanySuperior :: Lens' SuperCompanyTableData Bool
resultSuperCompanySuperior = _dbrOutput . _7 . _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
msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo
let
reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
-- 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
, E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.val reasonSuperior)) usr)
)
dbtRowKey = querySuperUser >>> (E.^. UserId)
dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute, isSuperior) -> 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, isSuperior)
dbtColonnade = formColonnade $ mconcat
[ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey))
, colUserNameModalHdr MsgTableSupervisor ForProfileDataR
, guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinkedAdmin 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-super") (i18nCell MsgTableIsDefaultSupervisor) $ \row ->
let mb = row ^. resultSuperCompanyDefaultSuper
sp = row ^. resultSuperCompanySuperior
in case (mb,sp) of
(_ , True) -> iconCell IconSuperior
(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
[ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData
, singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor) (Just $ Just True)
<*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute) Nothing
<* aformMessage msgSupervisorUnchanged
, 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 <- checkAdmin
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
(FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do
let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of
(Just True, Nothing) -> ([UserCompanySupervisor ==. False], [UserCompanySupervisor =. True ])
(Just True, Just rer) -> ([UserCompanySupervisor ==. False] ||. [UserCompanySupervisorReroute !=. rer]
, [UserCompanySupervisor =. True , UserCompanySupervisorReroute =. rer ])
(Just False, _) -> ([UserCompanySupervisor ==. True ], [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False])
(Nothing, Just True) -> ([UserCompanySupervisor ==. True, UserCompanySupervisorReroute ==. False], [UserCompanySupervisorReroute =. True ])
(Nothing, Just False) -> ([ UserCompanySupervisorReroute ==. True ], [UserCompanySupervisorReroute =. False])
(Nothing, Nothing ) -> ([],[])
nrSuperChanges <- runDB $ updateWhereCount (fltrSpr <> [UserCompanyUser <-. uids, UserCompanyCompany ==. cid]) changes
addMessageI Info $ MsgFirmActAddSupersSet nrSuperChanges Nothing
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) isAdmin [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm]
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 <$> runDBRead (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 <$> runDBRead (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
-}
Reference in New Issue View Git Blame Copy Permalink