From b4a88abcf85783c350ad2bf3a5e973d13d1eb1f6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 16 Oct 2023 17:53:45 +0000 Subject: [PATCH 1/4] fix(sap): compileBlocks --- src/Handler/SAP.hs | 9 +++--- test/Handler/SAPSpec.hs | 61 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 66 insertions(+), 4 deletions(-) create mode 100644 test/Handler/SAPSpec.hs diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 01d856095..0012b3902 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -6,6 +6,7 @@ module Handler.SAP ( getQualificationSAPDirectR + , compileBlocks -- for Test in Handler.SAPSpec only ) where @@ -78,10 +79,10 @@ compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] compileBlocks dfrom duntil [] = [(dfrom, duntil )] compileBlocks dfrom duntil [(d,False)] = [(dfrom, min duntil d)] -- redundant, but common case compileBlocks dfrom duntil (p1@(d1,u1):(d2,u2):bs) - | u1 == u2 = compileBlocks dfrom duntil (p1:bs) -- superfluous block/unblock - | u2, dfrom < d1, d1 < d2, d2 < duntil = (dfrom, d1) : compileBlocks d2 duntil bs -- block and reinstated later -compileBlocks dfrom duntil ((_,True ):bs) = compileBlocks dfrom duntil bs -- superfluous unblock -compileBlocks dfrom duntil ((d,False):bs) = compileBlocks dfrom (min duntil d) bs -- should only occur if blocks/unblock happened on same day + | u1 == u2 = compileBlocks dfrom duntil (p1:bs) -- superfluous block/unblock + | u2, dfrom < d1, d1 < d2, d2 < duntil = (dfrom, d1) : compileBlocks d2 duntil bs -- block and reinstated later +compileBlocks dfrom duntil ((_,True ):bs) = compileBlocks dfrom duntil bs -- superfluous unblock +compileBlocks dfrom duntil ((_,False):bs) = compileBlocks dfrom duntil bs -- should only occur if blocks/unblock happened on same day -- Alternative Version constructed first, probably more efficient, but GHC does not recognize pattern matching as complete -- compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] diff --git a/test/Handler/SAPSpec.hs b/test/Handler/SAPSpec.hs new file mode 100644 index 000000000..f0edd28b4 --- /dev/null +++ b/test/Handler/SAPSpec.hs @@ -0,0 +1,61 @@ +-- SPDX-FileCopyrightText: 2023 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Handler.SAPSpec where + +import TestImport +-- import ModelSpec () +-- import CryptoID + +import Handler.SAP + + +data BlockIntervalTest = BlockIntervalTest Day Day [(Day,Bool)] + deriving (Show, Eq, Ord) + +instance Arbitrary BlockIntervalTest where + arbitrary = do + blocks <- arbitrary + case blocks of + [] -> do + dFrom <- arbitrary + dUntil <- arbitrary `suchThat` (dFrom <) + return $ BlockIntervalTest dFrom dUntil [] + ((h,_):t') -> do + let ds = ncons h (fst <$> t') + dmin = minimum ds + dmax = maximum ds + dFrom <- arbitrary `suchThat` (< dmin) + dUntil <- arbitrary `suchThat` (>= dmax) + return $ BlockIntervalTest dFrom dUntil $ sort blocks + + shrink (BlockIntervalTest dFrom dUntil []) + = [BlockIntervalTest dF dU [] | dF <- shrink dFrom, dU <- shrink dUntil, dF < dU] + shrink (BlockIntervalTest dFrom dUntil blocks) + = [BlockIntervalTest dFrom dUntil b | b <- shrink blocks, all ((dFrom <=) . fst) b] + + +cmpBlocks :: BlockIntervalTest -> [(Day,Day)] +cmpBlocks (BlockIntervalTest dFrom dUntil blocks) = makePeriods dFrom dUntil $ cleanBlocks $ sort blocks + where + cleanBlocks ((_,True):r) = cleanBlocks r + cleanBlocks (b1@(_,False):b2@(_,True):r) = b1:b2:cleanBlocks r + cleanBlocks (b1@(_,False): (_,False):r) = cleanBlocks (b1:r) + cleanBlocks r@[(_,False)] = r + cleanBlocks [] = [] + + makePeriods a b ((d1,False):(d2,True):r) + | b > d2 = (a,d1):makePeriods d2 b r + | otherwise = [(a,d1)] + makePeriods a b [(d,False)] = [(a,min b d)] + makePeriods a b _ = [(a,b)] + + + +spec :: Spec +spec = do + describe "SAP.compileBlocks" $ do + it "yields basic intervals" . property $ + \bit@(BlockIntervalTest dFrom dUntil blocks) -> + cmpBlocks bit == compileBlocks dFrom dUntil blocks From cbb44f106ad59e0a53ca04963ade5544120b7e21 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 17 Oct 2023 12:19:47 +0200 Subject: [PATCH 2/4] fix(sap): combine immediate next day licence chnages for SAP --- src/Handler/SAP.hs | 28 ++++++++++-------------- test/Handler/SAPSpec.hs | 48 +++++++++++++++++++++++++++++++++++------ 2 files changed, 52 insertions(+), 24 deletions(-) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 0012b3902..c22cc58bb 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -76,24 +76,18 @@ sapRes2csv = concatMap procRes -- | compute a series of valid periods, assume that lists is already sorted by Day -- the lists encodes qualification_user_blocks with block=False/unblock=True compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] -compileBlocks dfrom duntil [] = [(dfrom, duntil )] -compileBlocks dfrom duntil [(d,False)] = [(dfrom, min duntil d)] -- redundant, but common case -compileBlocks dfrom duntil (p1@(d1,u1):(d2,u2):bs) - | u1 == u2 = compileBlocks dfrom duntil (p1:bs) -- superfluous block/unblock - | u2, dfrom < d1, d1 < d2, d2 < duntil = (dfrom, d1) : compileBlocks d2 duntil bs -- block and reinstated later -compileBlocks dfrom duntil ((_,True ):bs) = compileBlocks dfrom duntil bs -- superfluous unblock -compileBlocks dfrom duntil ((_,False):bs) = compileBlocks dfrom duntil bs -- should only occur if blocks/unblock happened on same day +compileBlocks dStart dEnd = go (dStart, True) + where + go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)] + go (d,s) ((d1,s1):r1@((d2,s2):r2)) + | d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go (d,s) r1 -- ignore unnecessary change + go (d,s) ((d1,s1):r1) + | s, d < d1, d1 < dEnd = (d,d1) : go (d1,s1) r1 -- valid interval found + | otherwise = go (d1,s1) r1 -- ignore invalid interval + go (d,s) [] + | s = [(d,dEnd)] + | otherwise = [] --- Alternative Version constructed first, probably more efficient, but GHC does not recognize pattern matching as complete --- compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] --- compileBlocks dfrom duntil (p1@(d1,u1):p2@(d2,u2):bs) --- | u1 == u2 = compileBlocks dfrom duntil (p1:bs) --- | u2, d1 < duntil --- , d2 < duntil = (dfrom,d1) : compileBlocks d2 duntil bs --- compileBlocks dfrom duntil ((d1,True):bs) = compileBlocks dfrom duntil bs --- compileBlocks dfrom duntil [(d1,False)] = [(dfrom, min duntil d1)] --- compileBlocks dfrom duntil _ = [(dfrom,duntil)] - -- | Deliver all employess with a successful LDAP synch within the last 3 months getQualificationSAPDirectR :: Handler TypedContent diff --git a/test/Handler/SAPSpec.hs b/test/Handler/SAPSpec.hs index f0edd28b4..856bcf001 100644 --- a/test/Handler/SAPSpec.hs +++ b/test/Handler/SAPSpec.hs @@ -10,7 +10,7 @@ import TestImport import Handler.SAP - +{- data BlockIntervalTest = BlockIntervalTest Day Day [(Day,Bool)] deriving (Show, Eq, Ord) @@ -26,7 +26,7 @@ instance Arbitrary BlockIntervalTest where let ds = ncons h (fst <$> t') dmin = minimum ds dmax = maximum ds - dFrom <- arbitrary `suchThat` (< dmin) + dFrom <- arbitrary `suchThat` (<= dmin) dUntil <- arbitrary `suchThat` (>= dmax) return $ BlockIntervalTest dFrom dUntil $ sort blocks @@ -34,13 +34,30 @@ instance Arbitrary BlockIntervalTest where = [BlockIntervalTest dF dU [] | dF <- shrink dFrom, dU <- shrink dUntil, dF < dU] shrink (BlockIntervalTest dFrom dUntil blocks) = [BlockIntervalTest dFrom dUntil b | b <- shrink blocks, all ((dFrom <=) . fst) b] +-} +{- These alternative implementations do NOT meet the specifications and thus cannot be used for testing +compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] +compileBlocks dfrom duntil [] = [(dfrom, duntil)] +compileBlocks dfrom duntil [(d,False)] + | dend <- min duntil d, dfrom < dend = [(dfrom, dend)] -- redundant, but common case + | otherwise = [] +compileBlocks dfrom duntil (p1@(d1,u1):p2@(d2,u2):bs) + | u1 == u2 = compileBlocks dfrom duntil (p1:bs) -- superfluous block/unblock + | d1 == d2 = compileBlocks dfrom duntil (p2:bs) -- eliminate same day changes + | u2, dfrom < d1, d1 < d2, d2 < duntil = (dfrom, d1) : compileBlocks d2 duntil bs -- block and reinstated later +compileBlocks dfrom duntil ((_,True ):bs) = compileBlocks dfrom duntil bs -- superfluous unblock +compileBlocks dfrom duntil ((d,False):bs) + | dfrom >= d = compileBlocks dfrom duntil bs -- should only occur if blocks/unblock happened on same day + cmpBlocks :: BlockIntervalTest -> [(Day,Day)] cmpBlocks (BlockIntervalTest dFrom dUntil blocks) = makePeriods dFrom dUntil $ cleanBlocks $ sort blocks where cleanBlocks ((_,True):r) = cleanBlocks r - cleanBlocks (b1@(_,False):b2@(_,True):r) = b1:b2:cleanBlocks r + cleanBlocks (b1@(d1,False):b2@(d2,True):r) + | d1 < d1 = b1:b2:cleanBlocks r + | otherwise = cleanBlocks r cleanBlocks (b1@(_,False): (_,False):r) = cleanBlocks (b1:r) cleanBlocks r@[(_,False)] = r cleanBlocks [] = [] @@ -50,12 +67,29 @@ cmpBlocks (BlockIntervalTest dFrom dUntil blocks) = makePeriods dFrom dUntil $ c | otherwise = [(a,d1)] makePeriods a b [(d,False)] = [(a,min b d)] makePeriods a b _ = [(a,b)] - +-} spec :: Spec spec = do describe "SAP.compileBlocks" $ do - it "yields basic intervals" . property $ - \bit@(BlockIntervalTest dFrom dUntil blocks) -> - cmpBlocks bit == compileBlocks dFrom dUntil blocks + it "works on examples" . example $ do + let wA = fromGregorian 2002 1 11 + wE = fromGregorian 2025 4 30 + w0 = fromGregorian 2001 9 22 + w1 = fromGregorian 2023 9 22 + w2 = fromGregorian 2023 10 16 + w3 = fromGregorian 2023 11 17 + compileBlocks wA wE [] `shouldBe` [(wA,wE)] + compileBlocks wA wE [(w1,False)] `shouldBe` [(wA,w1)] + compileBlocks wA wE [(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)] + compileBlocks wA wE [(wA,False),(w1,True)] `shouldBe` [(w1,wE)] + compileBlocks wA wE [(wA,True),(wA,False),(w1,True)] `shouldBe` [(w1,wE)] + compileBlocks wA wE [(wA,False),(wA,True),(w1,True)] `shouldBe` [(wA,wE)] + compileBlocks wA wE [(wA,False),(w1,True),(w2,False)] `shouldBe` [(w1,w2)] + compileBlocks wA wE [(w1,False),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)] + compileBlocks wA wE [(w1,False),(succ w1,True),(succ w1,False),(w2,True)] `shouldBe` [(wA,succ w1),(w2,wE)] + compileBlocks wA wE [(w0,True),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True),(w3,True)] `shouldBe` [(wA,w1),(w2,wE)] + -- it "yields basic intervals" . property $ + -- \bit@(BlockIntervalTest dFrom dUntil blocks) -> + -- cmpBlocks bit == compileBlocks dFrom dUntil blocks From f4adfdf87270930d4ca6611f2a9956613fcace53 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 17 Oct 2023 13:57:19 +0200 Subject: [PATCH 3/4] fix(sap): combine immediate next day licence chnages for SAP --- src/Handler/SAP.hs | 10 ++++++---- test/Handler/SAPSpec.hs | 37 +++++++++++++++++++++++++++++++------ 2 files changed, 37 insertions(+), 10 deletions(-) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index c22cc58bb..10b71fd9f 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -79,11 +79,13 @@ compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] compileBlocks dStart dEnd = go (dStart, True) where go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)] - go (d,s) ((d1,s1):r1@((d2,s2):r2)) - | d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go (d,s) r1 -- ignore unnecessary change + go (d,s) ((d1,s1):r1@((d2,_s2):_r2)) + | d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go (d,s) r1 -- ignore unnecessary change go (d,s) ((d1,s1):r1) - | s, d < d1, d1 < dEnd = (d,d1) : go (d1,s1) r1 -- valid interval found - | otherwise = go (d1,s1) r1 -- ignore invalid interval + | s, not s1 + , d < d1, d1 < dEnd = (d,d1) : go (d1,s1) r1 -- valid interval found + | s == s1 = go (d ,s ) r1 -- no change + | otherwise = go (d1,s1) r1 -- ignore invalid interval go (d,s) [] | s = [(d,dEnd)] | otherwise = [] diff --git a/test/Handler/SAPSpec.hs b/test/Handler/SAPSpec.hs index 856bcf001..3f99699cf 100644 --- a/test/Handler/SAPSpec.hs +++ b/test/Handler/SAPSpec.hs @@ -80,16 +80,41 @@ spec = do w1 = fromGregorian 2023 9 22 w2 = fromGregorian 2023 10 16 w3 = fromGregorian 2023 11 17 + w4 = fromGregorian 2024 01 21 compileBlocks wA wE [] `shouldBe` [(wA,wE)] compileBlocks wA wE [(w1,False)] `shouldBe` [(wA,w1)] + compileBlocks wA wE [(w1,True)] `shouldBe` [(wA,wE)] compileBlocks wA wE [(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)] compileBlocks wA wE [(wA,False),(w1,True)] `shouldBe` [(w1,wE)] - compileBlocks wA wE [(wA,True),(wA,False),(w1,True)] `shouldBe` [(w1,wE)] - compileBlocks wA wE [(wA,False),(wA,True),(w1,True)] `shouldBe` [(wA,wE)] + compileBlocks wA wE [(wA,True),(wA,False),(w1,True)] `shouldBe` [(w1,wE)] + compileBlocks wA wE [(wA,False),(wA,True),(w1,True)] `shouldBe` [(wA,wE)] compileBlocks wA wE [(wA,False),(w1,True),(w2,False)] `shouldBe` [(w1,w2)] - compileBlocks wA wE [(w1,False),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)] + compileBlocks wA wE [(w1,False),(w2,True),(w3,True)] `shouldBe` [(wA,w1),(w2,wE)] compileBlocks wA wE [(w1,False),(succ w1,True),(succ w1,False),(w2,True)] `shouldBe` [(wA,succ w1),(w2,wE)] + compileBlocks wA wE [(w1,False),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)] compileBlocks wA wE [(w0,True),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True),(w3,True)] `shouldBe` [(wA,w1),(w2,wE)] - -- it "yields basic intervals" . property $ - -- \bit@(BlockIntervalTest dFrom dUntil blocks) -> - -- cmpBlocks bit == compileBlocks dFrom dUntil blocks + compileBlocks wA wE [(w0,False),(w1,False),(w2,True),(w3,False),(w4,True)] `shouldBe` [(wA,w1),(w2,w3),(w4,wE)] + + it "handles basic intervals" $ do + (d1,d2,d3) <- generate $ do + d1 <- arbitrary + d2 <- arbitrary `suchThat` (d1 <) + d3 <- arbitrary `suchThat` (d1 <) + return (d1,d2,d3) + b <- generate arbitrary + let test = compileBlocks d1 d2 [(d3,b)] + test `shouldBe` bool [(d1,min d2 d3)] [(d1,d2)] b + + it "identifies two correct intervals" $ do + (d1,d2,d3,d4) <- generate $ do + d1 <- arbitrary + d2 <- arbitrary `suchThat` (d1 <) + d3 <- arbitrary `suchThat` (d1 <) + d4 <- arbitrary `suchThat` (d3 <) + return (d1,d2,d3,d4) + b <- generate arbitrary + let test = compileBlocks d1 d2 [(d3,b),(d4,not b)] + result | b = [(d1, min d2 d4)] + | d2 > d4 = [(d1,d3),(d4,d2)] + | otherwise = [(d1, min d2 d3)] + test `shouldBe` result From 3924d14abd868305b42c9d04913536b4999dc45b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 17 Oct 2023 16:56:56 +0200 Subject: [PATCH 4/4] fix(sap): combineBlocks yet another bug squashed --- src/Handler/SAP.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 10b71fd9f..34b00b81b 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -79,13 +79,13 @@ compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)] compileBlocks dStart dEnd = go (dStart, True) where go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)] - go (d,s) ((d1,s1):r1@((d2,_s2):_r2)) - | d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go (d,s) r1 -- ignore unnecessary change - go (d,s) ((d1,s1):r1) - | s, not s1 - , d < d1, d1 < dEnd = (d,d1) : go (d1,s1) r1 -- valid interval found - | s == s1 = go (d ,s ) r1 -- no change - | otherwise = go (d1,s1) r1 -- ignore invalid interval + go b@(d,s) ((d1,s1):r1@((d2,_s2):_r2)) + | d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go b r1 -- ignore unnecessary change + go b@(d,s) ((d1,s1):r1) + | d1 >= dEnd = go b [] -- remaining days extend validity + | s, not s1, d < d1 = (d,d1) : go (d1,s1) r1 -- valid interval found + | s == s1 = go b r1 -- no change + | otherwise = go (d1,s1) r1 -- ignore invalid interval go (d,s) [] | s = [(d,dEnd)] | otherwise = []