chore(acs): checkLicences completed
This commit is contained in:
Steffen Jost
parent
59f268a796
commit
fc36161ff2
@ -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)
|
||||
|
||||
@ -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 =?.
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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 --
|
||||
-----------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user