-- SPDX-FileCopyrightText: 2022-24 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# LANGUAGE TypeApplications, ExistentialQuantification #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- 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 , upsertAvsUserById, upsertAvsUserByCard -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface , AvsLicenceDifferences(..) , setLicence, setLicenceAvs, setLicencesAvs , retrieveDifferingLicences, retrieveDifferingLicencesStatus , computeDifferingLicences -- , synchAvsLicences , 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 Utils.Avs import Utils.Mail (pickValidEmail) import Utils.Users import Handler.Utils.Users import Handler.Utils.Profile (validPostAddressText) import Handler.Utils.Company import Handler.Utils.Qualification import Handler.Utils.Memcached import Database.Persist.Sql (deleteWhereCount) --, updateWhereCount) 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 | 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 act = act `catches` handlers where handlers = [ Catch.Handler (\(exc::AvsException) -> addMessageI Warning exc >> return Nothing) , Catch.Handler (\(exc::ClientError ) -> do let msg = "AVS fatal communicaton failure: " <> tshow exc $logErrorS "AVS" msg addMessage Warning $ toHtml msg return Nothing ) ] ------------------ -- AVS Handlers -- ------------------ -- TODO: delete lookupAvsUser and lookupAvsUsers once Handler.Admin.Avs.getAdminAvsUserR as refactored! 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 runDB (getBy (UniqueUserAvsUser uid)) >>= \case Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> void . maybeCatchAll $ Just <$> upsertAvsUserById apid Nothing -> return () -- Retrieve updated user and supervisors now (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,) <$> 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 (void . maybeCatchAll . fmap Just . upsertAvsUserById) -- attempt to update postaddress from AVS if null receiverIDs then directResult else do receivers <- runDB $ 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 . maybeCatchAll . 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 _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup) _avsFirmPostAddress = to mkPost where mkPost afi@AvsFirmInfo{avsFirmFirm} = let someAddr = afi ^. _avsFirmPostAddressSimple prefAddr = plaintextToStoredMarkup . (avsFirmFirm <>) . Text.cons '\n' in prefAddr <$> someAddr -- | company post address without company name, better suited for comparisons _avsFirmPostAddressSimple :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) _avsFirmPostAddressSimple = to mkPost where mkPost AvsFirmInfo{..} = let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr] _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) _avsFirmPrimaryEmail = to mkEmail where mkEmail afi = let candidates = catMaybes [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail , afi ^. _avsFirmEMailSuperior , afi ^. _avsFirmEMail ] in pickValidEmail candidates -- should we return an invalid email rather than none? -- | Not sure this is useful, since postal is ignored if there is no post address anyway _avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool _avsFirmPrefersPostal = to mkPostPref where mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail) -- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate (EntityField record typ) (Getting typ iavs typ) -- A persistent record field and fitting getting -- | Compute necessary updates. Given an database record, a new and an old avs response and a pair consisting of a getter from avs response to a value and and EntityField of the same value, -- an update is returned, if the current value is identical to the old avs value, which changed in the new avs query mkUpdate :: PersistEntity record => record -> iavs -> Maybe iavs -> CheckAvsUpdate record iavs -> Maybe (Update record) mkUpdate ent new (Just old) (CheckAvsUpdate up l) | let newval = new ^. l , let oldval = old ^. l , let entval = ent ^. fieldLensVal up , newval /= entval , oldval == entval = Just (up =. newval) mkUpdate _ _ _ _ = Nothing -- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited mkUpdate' :: PersistEntity record => record -> iavs -> Maybe iavs -> CheckAvsUpdate record iavs -> Maybe (Update record) mkUpdate' ent new Nothing = mkUpdateDirect ent new mkUpdate' ent new just = mkUpdate ent new just mkUpdateDirect :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record) mkUpdateDirect ent new (CheckAvsUpdate up l) | let newval = new ^. l , let entval = ent ^. fieldLensVal up , newval /= entval = Just (up =. newval) mkUpdateDirect _ _ _ = Nothing -- | Unconditionally update a record through CheckAvsU updateRecord :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> record updateRecord ent new (CheckAvsUpdate up l) = let newval = new ^. l lensRec = fieldLensVal up in ent & lensRec .~ newval -- | Update given AvsPersonId by querying AVS for each; update only, no insertion! Uses batch mechanism, but single query may throw updateAvsUserByIds :: Set AvsPersonId -> DB (Set (AvsPersonId, UserId)) updateAvsUserByIds apids0 = do apids <- Set.fromList <$> E.filterExists UserAvsPersonId apids0 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) res <- foldMapM procResp requestedAnswers let missing = Set.toList $ Set.difference apids $ Set.map fst res unless (null missing) $ do now <- liftIO getCurrentTime updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"] -- all others were already marked as updated return res where procResp (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = fmap maybeMonoid . 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 newAvsCardNo <- queryAvsFullCardNo apid -- Nothing os ok here, does not throw now <- liftIO getCurrentTime let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here oldAvsCardNo = userAvsLastCardNo usravs & fmap Just per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo) [ CheckAvsUpdate UserFirstName _avsInfoFirstName , CheckAvsUpdate UserSurname _avsInfoLastName , CheckAvsUpdate UserDisplayName _avsInfoDisplayName , CheckAvsUpdate UserBirthday _avsInfoDateOfBirth , CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` , CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo ] em_p_up = mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo $ CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe im AvsInfo, aber nicht im User em_f_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. CheckAvsUpdate UserDisplayEmail $ _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI eml_up = em_p_up <|> em_f_up -- ensure that only one email update is produced; there is no Eq instance for the Update type frm_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ -- Legacy, if company postal is stored in user; should no longer be true for new users, CheckAvsUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead pin_up = mkUpdate' usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card CheckAvsUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` 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, entityVal=newCompany} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo primaryCompanyId <- getUserPrimaryCompany usrId (Just . CompanyKey . companyShorthand) let oldCompanyId = entityKey <$> oldCompanyEnt oldCompanyMb = entityVal <$> oldCompanyEnt pst_up = if -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) | isNothing oldCompanyMb -> mkUpdateDirect usr newCompany $ CheckAvsUpdate 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 $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference | otherwise -> Nothing superReasonComDef = tshow SupervisorReasonCompanyDefault newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done usr_up2 <- case oldAvsFirmInfo of _ | Just newCompanyId == oldCompanyId -- company unchanged entirely -> return Nothing -- => do nothing (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged OR || ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- 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 Nothing _ | 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 Nothing _ -- company changed completely -> do -- 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 oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] addCompanySupervisors newCompanyId usrId newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId return pst_up repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors update usrId $ usr_up2 `mcons` usr_up1 -- update user eventually update uaId avs_ups -- update stored avsinfo for future updates return $ Set.singleton (apid, usrId) -- 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 :: AvsPersonId -> Handler UserId createAvsUserById api = do AvsResponseContact contactRes <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api case Set.toList contactRes of [] -> throwM $ AvsUserUnknownByAvs api (_:_:_) -> throwM $ AvsUserAmbiguous api [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 <- runDB $ do mbUid <- firstJustM $ catMaybes [ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing , persMail <&> guessUserByEmail ] mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid return (mbUid, mbUAvs) usrCardNo <- queryAvsFullCardNo api now <- liftIO getCurrentTime let usrAvs uid mbFirmInfo = 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 = Just cpi , userAvsLastFirmInfo = mbFirmInfo , userAvsLastCardNo = usrCardNo } case oldUsr of (_ , Just Entity{entityVal=UserAvs{userAvsPersonId=api'}}) | api /= api' -> throwM $ AvsIdMismatch api api' | otherwise -> throwM $ AvsUserUnknownByAvs api (Just uid, Nothing) -> runDB $ do -- link with matching exisitng user insert_ $ usrAvs uid Nothing -- company info should cause the user to be associated with the company during the update updRes <- updateAvsUserByIds $ Set.singleton api -- no loop, since updateAvsUserByIds does not call createAvsUserById case Set.toList updRes of [(api',uid')] | api == api' -> return uid' -- && uid == uid' -> return uid | otherwise -> throwM $ AvsIdMismatch api api' [] -> throwM $ AvsUserUnknownByAvs api _ -> throwM $ AvsUserAmbiguous api (Nothing, Nothing) -> do 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 = persMail & fromMaybe mempty , audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI) , audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api ) , audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo , audMatriculation = cpi ^. _avsInfoPersonNo & Just . tshow , 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 -- 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 addCompanySupervisors cid uid repsertSuperiorSupervisor (Just cid) firmInfo uid -- Save AVS data for future updates insert_ $ usrAvs uid $ Just firmInfo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible return uid -- | upsert superior by eMail through LDAP only (currently no email search available in AVS) repsertSuperiorSupervisor :: Maybe CompanyId -> AvsFirmInfo -> UserId -> DB () repsertSuperiorSupervisor cid afi uid = whenIsJust (afi ^. _avsFirmEMailSuperior) $ \supemail -> forMM_ (altM (guessUserByEmail $ stripCI supemail) (maybeCatchAll $ Just . entityKey <$> ldapLookupAndUpsert supemail) ) $ \supid -> do let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior deleteWhere [UserSupervisorUser ==. uid, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior] void $ insertUnique $ UserSupervisor supid uid False cid reasonSuperior -- | 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 $ bcons (compAvsId > 0) ( getBy $ UniqueCompanyAvsId compAvsId ) [ getEntity $ CompanyKey compShorthand , getBy $ UniqueCompanyName compName ] -- | 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 case (mbFirmEnt, mbOldAvsFirmInfo) of (Nothing, _) -> do -- insert new company 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 = newAvsFirmInfo ^. _avsFirmFirmNo , companyPrefersPostal = True , companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress , companyEmail = newAvsFirmInfo ^? _avsFirmPrimaryEmail . _Just . from _CI } newCmp <- insertEntity $ foldl' upd dmy firmInfo2company reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp 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 Entity firmid <$> updateGet firmid cmp_ups where firmInfo2company = [ CheckAvsUpdate CompanyName $ _avsFirmFirm . from _CI , CheckAvsUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI , CheckAvsUpdate CompanyAvsId _avsFirmFirmNo -- Updating primary keys is always tricky, but should be okay thanks to OnUpdateCascade -- , CheckAvsUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available , CheckAvsUpdate CompanyPostAddress _avsFirmPostAddress , CheckAvsUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just ] -- | 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 runDB (getBy $ UniqueUserAvsId avsid) >>= \case (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid | prefix=="AVSNO:" = runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr]) guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) = catchAVS2message $ upsertAvsUserByCard someavsid >>= \case Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid]) other -> return other guessAvsUser someid = do try (runDB $ ldapLookupAndUpsert someid) >>= \case Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> -- ensure internal user is linked to avs, if possible catchAVS2message (upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo) <&> \case Nothing -> Just uid other -> other 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 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 (updateAvsUserByIds $ Set.singleton api) case Set.toList upd of [] -> createAvsUserById api [(api',uid)] | api == api' -> return uid | otherwise -> throwM $ AvsIdMismatch api api' -- error $ "Handler.Utils.Avs.updateAvsUserByIds returned unasked user with AvsPersonId " <> show api' <> " for queried AvsPersonId " <> show api <> "." (_:_:_) -> throwM $ AvsUserAmbiguous api -- 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 -- TODO: Admin Error page 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) -}