chore(acs): checkLicences completed

src/Data/Time/Clock/Instances.hs

@@ -99,7 +99,7 @@ instance PersistField CalendarDiffDays where
       coerceICcd :: Integer -> CDDdb
       coerceICcd = fromIntegral
 
-      -- placement in Utils impossivle due to cyclic dependencies
+      -- placement in Utils impossible due to cyclic dependencies
       -- Data.Tuple.Extra is not yet a dependency
       -- both = join (***)  is still too cryptic for me
       both :: (a -> b) -> (a, a) -> (b, b)

src/Database/Esqueleto/Utils.hs

@@ -106,7 +106,7 @@ justValList :: PersistField typ => [typ] -> E.SqlExpr (E.ValueList (Maybe typ))
 -- justValList = E.valList . map Just
 justValList = E.justList . E.valList
 
-toValues :: PersistField typ => NonEmpty typ -> Ex.From (Ex.SqlExpr (Ex.Value typ)) -- E.From does not work here! Requires Experimental!
+toValues :: PersistField typ => NonEmpty typ -> Ex.From (Ex.SqlExpr (Ex.Value typ)) -- E.From invalid here, requires Esqueleto.Experimental
 toValues = E.values . fmap Ex.val
 
 infixl 4 =?.

src/Handler/Utils/Avs.hs

@@ -6,7 +6,7 @@
 
 {-# 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-error=unused-matches #-}  -- TODO: remove this line, once the module is completed
 
 
 module Handler.Utils.Avs
@@ -124,9 +124,19 @@ setLicencesAvs pls = do
 checkLicences :: Handler ()
 checkLicences = do        
   AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery  
-  AvsResponseGetLicences licences <- throwLeftM avsQueryGetAllLicences  
+  allLicences <- throwLeftM avsQueryGetAllLicences  
+  deltaLicences <- computeDifferingLicences allLicences
+  setResponse <- throwLeftM $ avsQuerySetLicences deltaLicences
+  _ <- case setResponse of 
+    AvsResponseSetLicencesError stat msg -> error "TODO!"
+    AvsResponseSetLicences msgs -> 
+      let (ok,bad) = Set.partition (sloppyBool . avsResponseSuccess) msgs
+      in error "TODO!"
+  return ()
+
+computeDifferingLicences :: AvsResponseGetLicences -> Handler AvsQuerySetLicences  
+computeDifferingLicences (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 
@@ -134,36 +144,11 @@ checkLicences = do
       noOne   = AvsPersonId 0
       vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence)      licences
       rollfeld'      = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld'
-      vorORrollfeld  = set2NonEmpty noOne (Set.map avsLicencePersonID vorORrollfeld')
+      vorORrollfeld  = Set.map avsLicencePersonID vorORrollfeld'
-      rollfeld       = set2NonEmpty noOne (Set.map avsLicencePersonID rollfeld'     )
+      rollfeld       = Set.map avsLicencePersonID rollfeld'
 
-
+      antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId)
-  -- we get a weird type error so we try a simple demo here:
+      antijoinAvsLicences lic avsLics = fmap unwrapIds $ 
-  (_res :: [(E.Value AvsPersonId, E.Value AvsPersonId )]) <- runDB $ E.select $ do
-    (usrAvs E.:& excl) <-
-      E.from $ E.table @UserAvs `E.innerJoin` E.toValues rollfeld
-              `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?!
-
-{-
-  Cases to consider (AVS_Licence,has_valid_F, has_valid_R):
-    (0,0,0)  -> ok; avs_id not returned from queries, no problem 
-    (0,0,1)  -> do nothing     -- CHECK since id is returned by roll-query
-    (0,1,0)  -> set F for id 
-    (0,1,1)  -> set R for id
-    (1,0,0)  -> unset F for id
-    (1,0,1)  -> unset F for id 
-    (1,1,0)  -> ok
-    (1,1,1)  -> set R for id
-    (2,0,0)  -> unset R for id
-    (2,0,1)  -> unset R for id -- CHECK
-    (2,1,0)  -> set F for id 
-    (2,1,1)  -> ok
--}
-  
-      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
@@ -178,25 +163,49 @@ checkLicences = do
               )
             `E.innerJoin` E.table @UserAvs
             `E.on` (\(_ E.:& qualUser E.:& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
-          ) `E.fullOuterJoin` E.toValues avsLics -- left-hand side produces all currently valid matching qualifications
+          ) `E.fullOuterJoin` E.toValues (set2NonEmpty noOne 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
+      unwrapIds :: [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] -> (Set AvsPersonId, Set AvsPersonId)        
-  --     roll2roll = Set.fromList rollGrant
+      unwrapIds = mapBoth (Set.delete noOne) . foldr aux mempty
-  --     vorf2vorf = Set.fromList vorfGrant
+        where
-  --     vorf2zero = Set.fromList vorfRevoke
+          aux (_, E.Value(Just api)) (l,r) = (l, Set.insert api r) -- we may assume here that each pair contains precisely one Just constructor
-  -- cases to consider:
+          aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r)             
-    -- aID is either in lhs or rhs of vorfDelta, rollDelta or both. 
+          aux _ acc = acc -- should never occur
-    -- The case 
+
-  
+  ((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,)
-    
+    <$> antijoinAvsLicences AvsLicenceVorfeld  vorORrollfeld
-  error "CONTINUE HERE" -- TODO STUB
+    <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
+  let setTo0 = vorfRevoke -- ready to use with SET 0 
+      setTo1 = (vorfGrant Set.\\ rollGrant ) `Set.union` (rollRevoke Set.\\ vorfRevoke)
+      setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld)
+      {-
+        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)              
+      -}
+  return $ AvsQuerySetLicences $
+       Set.map (AvsPersonLicence AvsNoLicence)       setTo0
+    <> Set.map (AvsPersonLicence AvsLicenceVorfeld)  setTo1 
+    <> Set.map (AvsPersonLicence AvsLicenceRollfeld) setTo2
 
 
 upsertAvsUser :: Text -> Handler (Maybe UserId)

src/Utils.hs

@@ -619,6 +619,10 @@ trd3 (_,_,z) = z
 mTuple :: Applicative f => f a -> f b -> f (a, b)
 mTuple = liftA2 (,)
 
+-- From Data.Tuple.Extra
+mapBoth :: (a -> b) -> (a,a) -> (b,b)
+mapBoth f ~(a,b) = (f a, f b)
+
 -----------
 -- Lists --
 -----------