240 lines
14 KiB
Haskell
240 lines
14 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Utils.Company where
|
|
|
|
|
|
import Import
|
|
|
|
-- import Data.CaseInsensitive (CI)
|
|
-- import qualified Data.CaseInsensitive as CI
|
|
-- import qualified Data.Char as Char
|
|
-- import qualified Data.Text as Text
|
|
import Database.Persist.Postgresql
|
|
|
|
import Database.Esqueleto.Experimental ((:&)(..))
|
|
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import qualified Database.Esqueleto.PostgreSQL as E
|
|
|
|
import Handler.Utils.Users
|
|
import Handler.Utils.Widgets
|
|
|
|
-- Snippet to restrict to primary company only
|
|
-- E.&&. E.notExists (do
|
|
-- othr <- E.from $ E.table @UserCompany
|
|
-- E.where_ $ othr E.^. UserCompanyPriority E.>. userCompany E.^. UserCompanyPriority
|
|
-- E.&&. othr E.^. UserCompanyUser E.==. userCompany E.^. UserCompanyUser
|
|
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
|
|
-- )
|
|
|
|
company2msg :: CompanyId -> SomeMessage UniWorX
|
|
company2msg = text2message . ciOriginal . unCompanyKey
|
|
|
|
wgtCompanies :: UserId -> DB (Maybe Widget)
|
|
wgtCompanies = \uid -> do
|
|
companies <- E.select $ do
|
|
(usrComp :& comp) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @Company
|
|
`E.on` (\(usrComp :& comp) -> usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId)
|
|
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
|
|
E.orderBy [E.asc (comp E.^. CompanyName)]
|
|
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor, usrComp E.^. UserCompanyPriority)
|
|
let (mPri, topCmp, otherCmp) = procCmp mPri companies
|
|
resWgt =
|
|
[whamlet|
|
|
$forall c <- topCmp
|
|
<p>
|
|
^{c}
|
|
$forall c <- otherCmp
|
|
<p>
|
|
^{c}
|
|
|]
|
|
return $ toMaybe (notNull topCmp) resWgt
|
|
where
|
|
procCmp _ [] = (0, [], [])
|
|
procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) =
|
|
let isTop = cmpPrio >= maxPri
|
|
cmpWgt = companyWidget isTop (cmpSh, cmpName, cmpSpr)
|
|
(accPri,accTop,accRem) = procCmp maxPri cs
|
|
in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpWgt : accRem) accRem isTop) -- lazy evaluation after repmin example, don't factor out the bool!
|
|
|
|
type AnySuperReason = Either SupervisorReason (Maybe Text)
|
|
|
|
|
|
addDefaultSupervisors' :: CompanyId -> NonEmpty UserId -> DB Int64
|
|
addDefaultSupervisors' = addDefaultSupervisors $ Just $ tshow SupervisorReasonCompanyDefault
|
|
|
|
-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
|
|
-- if no reason is given, SupervisorReasonCompanyDefault is used, except if reason == Just "NULL"
|
|
addDefaultSupervisors :: Maybe Text -> CompanyId -> NonEmpty UserId -> DB Int64
|
|
addDefaultSupervisors reason 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.<&> case reason of
|
|
Nothing -> E.justVal $ tshow SupervisorReasonCompanyDefault
|
|
Just "NULL" -> E.nothing
|
|
other -> E.val other
|
|
)
|
|
(\old new ->
|
|
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
|
, UserSupervisorCompany E.=. E.justVal cid
|
|
, UserSupervisorReason E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
|
|
])
|
|
|
|
|
|
-- like `Handler.Utils.addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
|
|
-- TODO: check redundancies
|
|
addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Maybe UserId -> Bool -> mono -> DB Int64
|
|
addDefaultSupervisorsFor reason 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.val reason
|
|
)
|
|
(\old new ->
|
|
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
|
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
|
, UserSupervisorReason E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
|
|
] )
|
|
|
|
-- like `addDefaultSupervisors`, but selects all employees of given companies from database
|
|
-- TODO: check redundancies
|
|
addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Bool -> mono -> DB Int64
|
|
addDefaultSupervisorsAll reason 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.val reason
|
|
)
|
|
(\old new ->
|
|
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
|
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
|
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
|
|
] )
|
|
|
|
-- | removes user supervisorship on switch. WARNING: problems are not yet written to DB via reportProblem yet
|
|
switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem])
|
|
switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = do
|
|
usrRec <- get404 uid
|
|
newCompany <- get404 newCompanyId
|
|
mbUsrComp <- getUserPrimaryCompany uid
|
|
mbOldComp <- (get . userCompanyCompany) `traverseJoin` mbUsrComp
|
|
mbUsrAvs <- if usrPostEmailUpds then getBy (UniqueUserAvsUser uid) else return Nothing
|
|
let usrPostAddr :: Maybe StoredMarkup = userPostAddress usrRec
|
|
avsPostAddr :: Maybe StoredMarkup = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just
|
|
usrPostUp = toMaybe (usrPostEmailUpds && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr))
|
|
(UserPostAddress =. Nothing) -- use company address indirectly instead
|
|
usrPrefPost = userPrefersPostal usrRec
|
|
usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal))
|
|
(UserPrefersPostal =. companyPrefersPostal newCompany)
|
|
usrEmail :: UserEmail = userDisplayEmail usrRec
|
|
avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI
|
|
usrEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrEmail) (UserDisplayEmail =. "")
|
|
usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrEmailUp]
|
|
-- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional
|
|
-- update uid usrUpdate
|
|
-- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association
|
|
case mbUsrComp of
|
|
Nothing -> do -- create company user
|
|
void $ insertUnique newUserComp
|
|
void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
|
|
return (usrUpdate, mempty)
|
|
Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute, userCompanyReason=oldAssocReason}
|
|
| newCompanyId == oldCompanyId -> return mempty -- nothing to do
|
|
| otherwise -> do -- switch company
|
|
when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId
|
|
void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp
|
|
[UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
|
|
-- supervised by uid
|
|
supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
|
|
usrSup <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSup E.^. UserSupervisorSupervisor E.==. E.val uid
|
|
E.&&. usrSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId
|
|
E.&&. usrSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef
|
|
let singleSup = E.notExists $ do
|
|
othSup <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSup E.^. UserSupervisorUser E.==. othSup E.^. UserSupervisorUser
|
|
E.&&. othSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId
|
|
E.&&. othSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef
|
|
return (usrSup, singleSup)
|
|
newlyUnsupervised <- guardMonoidM (notNull supervisees) $ do
|
|
E.delete $ do
|
|
usrSup <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ usrSup E.^. UserSupervisorId `E.in_` E.vals (fmap (entityKey . fst) supervisees)
|
|
return $ [ AdminProblemSupervisorLeftCompany subid oldCompanyId oldSuperReroute
|
|
| (Entity{entityVal=UserSupervisor{userSupervisorUser=subid}}, E.Value True) <- supervisees ]
|
|
-- supervisors of uid
|
|
let superDeftFltr = (UserSupervisorUser ==. uid) : (UserSupervisorReason ~=. superReasonComDef)
|
|
oldSubFltr = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr
|
|
oldAPs <- if keepOldCompanySupervs
|
|
then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing]
|
|
else deleteWhereCount oldSubFltr
|
|
void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
|
|
newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr
|
|
let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0
|
|
problems = bcons oldSuper (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute)
|
|
$ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
|
|
newlyUnsupervised
|
|
return (usrUpdate ,problems)
|
|
where
|
|
newUserComp = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
|
|
superReasonComDef = tshow SupervisorReasonCompanyDefault
|
|
|
|
defaultSupervisorReasonFilter :: [Filter UserSupervisor]
|
|
defaultSupervisorReasonFilter =
|
|
[UserSupervisorReason ==. Nothing]
|
|
||. [UserSupervisorReason ==. Just (tshow SupervisorReasonCompanyDefault)]
|
|
-- ||. [UserSupervisorReason <-. [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]]
|
|
|
|
-- | remove supervisors for given users; maybe restricted to those linked to given companies or supervisors
|
|
deleteDefaultSupervisorsForUsers :: [CompanyId] -> [UserId] -> NonEmpty UserId -> DB Int64
|
|
deleteDefaultSupervisorsForUsers cids sprs usrs =
|
|
deleteWhereCount
|
|
$ bcons (notNull cids) (UserSupervisorCompany <-. (cids <&> Just))
|
|
$ bcons (notNull sprs) (UserSupervisorSupervisor <-. sprs)
|
|
$ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter
|
|
|
|
-- | deletes user company association and all company related supervision
|
|
-- WARNING: does not check for admin problems!
|
|
deleteCompanyUser :: CompanyId -> [UserId] -> DB (Int64, Int64, Int64)
|
|
deleteCompanyUser cid uids = (,,)
|
|
<$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids]
|
|
<*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorSupervisor <-. uids) : defaultSupervisorReasonFilter)
|
|
<*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorUser <-. uids) : defaultSupervisorReasonFilter)
|