62 lines
1.9 KiB
Haskell
62 lines
1.9 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]
|
|
|
|
|
|
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
|