128 lines
5.8 KiB
Haskell
128 lines
5.8 KiB
Haskell
-- 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
|
|
wF = fromGregorian 2023 10 17
|
|
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)]
|
|
compileBlocks wA wE [(w1,False),(w2,True),(wF,True ),(w3,False)] `shouldBe` [(wA,w1),(w2,w3)]
|
|
compileBlocks wA wE [(w1,True),(w2,False),(wF,False),(w3,True)] `shouldBe` [(wA,w2),(w3,wE)]
|
|
compileBlocks wA wE [(w2,False),(wF,False),(w3,True)] `shouldBe` [(wA,w2),(w3,wE)]
|
|
compileBlocks wA wE [(w2,False),(wF,False)] `shouldBe` [(wA,w2) ]
|
|
|
|
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)
|
|
b3 <- generate arbitrary
|
|
b4 <- generate arbitrary
|
|
let test = compileBlocks d1 d2 [(d3,b3),(d4,b4)]
|
|
result | b3, b4 = [(d1, d2)]
|
|
| b3 = [(d1, min d2 d4)]
|
|
| b4, d2 > d4 = [(d1,d3),(d4,d2)]
|
|
| otherwise = [(d1, min d2 d3)]
|
|
test `shouldBe` result
|