From 3794f7482b720eefd555bcbf3581d7f91a463a4b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 25 Nov 2022 19:08:46 +0100 Subject: [PATCH] chore(avs): avs licence synchronize via anti join (WIP, we see light) --- models/avs.model | 2 +- src/Database/Esqueleto/Utils.hs | 6 +- src/Handler/Utils/Avs.hs | 103 +++++++++++++++++++------------- src/Utils/Set.hs | 10 +++- 4 files changed, 74 insertions(+), 47 deletions(-) diff --git a/models/avs.model b/models/avs.model index a1a7d87c7..041c6aba0 100644 --- a/models/avs.model +++ b/models/avs.model @@ -14,7 +14,7 @@ UserAvs - personId AvsPersonId -- unique identifier for user throughout avs + personId AvsPersonId -- unique identifier for user throughout avs; newtype for Int user UserId UniqueUserAvsUser user UniqueUserAvsId personId diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 2d823de2b..66394d53b 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -97,10 +97,12 @@ false = E.val False -- infinity = unsafeSqlValue "'infinity'" justVal :: PersistField typ => typ -> E.SqlExpr (E.Value (Maybe typ)) -justVal = E.val . Just +-- justVal = E.val . Just +justVal = E.just . E.val justValList :: PersistField typ => [typ] -> E.SqlExpr (E.ValueList (Maybe typ)) -justValList = E.valList . map Just +-- justValList = E.valList . map Just +justValList = E.justList . E.valList infixl 4 =?. (=?.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index c1316fb23..85671d0ae 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -5,6 +5,9 @@ {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO: remove this line, once the module is completed +{-# OPTIONS_GHC -Wno-error=unused-local-binds #-} -- TODO: remove this line, once the module is completed +{-# OPTIONS_GHC -Wno-warn=unused-local-binds #-} -- TODO: remove this line, once the module is completed + module Handler.Utils.Avs ( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard @@ -33,7 +36,8 @@ import Handler.Users.Add 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.Utils as E +import qualified Database.Esqueleto.PostgreSQL as E -------------------- @@ -43,7 +47,7 @@ import qualified Database.Esqueleto.Utils as E data AvsException = AvsInterfaceUnavailable -- Interface to AVS was not configured at startup or does not respond | AvsUserUnassociated UserId -- Manipulating AVS Data for a user that is not linked to AVS yet - | AvsUserUnknownByAvs AvsPersonId -- AvsPersionId not (or no longer) found in AVS DB + | AvsUserUnknownByAvs AvsPersonId -- AvsPersonId not (or no longer) found in AVS DB | AvsUserAmbiguous -- Multiple matching existing users found in our DB | AvsPersonSearchEmpty -- AvsPersonSearch returned empty result | AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result @@ -118,56 +122,69 @@ setLicencesAvs pls = do -- Only react to changes as compared to last seen status in avs.model -- TODO: turn into a job, once the interface is actually available checkLicences :: Handler () -checkLicences = do - {- +checkLicences = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery AvsResponseGetLicences licences <- throwLeftM avsQueryGetAllLicences - + now <- liftIO getCurrentTime + --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences -- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld - let (noOrVorfeld, rollfeld) = Set.spanAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) licences - (_nolicence , vorfeld) = Set.spanAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) noOrVorfeld - idsRollfeld = avsLicencePersonId <$> Set.toList rollfeld - idsVorfeld = avsLicencePersonId <$> Set.toList vorfeld - - -- let licenceMap Map.map avsLicencePersonID $ avsMap.fromSet avsLicenceRampLicence licences - -- idsRollfeld = concat $ Map.lookup AvsLicenceRollfeld licenceMap - -- idsVorfeld = concat $ Map.lookup AvsLicenceVorfeld - - now <- liftIO getCurrentTime + -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either + let nowaday = utctDay now + noOne = AvsPersonId 0 + vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences + rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld' + vorORrollfeld :: NonEmpty AvsPersonId = set2NonEmpty noOne (Set.map avsLicencePersonID vorORrollfeld') + rollfeld = set2NonEmpty noOne (Set.map avsLicencePersonID rollfeld' ) - runDB $ do - E.select $ do - (qauli E.:& qualUser E.:& usrAvs) <- - E.from $ E.table @Qualification - `E.innerJoin` E.table @QualificationUser - `E.on` (\(quali E.:& qualUser) -> qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification) - `E.innerJoin` E.table @UserAvs - `E.on` (\(_ E.:& qualUser E.:& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) - E.where_ $ E.isJust (quali E.^. QualificationAvsLicence) - E.&&. (usrAvs E.^. QualificationAvsLicence `E.notIn` E.valList idsRollfeld) + -- we get a weird type error so we try a simple demo here: + (_res :: [(E.Value AvsPersonId, E.Value AvsPersonId )]) <- runDB $ E.select $ do + (usrAvs E.:& (excl,_)) <- + E.from $ E.table @UserAvs `E.innerJoin` E.values ((E.val (AvsPersonId 10), E.val ("ten" :: Text)) + :| [ (E.val (AvsPersonId 20), E.val "twenty") + , (E.val (AvsPersonId 30), E.val "thirty") ] + ) + `E.on` (\(usrAvs E.:& (excl,_)) -> excl E.==. usrAvs E.^. UserAvsPersonId) + return (usrAvs E.^. UserAvsPersonId, excl) + -- > Looks like we need te Type NonEmpty (SqlExpr (Value typ)) i.e. we need to wrap everything with E.val?! - SELECT * - FROM sometable - FULL OUTER JOIN - (VALUES {{1,2,3},{4,5,6}}) AS t(x,y,z) - ON sometable.x = t.x - WHERE either IS NULL -- Use ERaw - + {- - -- WAS WILL ICH HIER WIRKLICH: - -- Liefere alle avsIds, welche die falsche Qualifikation zugewiesen bekommen haben? - -- Wie erhalte ich alle IDs, welche es KEINE Qualifikation haben? FROM valList scheint es nicht zu geben! - - return - ( userAvs E.^. UserAvsPersonId - , quali E.^. QualificationAvsLicence - ) - - --TODO this must be chunked into separate jobs/tasks - --forM licences $ \AvsPersonLicence{..} -> do + -- antijoinAvsLicences :: AvsLicence -> NonEmpty AvsPersonId -> DB [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] + antijoinAvsLicences lic avsLics = --fmap (fmap $(E.unValueN 2)) $ + E.select $ do + ((_qauli E.:& _qualUser E.:& usrAvs) E.:& excl) <- + E.from $ ( E.table @Qualification + `E.innerJoin` E.table @QualificationUser + `E.on` ( \(quali E.:& 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.&&. (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld + ,qualUser E.^. QualificationUserValidUntil)) -- currently valid + E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- no blocked + ) + `E.innerJoin` E.table @UserAvs + `E.on` (\(_ E.:& qualUser E.:& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) + ) `E.fullOuterJoin` E.values avsLics -- left-hand side produces all currently valid matching qualifications + `E.on` (\((_ E.:& _ E.:& usrAvs) E.:& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl) + E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId) -- anti join + return (usrAvs E.?. UserAvsPersonId, excl) -} + -- (_rollDelta, _vorfDelta) <- runDB $ (,) + -- <$> antijoinAvsLicences AvsLicenceRollfeld rollfeld + -- <*> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld + + -- let roll2zero = Set.fromList rollRevoke + -- roll2roll = Set.fromList rollGrant + -- vorf2vorf = Set.fromList vorfGrant + -- vorf2zero = Set.fromList vorfRevoke + -- cases to consider: + -- aID is either in lhs or rhs of vorfDelta, rollDelta or both. + -- The case + + error "CONTINUE HERE" -- TODO STUB diff --git a/src/Utils/Set.hs b/src/Utils/Set.hs index c539dff14..80b61cfeb 100644 --- a/src/Utils/Set.hs +++ b/src/Utils/Set.hs @@ -11,8 +11,10 @@ module Utils.Set , setPartitionEithers , setFromFunc , mapIntersectNotOne +, set2NonEmpty ) where +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Set as Set import qualified Data.Map.Strict() import qualified Data.Map as Map @@ -65,4 +67,10 @@ setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b) setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right) setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k -setFromFunc = Set.fromList . flip filter universeF \ No newline at end of file +setFromFunc = Set.fromList . flip filter universeF + + +-- | convert a Set to NonEmpty, inserting a default value if necessary +set2NonEmpty :: a -> Set a -> NonEmpty.NonEmpty a +set2NonEmpty _ (Set.toList -> h:t) = h NonEmpty.:| t +set2NonEmpty d _ = d NonEmpty.:| []