fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into fradrive/company

Browse Source
This commit is contained in:
Steffen Jost 2023-10-17 15:11:41 +00:00
commit db4b1d8730
2 changed files with 134 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
src/Handler/SAP.hs
View File

@ -6,6 +6,7 @@
module Handler.SAP
( getQualificationSAPDirectR
, compileBlocks -- for Test in Handler.SAPSpec only
)
where
@ -75,24 +76,20 @@ 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 ((d,False):bs) = compileBlocks dfrom (min duntil d) 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 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 = []
-- 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

120
test/Handler/SAPSpec.hs Normal file
View File

@ -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