diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs index 84f23db4f..d08b8e6c4 100644 --- a/src/Data/Time/Clock/Instances.hs +++ b/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) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 1555f6388..128307869 100644 --- a/src/Database/Esqueleto/Utils.hs +++ 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 =?. diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 13e20bf30..ecdf343c5 100644 --- a/src/Handler/Utils/Avs.hs +++ b/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') - rollfeld = set2NonEmpty noOne (Set.map avsLicencePersonID rollfeld' ) + vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld' + rollfeld = Set.map avsLicencePersonID rollfeld' - - -- 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.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)) $ + antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId) + antijoinAvsLicences lic avsLics = fmap unwrapIds $ 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 - -- 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 + unwrapIds :: [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] -> (Set AvsPersonId, Set AvsPersonId) + unwrapIds = mapBoth (Set.delete noOne) . 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 -- 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) diff --git a/src/Utils.hs b/src/Utils.hs index 575ac8fd5..8a92fe520 100644 --- a/src/Utils.hs +++ b/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 -- -----------