289 lines
17 KiB
Haskell
289 lines
17 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-2025 Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE BlockArguments #-} -- do starts is own block
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
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
|
|
|
|
-- KeyCompany is CompanyShorthand, i.e. CI Text
|
|
instance E.SqlString (Key Company)
|
|
|
|
-- 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
|
|
|
|
-- for convenience in debugging
|
|
instance ToText (Maybe CompanyId) where
|
|
toText Nothing = toText ("-None-"::Text)
|
|
toText (Just fsh) = toText $ unCompanyKey fsh
|
|
|
|
wgtCompanies :: Bool -> UserId -> DB (Maybe Widget)
|
|
wgtCompanies useShort = (wrapUL . fst <<$>>) . wgtCompanies' useShort
|
|
where
|
|
wrapUL wgt = [whamlet|<ul .list--iconless>^{wgt}|]
|
|
|
|
-- | Given a UserId, create widget showing top-companies (with internal link) and associated companies (unlinked)
|
|
-- NOTE: The widget must be wrapped with <ul>
|
|
wgtCompanies' :: Bool -> UserId -> DB (Maybe (Widget, [(CompanyShorthand,CompanyName,Bool,Int)]))
|
|
wgtCompanies' useShort uid = do
|
|
companies <- $(E.unValueN 4) <<$>> 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
|
|
<li>
|
|
^{c}
|
|
$forall c <- otherCmp
|
|
<li>
|
|
^{c}
|
|
|]
|
|
return $ toMaybe (notNull companies) (resWgt, companies)
|
|
where
|
|
procCmp _ [] = (0, [], [])
|
|
procCmp maxPri ((cmpSh, cmpName, cmpSpr, cmpPrio) : cs) =
|
|
let isTop = cmpPrio >= maxPri
|
|
cmpWgt = companyWidget' useShort isTop (cmpSh, cmpName, cmpSpr)
|
|
(accPri,accTop,accRem) = procCmp maxPri cs
|
|
in ( max cmpPrio accPri
|
|
, bool accTop (cmpWgt : accTop) isTop -- lazy evaluation after repmin example, don't factor out the bool!
|
|
, bool (cmpWgt : accRem) accRem isTop
|
|
)
|
|
|
|
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 only returned, but not yet written to DB via reportProblem
|
|
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)
|
|
usrPinPassUp = toMaybe (newCompany ^. _companyPinPassword . _not) (UserPinPassword =. Nothing)
|
|
-- newCmpEmail :: UserEmail = fromMaybe "" $ companyEmail newCompany
|
|
usrDisplayEmail :: UserEmail = userDisplayEmail usrRec
|
|
avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI
|
|
usrDisplayEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrDisplayEmail) (UserDisplayEmail =. "") -- delete DisplayEmail, if equal to AVS Firm Email
|
|
usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrPinPassUp, usrDisplayEmailUp]
|
|
newUserComp = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
|
|
superReasonComDef = tshow SupervisorReasonCompanyDefault
|
|
|
|
-- 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
|
|
newAPs <- addDefaultSupervisors' newCompanyId $ singleton uid
|
|
$logInfoS "Supervision" [st|switchAvsUserCompany for #{tshow uid} to #{unCompanyKey newCompanyId}. #{newAPs} default company supervisors upserted.|]
|
|
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
|
|
let newPrio = succ oldPrio
|
|
void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp{userCompanyPriority = newPrio}
|
|
[UserCompanyPriority =. newPrio, 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) -- default or no reason
|
|
oldSubFltr = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr -- old company or no company
|
|
oldAPs <- if keepOldCompanySupervs
|
|
then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing]
|
|
else deleteWhereCount oldSubFltr
|
|
nrDefSups <- addDefaultSupervisors' newCompanyId $ singleton uid -- CHECK HERE WITH LINES ABOVE
|
|
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
|
|
delupd = bool "deleted" "updated" keepOldCompanySupervs :: Text
|
|
$logInfoS "Supervision" [st|switchAvsUserCompany for #{tshow uid} from #{unCompanyKey oldCompanyId} to #{unCompanyKey newCompanyId}. #{oldAPs} old APs #{delupd}. #{nrDefSups} default company supervisors upserted. #{newAPs} new company supervisors counted now.|]
|
|
return (usrUpdate ,problems)
|
|
|
|
defaultSupervisorReasonFilter :: [Filter UserSupervisor]
|
|
defaultSupervisorReasonFilter =
|
|
[UserSupervisorReason ==. Nothing]
|
|
||. [UserSupervisorReason ==. Just (tshow SupervisorReasonCompanyDefault)]
|
|
||. [UserSupervisorReason ==. Just (tshow SupervisorReasonAvsSuperior )]
|
|
-- ||. [UserSupervisorReason <-. Nothing : [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]] -- Does <-. work with Nothing?
|
|
|
|
-- | 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
|
|
|
|
-- | retrieve maximum company user priority for a user
|
|
|
|
getCompanyUserMaxPrio :: UserId -> DB Int
|
|
getCompanyUserMaxPrio uid = do
|
|
mbMaxPrio <- E.selectOne $ do
|
|
usrCmp <- E.from $ E.table @UserCompany
|
|
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val uid
|
|
return . E.max_ $ usrCmp E.^. UserCompanyPriority
|
|
return $ maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
|
|
|
|
-- | retrieve maximum company user priority for a user within SQL query
|
|
-- Note: if there a multiple top-companies, only one is returned
|
|
selectCompanyUserPrime :: E.SqlExpr (Entity User) -> E.SqlExpr (E.Value (Maybe CompanyId))
|
|
selectCompanyUserPrime usr = E.subSelect $ selectCompanyUserPrimeHelper $ usr E.^. UserId
|
|
|
|
-- | like @selectCompanyUserPrime@, but directly usable, a simpler type to think about it `UserId -> DB (Maybe CompanyId)`
|
|
selectCompanyUserPrime' :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend)
|
|
=> UserId -> ReaderT backend m (Maybe CompanyId)
|
|
selectCompanyUserPrime' uid = fmap E.unValue <<$>> E.selectOne $ selectCompanyUserPrimeHelper $ E.val uid
|
|
|
|
-- selectCompanyUserPrime'' :: UserId -> DB (Maybe CompanyId)
|
|
-- selectCompanyUserPrime'' uid = (userCompanyCompany . entityVal) <<$>> selectMaybe [UserCompanyUser ==. uid] [Desc UserCompanyPriority, Asc UserCompanyCompany]
|
|
|
|
selectCompanyUserPrimeHelper :: E.SqlExpr (E.Value UserId) -> E.SqlQuery (E.SqlExpr (E.Value CompanyId))
|
|
selectCompanyUserPrimeHelper uid = do
|
|
uc <- E.from $ E.table @UserCompany
|
|
E.where_ $ uc E.^. UserCompanyUser E.==. uid
|
|
E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
|
|
return (uc E.^. UserCompanyCompany) |