chore(avs): avs licence synchronize via anti join (WIP, we see light)

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

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)

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
@@ -119,55 +123,68 @@ setLicencesAvs pls = do
 --   TODO: turn into a job, once the interface is actually available
 checkLicences :: Handler ()
 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
+  -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either 
-      (_nolicence ,  vorfeld) = Set.spanAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence)      noOrVorfeld
+  let nowaday = utctDay now
-      idsRollfeld = avsLicencePersonId <$> Set.toList rollfeld
+      noOne   = AvsPersonId 0
-      idsVorfeld  = avsLicencePersonId <$> Set.toList vorfeld
+      vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence)      licences
-
+      rollfeld'      = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld'
-  -- let licenceMap Map.map avsLicencePersonID $ avsMap.fromSet avsLicenceRampLicence licences
+      vorORrollfeld  :: NonEmpty AvsPersonId = set2NonEmpty noOne (Set.map avsLicencePersonID vorORrollfeld')
-  --     idsRollfeld = concat $ Map.lookup AvsLicenceRollfeld licenceMap
+      rollfeld       = set2NonEmpty noOne (Set.map avsLicencePersonID rollfeld'     )
-  --     idsVorfeld  = concat $ Map.lookup AvsLicenceVorfeld
-
-  now <- liftIO getCurrentTime
 
 
-  runDB $ do
+  -- we get a weird type error so we try a simple demo here:
-    E.select $ do
+  (_res :: [(E.Value AvsPersonId, E.Value AvsPersonId )]) <- runDB $ E.select $ do
-      (qauli E.:& qualUser E.:& usrAvs) <-
+    (usrAvs E.:& (excl,_)) <-
-        E.from $      E.table @Qualification
+      E.from $ E.table @UserAvs `E.innerJoin` E.values ((E.val (AvsPersonId 10), E.val ("ten" :: Text))
-        `E.innerJoin` E.table @QualificationUser
+                                                  :| [ (E.val (AvsPersonId 20), E.val "twenty")
-        `E.on` (\(quali E.:& qualUser) -> qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification)
+                                                      , (E.val (AvsPersonId 30), E.val "thirty") ]
-        `E.innerJoin` E.table @UserAvs
+                                                  )
-        `E.on` (\(_ E.:& qualUser E.:& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
+              `E.on` (\(usrAvs E.:& (excl,_)) -> excl E.==. usrAvs E.^. UserAvsPersonId)
-      E.where_ $ E.isJust (quali E.^. QualificationAvsLicence)
+    return (usrAvs E.^. UserAvsPersonId, excl)
-          E.&&.  (usrAvs E.^. QualificationAvsLicence `E.notIn` E.valList idsRollfeld)
+    -- > 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 
 
-
+      -- antijoinAvsLicences :: AvsLicence -> NonEmpty AvsPersonId -> DB [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] 
-      -- WAS WILL ICH HIER WIRKLICH:
+      antijoinAvsLicences lic avsLics = --fmap (fmap $(E.unValueN 2)) $ 
-      --  Liefere alle avsIds, welche die falsche Qualifikation zugewiesen bekommen haben?
+       E.select $ do
-          -- Wie erhalte ich alle IDs, welche es KEINE Qualifikation haben?  FROM valList scheint es nicht zu geben!
+        ((_qauli E.:& _qualUser E.:& usrAvs) E.:& excl) <-
-
+          E.from $ (      E.table @Qualification
-      return 
+            `E.innerJoin` E.table @QualificationUser
-        ( userAvs E.^. UserAvsPersonId
+            `E.on` ( \(quali E.:& qualUser) -> 
-        , quali   E.^. QualificationAvsLicence
+                    (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
-  --TODO this must be chunked into separate jobs/tasks
+              E.&&. (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld           
-  --forM licences $ \AvsPersonLicence{..} -> do
+                                               ,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
 
 

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
@@ -66,3 +68,9 @@ setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (previ
 
 setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k
 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.:| []