-- SPDX-FileCopyrightText: 2022-24 Steffen Jost -- -- 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) -}