Merge branch 'master' into fradrive/company

src/Handler/SAP.hs

@@ -6,6 +6,7 @@
 
 module Handler.SAP
   ( getQualificationSAPDirectR
+  , compileBlocks -- for Test in Handler.SAPSpec only
   )
   where
 
@@ -75,23 +76,19 @@ 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 dStart dEnd = go (dStart, True) 
-compileBlocks dfrom duntil [(d,False)]    = [(dfrom, min duntil d)] -- redundant, but common case
+  where 
-compileBlocks dfrom duntil (p1@(d1,u1):(d2,u2):bs)
+    go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)]
-  | u1 == u2                              =               compileBlocks dfrom      duntil (p1:bs)   -- superfluous block/unblock
+    go b@(d,s) ((d1,s1):r1@((d2,_s2):_r2))
-  | u2, dfrom < d1, d1 < d2, d2 < duntil  = (dfrom, d1) : compileBlocks d2         duntil     bs    -- block and reinstated later
+      | d1 == d2 || succ d1 == d2 || s == s1 || d1 < d = go b r1  -- ignore unnecessary change
-compileBlocks dfrom duntil ((_,True ):bs) =               compileBlocks dfrom      duntil     bs    -- superfluous unblock
+    go b@(d,s) ((d1,s1):r1)
-compileBlocks dfrom duntil ((d,False):bs) =               compileBlocks dfrom (min duntil d)  bs    -- should only occur if blocks/unblock happened on same day 
+      | d1 >= dEnd        = go b []                               -- remaining days extend validity
-
+      | s, not s1, d < d1 = (d,d1) : go (d1,s1) r1                -- valid interval found
--- Alternative Version constructed first, probably more efficient, but GHC does not recognize pattern matching as complete
+      | s == s1           =          go  b      r1                -- no change
--- compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
+      | otherwise         =          go (d1,s1) r1                -- ignore invalid interval
--- compileBlocks dfrom duntil (p1@(d1,u1):p2@(d2,u2):bs)
+    go (d,s) []
---   | u1 == u2        =              compileBlocks dfrom duntil (p1:bs)  
+      | s         = [(d,dEnd)]
---   | u2, d1 < duntil  
+      | otherwise = []
---       , 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

test/Handler/SAPSpec.hs

@@ -0,0 +1,120 @@
+-- SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@faport.de>
+--
+-- 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]
+-}
+
+{- 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@(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 [] = []
+
+    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 "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
+          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,False),(w1,True),(w2,False)] `shouldBe` [(w1,w2)]
+      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)]
+      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