141 lines
8.1 KiB
Haskell
141 lines
8.1 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
|
|
|
|
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 cmpWgt = companyWidget (cmpSh, cmpName, cmpSpr)
|
|
isTop = cmpPrio >= maxPri
|
|
(accPri,accTop,accRem) = procCmp maxPri cs
|
|
in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpName : accRem) accRem isTop) -- lazy evaluation after repmin example
|
|
|
|
-- TODO: use this function in company view Handler.Firm #157
|
|
-- | add all company supervisors for a given users
|
|
addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend)
|
|
=> Key Company -> Key User -> ReaderT backend m ()
|
|
addCompanySupervisors cid uid =
|
|
E.insertSelectWithConflict
|
|
UniqueUserSupervisor
|
|
( do
|
|
userCompany <- E.from $ E.table @UserCompany
|
|
E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val cid
|
|
E.&&. userCompany E.^. UserCompanySupervisor
|
|
return $ UserSupervisor
|
|
E.<# (userCompany E.^. UserCompanyUser)
|
|
E.<&> E.val uid
|
|
E.<&> (userCompany E.^. UserCompanySupervisorReroute)
|
|
E.<&> E.justVal cid
|
|
E.<&> E.justVal (tshow SupervisorReasonCompanyDefault)
|
|
)
|
|
(\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists
|
|
[ UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] -- do we want this? Ok, since we delete unconditionally first?!
|
|
, UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ]
|
|
]
|
|
)
|
|
|
|
|
|
-- | 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 usrPostAddrUpd keepOldCompanySupervs uid newCompanyId = do
|
|
usrRec <- get404 uid
|
|
newCompany <- get404 newCompanyId
|
|
mbUsrComp <- getUserPrimaryCompany uid
|
|
mbOldComp <- (get . userCompanyCompany) `traverseJoin` mbUsrComp
|
|
mbUsrAvs <- if usrPostAddrUpd 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 (usrPostAddrUpd && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr))
|
|
(UserPostAddress =. Nothing) -- use company address indirectyl instead
|
|
usrPrefPost = userPrefersPostal usrRec
|
|
usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal))
|
|
(UserPrefersPostal =. companyPrefersPostal newCompany)
|
|
usrUpdate = catMaybes [usrPostUp, usrPrefPostUp]
|
|
-- [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
|
|
addCompanySupervisors newCompanyId uid
|
|
return (usrUpdate, mempty)
|
|
Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute}
|
|
| newCompanyId == oldCompanyId -> return mempty -- nothing to do
|
|
| otherwise -> do -- switch company
|
|
void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp
|
|
[UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True]
|
|
-- 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
|
|
addCompanySupervisors newCompanyId 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 -- default value for new company insertion, if no update can be done
|
|
superReasonComDef = tshow SupervisorReasonCompanyDefault |