1003 lines
60 KiB
Haskell
1003 lines
60 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE TypeApplications, ExistentialQuantification #-}
|
|
|
|
-- Module for functions directly related to the AVS interface,
|
|
-- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification
|
|
-- NOTE: Several ifdef DEVELOPMENT used, so UNSET DEVELOPMENT and build before comitting.
|
|
|
|
module Handler.Utils.Avs
|
|
( guessAvsUser
|
|
, upsertAvsUserByCard
|
|
, upsertAvsUserById
|
|
, updateAvsUserByIds
|
|
, linktoAvsUserByUIDs
|
|
, queueAvsUpdateByUID, queueAvsUpdateByAID
|
|
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
|
|
, AvsLicenceDifferences(..)
|
|
, setLicence, setLicenceAvs, setLicencesAvs
|
|
, retrieveDifferingLicences, retrieveDifferingLicencesStatus
|
|
, computeDifferingLicences
|
|
-- , synchAvsLicences
|
|
, queryAvsFullStatus
|
|
-- , lookupAvsUser, lookupAvsUsers
|
|
, AvsException(..)
|
|
, updateReceivers
|
|
, AvsPersonIdMapPersonCard
|
|
-- CR3
|
|
, SomeAvsQuery(..)
|
|
, queryAvsCardNo, queryAvsCardNos
|
|
) where
|
|
|
|
import Import
|
|
|
|
-- import Handler.Utils
|
|
-- import qualified Database.Esqueleto.Legacy as E
|
|
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Text as Text
|
|
-- import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Control.Monad.Catch as Catch
|
|
|
|
-- import Auth.LDAP (ldapUserPrincipalName)
|
|
import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
|
|
|
|
import Jobs.Queue
|
|
|
|
import Utils.Avs
|
|
import Utils.Users
|
|
import Handler.Utils.Users
|
|
import Handler.Utils.Company
|
|
import Handler.Utils.Qualification
|
|
import Handler.Utils.Memcached
|
|
import Handler.Utils.AvsUpdate
|
|
|
|
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 Servant.Client.Core.ClientError (ClientError)
|
|
|
|
|
|
--------------------
|
|
-- AVS Exceptions --
|
|
--------------------
|
|
|
|
data AvsException
|
|
= AvsInterfaceUnavailable -- Interface to AVS was not configured at startup or does not respond
|
|
| AvsUserUnassociated Text -- Manipulating AVS Data for a user that is not linked to AVS yet
|
|
| AvsUserUnknownByAvs AvsPersonId -- AvsPersonId not (or no longer) found in AVS
|
|
| AvsUserAmbiguous AvsPersonId -- Multiple matching existing users found for a query in AVS or DB
|
|
| AvsStatusSearchEmpty -- AvsStatusSearch returned empty result
|
|
| AvsPersonSearchEmpty -- AvsPersonSearch returned empty result
|
|
| AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result
|
|
| AvsSetLicencesFailed Text -- AvsSetLicence total failure
|
|
| AvsIdMismatch AvsPersonId AvsPersonId -- First AVS Id was requested, but second one was returned for that query
|
|
| AvsUserCreationFailed AvsPersonId
|
|
deriving (Show, Eq, Ord, Generic)
|
|
instance Exception AvsException
|
|
embedRenderMessage ''UniWorX ''AvsException id -- display as feedback for user initiated actions -- moved to Foundation.I18n
|
|
|
|
{-
|
|
Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException?
|
|
-}
|
|
|
|
-- | Catch AVS exceptions and display them as messages
|
|
catchAVS2message :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
|
|
-- catchAVS2message :: Handler (Maybe a) -> Handler (Maybe a)
|
|
catchAVS2message = catchAVShandler False False True Nothing
|
|
|
|
-- | Catch AVS exceptions and ignore them, but display them as messages
|
|
catchAVS2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
|
|
catchAVS2log = catchAVShandler False True False Nothing
|
|
|
|
catchAll2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m a -> m ()
|
|
catchAll2log = voidMaybe $ catchAVShandler True True False Nothing
|
|
|
|
-- catchAll2log' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException, Monoid a) => m a -> m ()
|
|
-- catchAll2log' = voidMaybe $ catchAVShandler True True False mempty
|
|
|
|
catchAVShandler :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => Bool -> Bool -> Bool -> a -> m a -> m a
|
|
catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHandlers)
|
|
where
|
|
avsHandlers =
|
|
[ Catch.Handler (\(exc::AvsException) -> liftHandler $ do
|
|
let txt = "AVS exception ignored: " <> tshow exc
|
|
when toLog $ $logErrorS "AVS" txt
|
|
when toMsg $ addMessageI Warning exc
|
|
return dft
|
|
)
|
|
|
|
, Catch.Handler (\(exc::ClientError ) -> liftHandler $ do
|
|
let txt = "AVS fatal communicaton failure: " <> tshow exc
|
|
when toLog $ $logErrorS "AVS" txt
|
|
when toMsg $ addMessage Warning $ toHtml txt
|
|
return dft
|
|
)
|
|
]
|
|
allHandlers = guardMonoid allEx
|
|
[ Catch.Handler (\(exc::SomeException) -> liftHandler $ do
|
|
let txt = "AVS fatal unknown failure: " <> tshow exc
|
|
when toLog $ $logErrorS "AVS" txt
|
|
when toMsg $ addMessage Error $ toHtml txt
|
|
return dft
|
|
)
|
|
]
|
|
|
|
|
|
|
|
------------------
|
|
-- AVS Handlers --
|
|
------------------
|
|
|
|
-- convenience wrapper for easy replacement with true status query
|
|
queryAvsFullStatus :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => AvsPersonId -> m AvsResponseStatus
|
|
queryAvsFullStatus api =
|
|
lookupAvsUser api <&> \case
|
|
Just AvsDataPerson{avsPersonPersonCards=cards}
|
|
| notNull cards -> AvsResponseStatus $ Set.singleton $ AvsStatusPerson api cards
|
|
_otherwise -> AvsResponseStatus mempty
|
|
|
|
-- TODO: delete deprecated Utility Functions from Utils.Avs as well -- still needed, since avsStatusQuery does not deliver company names tied to cards
|
|
lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
|
AvsPersonId -> m (Maybe AvsDataPerson)
|
|
lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
|
|
|
|
-- | retrieves complete avs user records for given AvsPersonIds.
|
|
-- Note that this requires several AVS-API queries, since
|
|
-- - avsQueryPerson does not support querying an AvsPersonId directly
|
|
-- - avsQueryStatus only provides limited information
|
|
-- avsQuery is used to obtain all card numbers, which are then queried separately an merged
|
|
-- May throw Servant.ClientError or AvsExceptions
|
|
-- Does not write to our own DB!
|
|
lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
|
Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
|
|
lookupAvsUsers apis = do
|
|
AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis
|
|
let forFoldlM = $(permuteFun [3,2,1]) foldlM
|
|
forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
|
|
forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do
|
|
AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
|
|
return $ mergeByPersonId adps acc2
|
|
|
|
|
|
-- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date
|
|
updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool)
|
|
updateReceivers uid = do
|
|
-- First perform AVS update for receiver
|
|
runDBRead (getBy (UniqueUserAvsUser uid)) >>= \case
|
|
Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> catchAll2log $ upsertAvsUserById apid
|
|
Nothing -> return ()
|
|
-- Retrieve updated user and supervisors now
|
|
(underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDBRead $ (,)
|
|
<$> getJustEntity uid
|
|
<*> (E.select $ do
|
|
(usrSuper :& usrAvs) <-
|
|
E.from $ E.table @UserSupervisor
|
|
`E.leftJoin` E.table @UserAvs
|
|
`E.on` (\(usrSuper :& userAvs) -> usrSuper E.^. UserSupervisorSupervisor E.=?. userAvs E.?. UserAvsUser)
|
|
E.where_ $ (usrSuper E.^. UserSupervisorUser E.==. E.val uid)
|
|
E.&&. (usrSuper E.^. UserSupervisorRerouteNotifications)
|
|
pure (usrSuper E.^. UserSupervisorSupervisor, usrAvs E.?. UserAvsPersonId)
|
|
)
|
|
let (superVs, avsIds) = unzip avsSupers
|
|
receiverIDs :: [UserId] = E.unValue <$> superVs
|
|
toUpdate = Set.fromList $ mapMaybe E.unValue avsIds
|
|
directResult = return (underling, pure underling, True) -- already contains updated address
|
|
forM_ toUpdate (catchAll2log . upsertAvsUserById) -- attempt to update postaddress from AVS
|
|
if null receiverIDs
|
|
then directResult
|
|
else do
|
|
receivers <- runDBRead $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
|
|
if null receivers
|
|
then directResult
|
|
else return (underling, receivers, uid `elem` (entityKey <$> receivers))
|
|
|
|
|
|
------------------
|
|
-- CR3 Functions
|
|
|
|
|
|
-- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API
|
|
class SomeAvsQuery q where
|
|
type SomeAvsResponse q :: Type
|
|
pickQuery :: (MonadIO m) => AvsQuery -> q -> m (Either ClientError (SomeAvsResponse q))
|
|
-- | send query to AVS or maybe look it up within cache, depending on the type of the query
|
|
avsQuery :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
|
|
avsQuery = avsQueryNoCache
|
|
-- | send query to AVS directly, never cached
|
|
avsQueryNoCache :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
|
|
avsQueryNoCache = avsQueryNoCacheDefault
|
|
|
|
avsQueryNoCacheDefault :: (SomeAvsQuery q
|
|
, MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
|
|
avsQueryNoCacheDefault qry = do
|
|
qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery)
|
|
throwLeftM $ qfun qry
|
|
|
|
avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q), NFData (SomeAvsResponse q)
|
|
, MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
|
|
avsQueryCached qry =
|
|
getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case
|
|
Just t | t > 1 -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry
|
|
_ -> avsQueryNoCache qry
|
|
|
|
instance SomeAvsQuery AvsQueryPerson where
|
|
type SomeAvsResponse AvsQueryPerson = AvsResponsePerson
|
|
pickQuery = avsQueryPerson
|
|
avsQuery = avsQueryCached
|
|
|
|
instance SomeAvsQuery AvsQueryStatus where
|
|
type SomeAvsResponse AvsQueryStatus = AvsResponseStatus
|
|
pickQuery = avsQueryStatus
|
|
avsQuery = avsQueryCached
|
|
|
|
instance SomeAvsQuery AvsQueryContact where
|
|
type SomeAvsResponse AvsQueryContact = AvsResponseContact
|
|
pickQuery = avsQueryContact
|
|
avsQuery = avsQueryCached
|
|
|
|
instance SomeAvsQuery AvsQuerySetLicences where
|
|
type SomeAvsResponse AvsQuerySetLicences = AvsResponseSetLicences
|
|
pickQuery = avsQuerySetLicences
|
|
-- NOTE: avsQuery = avsQueryCached -- should not and indeed does not compile
|
|
avsQueryNoCache qry = avsQueryNoCacheDefault qry
|
|
<* memcachedInvalidate (Proxy @AvsResponseContact) -- invalidate all AvsResponseContact which may contain RampLicence info, since keys may comprise several ids
|
|
|
|
instance SomeAvsQuery AvsQueryGetAllLicences where
|
|
type SomeAvsResponse AvsQueryGetAllLicences = AvsResponseGetLicences
|
|
pickQuery = const . avsQueryGetAllLicences
|
|
|
|
|
|
|
|
queryAvsCardNos :: Foldable t => t (Either AvsCardNo AvsFullCardNo) -> Handler (Set AvsPersonId)
|
|
queryAvsCardNos = foldMapM queryAvsCardNo
|
|
|
|
queryAvsCardNo :: Either AvsCardNo AvsFullCardNo -> Handler (Set AvsPersonId)
|
|
queryAvsCardNo crd = do
|
|
AvsResponsePerson adps <- avsQuery $ qry crd
|
|
return $ Set.map avsPersonPersonID adps
|
|
where
|
|
qry (Left acno) = def{ avsPersonQueryCardNo = Just acno }
|
|
qry (Right AvsFullCardNo{..}) = def{ avsPersonQueryCardNo = Just avsFullCardNo
|
|
, avsPersonQueryVersionNo = Just avsFullCardVersion
|
|
}
|
|
|
|
-- | Queries AVS Status to retrieve primary card (heursitic)
|
|
queryAvsPrimaryCard :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsDataPersonCard)
|
|
queryAvsPrimaryCard api = runMaybeT $ do
|
|
AvsResponseStatus res <- MaybeT . catchAVS2log . fmap Just . avsQuery . AvsQueryStatus $ Set.singleton api
|
|
pstatus <- hoistMaybe $ Set.lookupMax $ Set.filter ((api ==) . avsStatusPersonID) res
|
|
hoistMaybe $ Set.lookupMax $ avsStatusPersonCardStatus pstatus
|
|
|
|
-- | Queries AVS to retrieve CardNo from primary card (heursitic)
|
|
queryAvsFullCardNo :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsFullCardNo)
|
|
queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard
|
|
|
|
|
|
|
|
|
|
-- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks
|
|
updateAvsUserById :: AvsPersonId -> DB (Maybe UserId)
|
|
updateAvsUserById apid = do
|
|
AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId apid
|
|
let res = Set.filter ((== apid) . avsContactPersonID) adcs
|
|
snd <<$>> traverseJoin updateAvsUserByADC (Set.lookupMax res)
|
|
|
|
-- | Variant of `updateAvsUserByIds'` that catches and logs all exceptions
|
|
updateAvsUserByIds :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId))
|
|
updateAvsUserByIds = catchAVShandler True True False mempty . updateAvsUserByIds'
|
|
|
|
-- | Update given AvsPersonIds by querying AVS for each; update only, no insertion! Uses batch mechanism and should not throw. Each user dealt within own runDB, i.e. own DB transaction
|
|
updateAvsUserByIds' :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId))
|
|
updateAvsUserByIds' apids = do
|
|
-- apids <- Set.fromList <$> E.filterExists UserAvsPersonId apids0 --not needed anymore, we expect the set to be linked
|
|
AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids -- automatically batched
|
|
let requestedAnswers = Set.filter (view (_avsContactPersonID . to (`Set.member` apids))) adcs -- should not occur, neither should one apid occur multiple times within the response (if so, all responses processed here in random order)
|
|
(oks,bad) <- foldlM procResp mempty requestedAnswers
|
|
let missing = Set.toList $ Set.difference (Set.difference apids $ Set.map fst oks) bad
|
|
unless (null missing) $ do
|
|
now <- liftIO getCurrentTime
|
|
runDB $ updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Avs contact info unknown for AvsPersonId"] -- all others were already marked as updated
|
|
return oks
|
|
where
|
|
procResp :: (Set (AvsPersonId, UserId), Set AvsPersonId) -> AvsDataContact -> Handler (Set (AvsPersonId, UserId), Set AvsPersonId)
|
|
procResp (accOk, accBad) adc = do
|
|
let errHandler e = runDB $ do
|
|
let apid = avsContactPersonID adc
|
|
now <- liftIO getCurrentTime
|
|
updateBy (UniqueUserAvsId apid) [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just (tshow e)]
|
|
return (accOk, Set.insert apid accBad)
|
|
updateAvsUserByADC' :: DB (Set (AvsPersonId, UserId), Set AvsPersonId)
|
|
updateAvsUserByADC' = do
|
|
res <- updateAvsUserByADC adc
|
|
return (maybeInsert res accOk, accBad)
|
|
catchAll (runDB updateAvsUserByADC') errHandler
|
|
|
|
|
|
|
|
updateAvsUserByADC :: AvsDataContact -> DB (Maybe (AvsPersonId, UserId))
|
|
updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do
|
|
(Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid
|
|
let usrId = userAvsUser usravs
|
|
usr <- MaybeT $ get usrId
|
|
lift $ do -- maybeT no longer needed from here onwards
|
|
let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here
|
|
oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here
|
|
oldAvsCardNo = userAvsLastCardNo usravs & fmap Just
|
|
oldAvsDataContact = case (oldAvsPersonInfo, oldAvsFirmInfo) of
|
|
(Just oapi, Just oafi) -> Just $ AvsDataContact apid oapi oafi
|
|
_ -> Nothing
|
|
newAvsCardNo <- queryAvsFullCardNo apid -- Nothing os ok here, does not throw
|
|
now <- liftIO getCurrentTime
|
|
mbLdapExpire <- getsYesod $ views appSettings appSynchroniseLdapUsersExpire
|
|
ldap_ups <- if | Just ldapExpire <- mbLdapExpire
|
|
, maybe True (\lastLdapSync -> now > addUTCTime ldapExpire lastLdapSync) (userLastLdapSynchronisation usr)
|
|
, Just udep <- userCompanyDepartment usr
|
|
, let aipn = newAvsPersonInfo ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
|
|
depKey = CompanyKey $ stripCI udep -- Shorthand is returned by LDAP
|
|
-> do -- LDAP sync invalid/expired
|
|
usrComp <- getBy $ UniqueUserCompany usrId depKey
|
|
whenIsJust usrComp $ \Entity{entityKey=ucKey, entityVal=UserCompany{userCompanySupervisor=isSuper, userCompanySupervisorReroute=rroute}} -> do
|
|
delete ucKey
|
|
when isSuper $ reportAdminProblem $ AdminProblemSupervisorLeftCompany usrId depKey rroute
|
|
return [ UserCompanyDepartment =. Nothing
|
|
, UserCompanyPersonalNumber =. aipn
|
|
, UserLdapPrimaryKey =. aipn
|
|
]
|
|
| otherwise
|
|
-> return $ mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo) $
|
|
bcons (isJust $ newAvsPersonInfo ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo)
|
|
(mkCheckUpdate CU_API_UserLdapPrimaryKey)
|
|
[mkCheckUpdate CU_API_UserCompanyPersonalNumber]
|
|
let per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo . mkCheckUpdate)
|
|
[ CU_API_UserFirstName
|
|
, CU_API_UserSurname
|
|
, CU_API_UserDisplayName
|
|
, CU_API_UserBirthday
|
|
, CU_API_UserMobile
|
|
, CU_API_UserMatrikelnummer
|
|
-- , CU_API_UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above
|
|
]
|
|
eml_up = mkUpdate usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen.
|
|
frm_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ mkCheckUpdate CU_AFI_UserPostAddress -- Legacy, if company postal is stored in user; should no longer be true for new users, since company address should now be referenced with UserCompany instead
|
|
pin_up = mkUpdate' usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card
|
|
CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just
|
|
usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` (ldap_ups <> per_ups)))
|
|
avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
|
|
[ UserAvsLastSynch =. now
|
|
, UserAvsLastSynchError =. Nothing
|
|
, UserAvsLastPersonInfo =. Just newAvsPersonInfo
|
|
, UserAvsLastFirmInfo =. Just newAvsFirmInfo
|
|
, UserAvsLastCardNo =. newAvsCardNo
|
|
]
|
|
|
|
-- update company association & supervision
|
|
Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
|
|
oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
|
|
primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
|
|
let oldCompanyId = entityKey <$> oldCompanyEnt
|
|
-- oldCompanyMb = entityVal <$> oldCompanyEnt
|
|
-- pst_up = if
|
|
-- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines
|
|
-- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
|
-- | isNothing oldCompanyMb
|
|
-- -> mkUpdateDirect usr newCompany $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
|
-- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
|
|
-- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
|
|
-- | otherwise
|
|
-- -> Nothing
|
|
superReasonComDef = tshow SupervisorReasonCompanyDefault
|
|
newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
|
|
|
|
usr_up2 <- case oldAvsFirmInfo of
|
|
_ | Just newCompanyId == oldCompanyId -- company unchanged entirely
|
|
-> return mempty -- => do nothing
|
|
(Just oafi) | isJust (view _avsFirmPostAddressSimple oafi)
|
|
&& ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR
|
|
|| isJust (view _avsFirmPrimaryEmail oafi)
|
|
&& ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged
|
|
-> do -- => just update user company association, keeping supervision privileges
|
|
case oldCompanyId of
|
|
Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
|
|
Just ocid -> do
|
|
void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings
|
|
void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions
|
|
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of
|
|
, UserSupervisorReason ==. Just superReasonComDef] -- user
|
|
[ UserSupervisorCompany =. Just newCompanyId]
|
|
return mempty
|
|
_ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company
|
|
-> do
|
|
whenIsJust oldCompanyId $ \oldCid -> do
|
|
deleteBy $ UniqueUserCompany usrId oldCid
|
|
deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
|
|
return mempty
|
|
_ -- company changed completely
|
|
-> do
|
|
(pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
|
|
mapM_ reportAdminProblem problems
|
|
-- Following line does not type, hence additional parameter needed
|
|
-- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
|
|
return pst_up
|
|
-- SPECIALISED CODE, PROBABLY DEPRECATED
|
|
-- switch user company, keeping old priority
|
|
-- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
|
|
-- Nothing ->
|
|
-- void $ insertUnique newUserComp
|
|
-- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
|
|
-- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
|
|
-- delete ucidOld
|
|
-- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
|
|
-- -- adjust supervison
|
|
-- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
|
|
-- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
|
|
-- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
|
|
-- addDefaultSupervisors' newCompanyId $ singleton usrId
|
|
-- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
|
|
-- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
|
|
-- return pst_up
|
|
update usrId $ usr_up2 <> usr_up1 -- update user eventually
|
|
update uaId avs_ups -- update stored avsinfo for future updates
|
|
return (apid, usrId)
|
|
|
|
|
|
linktoAvsUserByUIDs :: Set UserId -> Handler ()
|
|
linktoAvsUserByUIDs uids = do
|
|
ips <- runDBRead $ E.select $ do
|
|
usr <- E.from $ E.table @User
|
|
let uid = usr E.^. UserId
|
|
ipn = usr E.^. UserCompanyPersonalNumber
|
|
E.where_ $ E.isJust ipn
|
|
E.&&. uid `E.in_` E.vals uids
|
|
E.&&. E.notExists (do
|
|
usrAvs <- E.from $ E.table @UserAvs
|
|
E.where_ $ uid E.==. usrAvs E.^. UserAvsUser
|
|
)
|
|
return (uid, ipn)
|
|
mapM_ procUsr ips
|
|
where
|
|
procUsr (E.Value uid, E.Value (Just ipn)) = catchAll2log $ linktoAvsUserByUID uid $ mkAvsInternalPersonalNo ipn
|
|
procUsr _ = return ()
|
|
|
|
-- | similar to 'upsertAvsUserByCard', but accounts for the known UserId
|
|
linktoAvsUserByUID :: UserId -> AvsInternalPersonalNo -> Handler ()
|
|
linktoAvsUserByUID uid aipn = do
|
|
AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryInternalPersonalNo = Just aipn}
|
|
case Set.elems adps of
|
|
[] -> throwM AvsPersonSearchEmpty
|
|
(_:_:_) -> throwM AvsPersonSearchAmbiguous
|
|
[AvsDataPerson{avsPersonPersonID=api}] ->
|
|
void $ createAvsUserById (Just uid) api
|
|
|
|
-- createAvsUserById :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) ???
|
|
-- | Create new user from AVS-Id. Will throw an AvsException if this is not possible, e.g. due to Uniqueness Constraints
|
|
createAvsUserById :: Maybe UserId -> AvsPersonId -> Handler UserId
|
|
createAvsUserById muid api = do
|
|
AvsResponseContact contactRes <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api
|
|
case Set.toList contactRes of
|
|
[] -> throwM $ AvsUserUnknownByAvs api
|
|
(_:_:_) -> throwM $ AvsUserAmbiguous api
|
|
[adc@AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}]
|
|
| avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID
|
|
| otherwise -> do
|
|
-- check for matching existing user
|
|
let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
|
|
-- persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
|
|
oldUsr <- runDBRead $ do
|
|
mbUid <- if isJust muid
|
|
then return muid
|
|
else firstJustM $ catMaybes
|
|
[ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
|
|
-- , persMail <&> guessUserByEmail -- this did not work, as unfortunately, superiors are sometimes listed under _avsInfoPersonEMail!
|
|
]
|
|
mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
|
|
return (mbUid, mbUAvs)
|
|
usrCardNo <- queryAvsFullCardNo api
|
|
now <- liftIO getCurrentTime
|
|
let usrAvs uid mbPersonInfo mbFirmInfo mbUsrCardNo = UserAvs
|
|
{ userAvsPersonId = api
|
|
, userAvsUser = uid
|
|
, userAvsNoPerson = fromMaybe (negate $ avsPersonId api) $ readMay $ cpi ^. _avsInfoPersonNo -- negative personId as fallback, but readMay should never fail
|
|
, userAvsLastSynch = now
|
|
, userAvsLastSynchError = Nothing
|
|
, userAvsLastPersonInfo = mbPersonInfo
|
|
, userAvsLastFirmInfo = mbFirmInfo
|
|
, userAvsLastCardNo = mbUsrCardNo
|
|
}
|
|
case oldUsr of
|
|
(Nothing , Just _) -> throwM $ AvsUserUnknownByAvs api -- this case should never occur
|
|
(Just uid, Just Entity{entityVal=UserAvs{userAvsPersonId=api',userAvsUser=uid'}})
|
|
| api /= api' -> throwM $ AvsIdMismatch api api'
|
|
| uid /= uid' -> throwM $ AvsUserAmbiguous api
|
|
| otherwise -> return uid -- nothing to do
|
|
(Just uid, Nothing) -> runDB $ do -- link with matching exisitng user
|
|
insert_ $ usrAvs uid Nothing Nothing Nothing -- all infos must be Nothing for subsequent update to work as intended
|
|
updRes <- updateAvsUserById api -- no loop, since updateAvsUserById does not call createAvsUserById
|
|
case updRes of
|
|
Nothing -> throwM $ AvsUserUnknownByAvs api
|
|
Just uid'
|
|
| uid /= uid' -> throwM $ AvsUserAmbiguous api
|
|
| otherwise -> return uid
|
|
(Nothing, Nothing) -> do -- create fresh user
|
|
Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback
|
|
let pinPass = avsFullCardNo2pin <$> usrCardNo
|
|
newUserData = AddUserData
|
|
{ audTitle = Nothing
|
|
, audFirstName = cpi ^. _avsInfoFirstName & Text.strip
|
|
, audSurname = cpi ^. _avsInfoLastName & Text.strip
|
|
, audDisplayName = cpi ^. _avsInfoDisplayName
|
|
, audDisplayEmail = adc ^. _avsContactPrimaryEmail . to (fromMaybe mempty) . from _CI
|
|
, audEmail = "AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI
|
|
, audIdent = "AVSID:" <> ciShow api
|
|
, audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo
|
|
, audMatriculation = cpi ^. _avsInfoPersonNo & Just
|
|
, audSex = Nothing
|
|
, audBirthday = cpi ^. _avsInfoDateOfBirth
|
|
, audMobile = cpi ^. _avsInfoPersonMobilePhoneNo
|
|
, audTelephone = Nothing
|
|
, audFPersonalNumber = internalPersNo
|
|
, audFDepartment = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI)
|
|
, audPostAddress = Nothing -- always use company address indirectly
|
|
, audPrefersPostal = cmp ^. _companyPrefersPostal
|
|
, audPinPassword = pinPass
|
|
}
|
|
runDB $ do -- any failure must rollback all DB write transactions here
|
|
uid <- maybeThrowM (AvsUserCreationFailed api) $ addNewUserDB newUserData
|
|
let userComp = UserCompany uid cid False False 1 True Nothing -- default value for new company insertion, if no update can be done
|
|
void $ insertUnique userComp -- Nothing indicates that the user is already linked to the company (which is unlikely here)
|
|
-- Supervision
|
|
void $ addDefaultSupervisors' cid $ singleton uid
|
|
-- Save AVS data for future updates
|
|
insert_ $ usrAvs uid (Just cpi) (Just firmInfo) usrCardNo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible
|
|
return uid
|
|
|
|
|
|
getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
|
|
getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany
|
|
|
|
-- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked. Highly unlikely that Nothing is returned, since all AvsResponseContact always contains an AvsFirmInfo
|
|
getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company))
|
|
getAvsCompany afi =
|
|
let compName :: CompanyName
|
|
compName = afi ^. _avsFirmFirm . from _CI
|
|
compShorthand :: CompanyShorthand
|
|
compShorthand = afi ^. _avsFirmAbbreviation . from _CI
|
|
compAvsId = afi ^. _avsFirmFirmNo
|
|
in firstJustM $ -- legacy treatment, only use UniqueCompnayAvsId in the future
|
|
guardMonoid (compAvsId > 0)
|
|
[ getBy $ UniqueCompanyAvsId compAvsId
|
|
, getEntity $ CompanyKey $ compShorthand <> "-" <> ciShow compAvsId
|
|
] <>
|
|
[ getByFilter [CompanyName ==. compName]
|
|
, getEntity $ CompanyKey compShorthand
|
|
]
|
|
|
|
-- | insert a company from AVS firm info or update an existing one based on previous values
|
|
upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
|
|
upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
|
|
mbFirmEnt <- getAvsCompany newAvsFirmInfo -- primarily by AvsId, then Shorthand, then name
|
|
$logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|]
|
|
cmpEnt <- case (mbFirmEnt, mbOldAvsFirmInfo) of
|
|
(Nothing, _) -> do -- insert new company, neither AvsId nor Shorthand exist in DB
|
|
afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo
|
|
then return $ newAvsFirmInfo ^. _avsFirmFirmNo
|
|
else maybe (-1) (pred . companyAvsId . entityVal) <$> selectMaybe [CompanyAvsId <. 0] [Asc CompanyAvsId]
|
|
let upd = flip updateRecord newAvsFirmInfo
|
|
dmy = Company -- mostly dummy, values are actually prodcued through firmInfo2company below for consistency
|
|
{ companyName = newAvsFirmInfo ^. _avsFirmFirm . from _CI
|
|
, companyShorthand = newAvsFirmInfo ^. _avsFirmAbbreviation . from _CI
|
|
, companyAvsId = afn
|
|
, companyPrefersPostal = True
|
|
, companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress
|
|
, companyEmail = newAvsFirmInfo ^? _avsFirmPrimaryEmail . _Just . from _CI
|
|
}
|
|
cmp = foldl' upd dmy $ firmInfo2key : firmInfo2companyNo : firmInfo2company
|
|
$logInfoS "AVS" $ "Insert new company: " <> tshow cmp
|
|
newCmp <- insertEntity cmp
|
|
reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
|
|
$logInfoS "AVS" "Insert new company completed."
|
|
return newCmp
|
|
|
|
(Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred
|
|
let cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
|
|
key_ups = mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2key
|
|
uniq_ups <- mkUpdateCheckUnique' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2companyNo
|
|
$logInfoS "AVS" [st|Update company #{companyShorthand firm}: #{tshow (length cmp_ups)}, #{tshow (length key_ups)}, #{tshow (length uniq_ups)} for #{tshow oldAvsFirmInfo}|]
|
|
res_cmp <- updateGetEntity firmid $ mcons uniq_ups cmp_ups
|
|
let cmp_id = res_cmp ^. _entityVal . _companyAvsId
|
|
res_cmp2 <- case key_ups of
|
|
Just key_up | cmp_id > 0 -> do
|
|
$logInfoS "AVS" $ "Updating CompanyShorthand from " <> ciOriginal (companyShorthand firm) <> " to " <> avsFirmAbbreviation newAvsFirmInfo <> " for AvsNo " <> tshow cmp_id
|
|
let uniq_cmp = UniqueCompanyAvsId cmp_id
|
|
cmp_key = newAvsFirmInfo ^. _avsFirmAbbreviation . from _CI
|
|
alt_key = cmp_key <> "-" <> ciShow cmp_id
|
|
key_ok <- notExists [CompanyShorthand ==. cmp_key]
|
|
alt_ok <- notExists [CompanyShorthand ==. alt_key]
|
|
if | key_ok -> updateBy uniq_cmp [key_up] -- this is ok, since we have OnUpdateCascade on all CompanyId entries
|
|
| alt_ok -> updateBy uniq_cmp [CompanyShorthand =. alt_key]
|
|
| otherwise -> $logInfoS "AVS" $ "Update company shorthand failed for " <> ciOriginal cmp_key <> " and " <> ciOriginal alt_key
|
|
maybeM (return res_cmp) return $ getBy uniq_cmp
|
|
_otherwise -> return res_cmp
|
|
$logInfoS "AVS" "Update company completed."
|
|
return res_cmp2
|
|
void $ upsertCompanySuperior (Just $ entityKey cmpEnt, newAvsFirmInfo) mbOldAvsFirmInfo -- ensure firmInfo superior is supervisor
|
|
return cmpEnt
|
|
where
|
|
firmInfo2key =
|
|
CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get
|
|
firmInfo2companyNo =
|
|
CheckUpdate CompanyAvsId _avsFirmFirmNo -- Updating a unique needs special considerations; AVS does not update FirmNo, but for legacy reasons we might have companies without a number
|
|
firmInfo2company =
|
|
[ CheckUpdate CompanyName $ _avsFirmFirm . from _CI
|
|
, CheckUpdate CompanyPostAddress _avsFirmPostAddress
|
|
, CheckUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just
|
|
-- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
|
|
]
|
|
|
|
-- upsert company supervisor from AvsFirmEMailSuperior
|
|
upsertCompanySuperior :: (Maybe CompanyId, AvsFirmInfo) -> Maybe AvsFirmInfo -> DB (Maybe (CompanyId, UserId))
|
|
upsertCompanySuperior (mbCid, newAfi) mbOldAfi = runMaybeT $ do
|
|
supemail <- MaybeT . pure $ newAfi ^. _avsFirmEMailSuperior
|
|
cid <- MaybeT $ altM (pure mbCid) (getAvsCompanyId newAfi)
|
|
supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail)
|
|
(catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
|
|
lift $ do
|
|
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
|
|
oldChanges <- runMaybeT $ do -- remove old superior, if any
|
|
oldAfi <- MaybeT $ pure mbOldAfi
|
|
oldEml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior
|
|
oldCid <- MaybeT $ getAvsCompanyId oldAfi
|
|
oldSup <- MaybeT $ guessUserByEmail $ stripCI oldEml
|
|
let supChange = oldSup /= supid
|
|
when (supChange && oldCid == cid) $ lift $ do
|
|
-- deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company NOTE: we leave this to the oldSuperior's AVS update
|
|
-- switch supervison
|
|
-- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness
|
|
E.update $ \usuper -> do
|
|
E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ]
|
|
E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup
|
|
E.&&. usuper E.^. UserSupervisorCompany E.==. E.justVal cid
|
|
E.&&. usuper E.^. UserSupervisorReason E.==. E.val reasonSuperior
|
|
E.&&. E.notExists (do
|
|
newSuper <- E.from $ E.table @UserSupervisor
|
|
E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid
|
|
E.&&. newSuper E.^. UserSupervisorUser E.==. newSuper E.^. UserSupervisorUser
|
|
)
|
|
deleteWhere [UserSupervisorSupervisor ==. oldSup, UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior] -- remove un-updateable remainders, if any
|
|
return (supChange, oldSup)
|
|
let supChange = fst <$> oldChanges
|
|
oldSup = snd <$> oldChanges
|
|
unless (supChange == Just False) $ do
|
|
-- upsert new superior company supervisor
|
|
mbMaxPrio <- E.selectOne $ do
|
|
usrCmp <- E.from $ E.table @UserCompany
|
|
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid
|
|
return . E.max_ $ usrCmp E.^. UserCompanyPriority
|
|
let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
|
|
suprEnt <- upsertBy (UniqueUserCompany supid cid)
|
|
(UserCompany supid cid True False maxPrio True reasonSuperior)
|
|
[UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio, UserCompanyReason =. reasonSuperior]
|
|
E.insertSelectWithConflict UniqueUserSupervisor
|
|
(do
|
|
usr <- E.from $ E.table @UserCompany
|
|
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
|
|
-- E.&&. E.notExists (do -- restrict to primary company only
|
|
-- 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.!=. E.val cid -- redundant due to > above, but likely performance improving
|
|
-- )
|
|
return $ UserSupervisor
|
|
E.<# E.val supid
|
|
E.<&> (usr E.^. UserCompanyUser)
|
|
E.<&> E.val (suprEnt ^. _entityVal . _userCompanySupervisorReroute)
|
|
E.<&> E.justVal cid
|
|
E.<&> E.val reasonSuperior
|
|
)
|
|
(\old new ->
|
|
[ UserSupervisorCompany E.=. E.coalesce [old E.^. UserSupervisorCompany, new E.^. UserSupervisorCompany]
|
|
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason , new E.^. UserSupervisorReason ]
|
|
]
|
|
)
|
|
reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup
|
|
return (cid,supid)
|
|
|
|
|
|
queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64
|
|
queueAvsUpdateByUID uids = queueAvsUpdateAux (E.table @User) (E.^. UserId) (\usr -> usr E.^. UserId `E.in_` E.vals uids)
|
|
|
|
queueAvsUpdateByAID :: (MonoFoldable mono, AvsPersonId ~ Element mono) => mono -> Maybe Day -> DB Int64
|
|
queueAvsUpdateByAID aids = queueAvsUpdateAux (E.table @UserAvs) (E.^. UserAvsUser) (\usrAvs -> usrAvs E.^. UserAvsPersonId `E.in_` E.vals aids)
|
|
|
|
-- queueAvsUpdateAux :: E.From (E.SqlExpr (Entity ent)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value UserId)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64
|
|
queueAvsUpdateAux :: E.From t -> (t -> E.SqlExpr (E.Value UserId)) -> (t -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64
|
|
queueAvsUpdateAux tbl prj fltr pause = do
|
|
now <- liftIO getCurrentTime
|
|
n <- E.insertSelectWithConflictCount UniqueAvsSyncUser
|
|
( do
|
|
usr <- E.from tbl
|
|
E.where_ $ fltr usr
|
|
return (AvsSync E.<# prj usr E.<&> E.val now E.<&> E.val pause)
|
|
) (\current excluded ->
|
|
[ AvsSyncCreationTime E.=. E.least (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime)
|
|
, AvsSyncPause E.=. E.greatest (current E.^. AvsSyncPause) (excluded E.^. AvsSyncPause)
|
|
]
|
|
)
|
|
runDBJobs' $ queueDBJob JobSynchroniseAvsQueue
|
|
return n
|
|
|
|
|
|
-- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo;
|
|
-- fail-safe, may or may not update existing users, may insert new users
|
|
-- If an existing User with internal number is found, an AVS update query is executed
|
|
guessAvsUser :: Text -> Handler (Maybe UserId)
|
|
guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
|
|
| prefix=="AVSID:" =
|
|
let avsid = AvsPersonId nr in
|
|
runDBRead (getBy $ UniqueUserAvsId avsid) >>= \case
|
|
(Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
|
|
Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid
|
|
| prefix=="AVSNO:" =
|
|
runDBRead (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
|
|
guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
|
|
catchAVS2message $ upsertAvsUserByCard someavsid >>= \case
|
|
Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
|
|
runDBRead (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
|
|
other -> return other
|
|
guessAvsUser someid = do
|
|
try (runDB $ ldapLookupAndUpsert someid) >>= \case
|
|
Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> do -- ensure internal user is linked to avs, if possible
|
|
let ldapUid = Just uid
|
|
avsUid <- catchAVS2message $ upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo
|
|
unless (ldapUid == avsUid) $ addMessageI Warning MsgAvsPersonSearchAmbiguous
|
|
return ldapUid
|
|
Right Entity{entityKey=uid} -> return $ Just uid
|
|
other -> do -- attempt to recover by trying other ids
|
|
whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all
|
|
runDB . runMaybeT $
|
|
MaybeT (guessUserByEmail $ stripCI someid) -- recall that monadic actions are only executed until first success here
|
|
<|> MaybeT (getKeyByFilter [UserDisplayName ==. someid])
|
|
|
|
|
|
-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update.
|
|
-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
|
|
upsertAvsUserByCard :: Either AvsInternalPersonalNo AvsFullCardNo -> Handler (Maybe UserId)
|
|
upsertAvsUserByCard persNo = do
|
|
let qry = case persNo of
|
|
Left fpn
|
|
-> def{ avsPersonQueryInternalPersonalNo = Just fpn } -- recall: default has all fields set to nothing
|
|
Right AvsFullCardNo{..}
|
|
-> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
|
|
-- NOTE: card validity might be outdated, so we must always check diretcly with avs and not within our DB!
|
|
AvsResponsePerson adps <- avsQuery qry
|
|
case Set.elems adps of
|
|
[] -> return Nothing -- throwM AvsPersonSearchEmpty -- since return a Maybe, there is no need to throw here
|
|
(_:_:_) -> throwM AvsPersonSearchAmbiguous
|
|
[AvsDataPerson{avsPersonPersonID=api}] -> Just <$> upsertAvsUserById api -- always triggers an update
|
|
|
|
|
|
-- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. Ignore AVS licence status. Updates company, address, PinPassword
|
|
-- Throws errors if the avsInterface in unavailable or new user would violate uniqueness constraints
|
|
upsertAvsUserById :: AvsPersonId -> Handler UserId
|
|
upsertAvsUserById api = do
|
|
upd <- runDB (updateAvsUserById api)
|
|
case upd of
|
|
Nothing -> createAvsUserById Nothing api -- attempts to link to exisiting user vie UserCompanyPersonalNumber
|
|
(Just uid) -> return uid
|
|
|
|
-- Licences
|
|
setLicence :: (PersistUniqueRead backend, MonadThrow m,
|
|
MonadHandler m, HandlerSite m ~ UniWorX,
|
|
BaseBackend backend ~ SqlBackend) =>
|
|
UserId -> AvsLicence -> ReaderT backend m Bool
|
|
setLicence uid lic =
|
|
getBy (UniqueUserAvsUser uid) >>= \case
|
|
Just Entity{entityVal=UserAvs{userAvsPersonId=api}} -> setLicenceAvs api lic
|
|
Nothing -> do
|
|
uname <- userDisplayName <<$>> get uid
|
|
throwM $ AvsUserUnassociated $ fromMaybe "user id unknown" uname
|
|
|
|
setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
|
|
AvsPersonId -> AvsLicence -> m Bool
|
|
setLicenceAvs apid lic = do
|
|
let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid }
|
|
(1 ==) <$> setLicencesAvs req
|
|
|
|
|
|
--setLicencesAvs :: Set AvsPersonLicence -> Handler Bool
|
|
setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
|
|
Set AvsPersonLicence -> m Int
|
|
setLicencesAvs = aux 0
|
|
where
|
|
aux batch0_ok pls
|
|
| Set.null pls = return batch0_ok
|
|
| otherwise = do
|
|
let (batch1, batch2) = Set.splitAt avsMaxSetLicenceAtOnce pls
|
|
response <- avsQueryNoCache $ AvsQuerySetLicences batch1
|
|
case response of
|
|
AvsResponseSetLicencesError{..} -> do
|
|
let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage
|
|
$logErrorS "AVS" msg
|
|
throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus
|
|
|
|
AvsResponseSetLicences msgs -> do
|
|
let (ok,bad') = Set.partition (sloppyBool . avsResponseSuccess) msgs
|
|
ok_ids = Set.map avsResponsePersonID ok
|
|
bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient
|
|
batch1_ok = Set.size ok
|
|
forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} ->
|
|
$logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg
|
|
aux (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?)
|
|
|
|
{- NOT USED ANYWHERE:
|
|
-- Retrieve all currently valid driving licences and check against our database
|
|
-- Only react to changes as compared to last seen status in avs.model
|
|
synchAvsLicences :: Handler Bool
|
|
synchAvsLicences = do
|
|
allLicences <- avsQueryNoCache AvsQueryGetAllLicences
|
|
deltaLicences <- computeDifferingLicences allLicences
|
|
setResponse <- setLicencesAvs deltaLicences
|
|
let setOk = setResponse == Set.size deltaLicences
|
|
if setOk
|
|
then $logInfoS "AVS" "FRADrive Licences written to AVS successfully."
|
|
else $logWarnS "AVS" "Writing FRADrive Licences to AVS incomplete."
|
|
return setOk
|
|
-}
|
|
|
|
|
|
data AvsLicenceDifferences = AvsLicenceDifferences
|
|
{ avsLicenceDiffRevokeAll :: Set AvsPersonId -- revoke all driving licences in AVS (set 0)
|
|
, avsLicenceDiffGrantVorfeld :: Set AvsPersonId -- grant apron driving licence in AVS (set 1, upgrade from 0)
|
|
, avsLicenceDiffRevokeRollfeld :: Set AvsPersonId -- revoke maneuvering area driving licence, but retain apron driving licence (set 1, downgrade from 2)
|
|
, avsLicenceDiffGrantRollfeld :: Set AvsPersonId -- grant maneuvering area driving licence (set 2)
|
|
}
|
|
deriving (Show)
|
|
|
|
#ifndef DEVELOPMENT
|
|
-- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build
|
|
avsLicenceDifferences2LicenceIds :: AvsLicenceDifferences -> Set AvsPersonId
|
|
avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions
|
|
[ avsLicenceDiffRevokeAll
|
|
, avsLicenceDiffGrantVorfeld
|
|
, avsLicenceDiffRevokeRollfeld
|
|
, avsLicenceDiffGrantRollfeld
|
|
]
|
|
#endif
|
|
|
|
avsLicenceDifferences2personLicences :: AvsLicenceDifferences -> Set AvsPersonLicence
|
|
avsLicenceDifferences2personLicences AvsLicenceDifferences{..} =
|
|
Set.map (AvsPersonLicence AvsNoLicence) avsLicenceDiffRevokeAll
|
|
<> Set.map (AvsPersonLicence AvsLicenceVorfeld) avsLicenceDiffGrantVorfeld
|
|
<> Set.map (AvsPersonLicence AvsLicenceVorfeld) avsLicenceDiffRevokeRollfeld
|
|
<> Set.map (AvsPersonLicence AvsLicenceRollfeld) avsLicenceDiffGrantRollfeld
|
|
|
|
computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence)
|
|
computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDifferingLicences
|
|
|
|
type AvsPersonIdMapPersonCard = Map AvsPersonId (Set AvsDataPersonCard)
|
|
|
|
avsResponseStatusMap :: AvsResponseStatus -> AvsPersonIdMapPersonCard
|
|
avsResponseStatusMap (AvsResponseStatus status) = Map.fromDistinctAscList [(avsStatusPersonID,avsStatusPersonCardStatus) | AvsStatusPerson{..}<- Set.toAscList status]
|
|
|
|
retrieveDifferingLicences :: Handler AvsLicenceDifferences
|
|
retrieveDifferingLicences = fst <$> retrieveDifferingLicences' False
|
|
|
|
retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
|
|
retrieveDifferingLicencesStatus = retrieveDifferingLicences' True
|
|
|
|
retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
|
|
retrieveDifferingLicences' getStatus = do
|
|
#ifdef DEVELOPMENT
|
|
avsUsrs <- runDB $ selectList [] [LimitTo 444]
|
|
let allLicences = AvsResponseGetLicences $ Set.fromList $
|
|
[ AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 77 -- AVS:1 FD:2
|
|
, AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678 -- AVS:2 FD:1
|
|
, AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 5 -- AVS:1 FD:0 (nichts)
|
|
, AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 2 -- AVS:1 FD:0 (ungültig)
|
|
-- , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 4 -- AVS:1 FD:1
|
|
] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs]
|
|
#else
|
|
allLicences <- avsQuery AvsQueryGetAllLicences
|
|
#endif
|
|
lDiff <- getDifferingLicences allLicences
|
|
#ifdef DEVELOPMENT
|
|
let mkAdpc valid color = AvsDataPersonCard valid Nothing Nothing color (Set.singleton 'F') Nothing Nothing Nothing Nothing (AvsCardNo "1234") "5"
|
|
lStat = AvsResponseStatus $ bool mempty fakes getStatus -- not really needed, but avoids unused variable error
|
|
fakes = Set.fromList $
|
|
[ AvsStatusPerson (AvsPersonId 77 ) $ Set.singleton $ mkAdpc True AvsCardColorGelb
|
|
, AvsStatusPerson (AvsPersonId 12345678) $ Set.fromList [mkAdpc False AvsCardColorGrün, mkAdpc True AvsCardColorGelb, mkAdpc False AvsCardColorBlau, mkAdpc True AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Violett"]
|
|
, AvsStatusPerson (AvsPersonId 5 ) $ Set.fromList [mkAdpc True AvsCardColorGrün, mkAdpc False AvsCardColorGelb, mkAdpc True AvsCardColorBlau, mkAdpc False AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Pink"]
|
|
, AvsStatusPerson (AvsPersonId 2 ) $ Set.singleton $ mkAdpc True AvsCardColorGrün
|
|
] <>
|
|
[ AvsStatusPerson avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ]
|
|
#else
|
|
let statQry = avsLicenceDifferences2LicenceIds lDiff
|
|
lStat <- if getStatus && notNull statQry
|
|
then avsQueryNoCache (AvsQueryStatus statQry)
|
|
-- `catch` handler
|
|
-- let handler _exception = do
|
|
-- addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry
|
|
-- return $ AvsResponseStatus mempty
|
|
else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls
|
|
#endif
|
|
return (lDiff, avsResponseStatusMap lStat)
|
|
|
|
|
|
getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences
|
|
getDifferingLicences (AvsResponseGetLicences licences) = do
|
|
now <- liftIO getCurrentTime
|
|
--let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences
|
|
-- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld
|
|
-- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either
|
|
let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences
|
|
rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld'
|
|
vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld'
|
|
rollfeld = Set.map avsLicencePersonID rollfeld'
|
|
|
|
antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId)
|
|
antijoinAvsLicences lic avsLics = fmap unwrapIds $
|
|
E.select $ do
|
|
((_qauli :& _qualUser :& usrAvs) :& excl) <-
|
|
E.from $ ( E.table @Qualification
|
|
`E.innerJoin` E.table @QualificationUser
|
|
`E.on` ( \(quali :& qualUser) ->
|
|
(quali E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification)
|
|
-- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work!
|
|
E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic) -- correct type of licence
|
|
E.&&. (now `validQualification` qualUser) -- currently valid and not blocked
|
|
)
|
|
`E.innerJoin` E.table @UserAvs
|
|
`E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
|
|
) `E.fullOuterJoin` E.toValues (set2NonEmpty avsPersonIdZero avsLics) -- left-hand side produces all currently valid matching qualifications
|
|
`E.on` (\((_ :& _ :& usrAvs) :& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl)
|
|
E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId) -- anti join
|
|
return (usrAvs E.?. UserAvsPersonId, excl)
|
|
|
|
unwrapIds :: [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] -> (Set AvsPersonId, Set AvsPersonId)
|
|
unwrapIds = mapBoth (Set.delete avsPersonIdZero) . foldr aux mempty
|
|
where
|
|
aux (_, E.Value(Just api)) (l,r) = (l, Set.insert api r) -- we may assume here that each pair contains precisely one Just constructor
|
|
aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r)
|
|
aux _ acc = acc -- should never occur
|
|
|
|
((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,)
|
|
<$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld
|
|
<*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
|
|
let setTo0 = vorfRevoke -- revoke driving licences
|
|
setTo1up = vorfGrant Set.\\ rollGrant -- grant apron driving licence
|
|
setTo1down = rollRevoke Set.\\ vorfRevoke -- revoke maneuvering area licence, but retain apron driving licence
|
|
setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence
|
|
return AvsLicenceDifferences
|
|
{ avsLicenceDiffRevokeAll = setTo0
|
|
, avsLicenceDiffGrantVorfeld = setTo1up
|
|
, avsLicenceDiffRevokeRollfeld = setTo1down
|
|
, avsLicenceDiffGrantRollfeld = setTo2
|
|
}
|
|
{- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) :
|
|
A (0,0,0) -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem
|
|
B (0,0,1) -> ((_,_),(x,_)) : nop; do nothing -- CHECK since id is returned by roll-query
|
|
C (0,1,0) -> ((x,_),(_,_)) : set F for id
|
|
D (0,1,1) -> ((x,_),(x,_)) : set R for id
|
|
E (1,0,0) -> ((_,x),(_,_)) : set 0 for id
|
|
F (1,0,1) -> ((_,x),(x,_)) : set 0 for id
|
|
G (1,1,0) -> ((_,_),(_,_)) : nop
|
|
H (1,1,1) -> ((_,_),(x,_)) : set R for id
|
|
I (2,0,0) -> ((_,x),(_,x)) : set 0 for id
|
|
J (2,0,1) -> ((_,x),(_,_)) : set 0 for id
|
|
K (2,1,0) -> ((_,_),(_,x)) : set F for id
|
|
L (2,1,1) -> ((_,_),(_,_)) : nop
|
|
|
|
PROBLEM: B & H in conflict! (Note that nop is automatic except for case B)
|
|
Results:
|
|
set to 0: determined by vorfeld-unset -- zuerst
|
|
set to 1: vorfeld-set && nicht in rollfeld-set || rollfeld-unset && nicht in vorfeld-unset
|
|
set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld)
|
|
-}
|