Add property test for auction algorithm.

[?]

Mar 5, 2016, 8:20 PM

LHJ2HFXVUQ4VG25I7DADWU73G5K5WNZBDQ3SVNKFYLZ5BEYM4XCQC

Dependencies

[2] HBULCDN6 Add tests for auction winner determination algorithm.
[3] KNSI575V Cleanup of EventLog types.
[4] 2XQD6KKK Add invitation logic and clean up DBProg error handling.
[5] KEP5WUFJ Convert project to stack-based build.
[6] SCXG6TJW Make log reduction safer in presence of overlapping events.
[7] UUR6SMCA Add start of specs for auctions.
[8] 2KZPOGRB Once you get Haskell to compile, the tests pass!
[9] Y35QCWYW Minor improvement in WorkIndex type to eliminate duplicated information.
[10] TLQ72DSJ Lenses, sqlite-simple
[11] M4KM76DG Merge branch 'stackify'
[12] IZEVQF62 Work in progress replacing sqlite with postgres.
[13] 7KZP4RHZ Switch from Data.Time to Data.Thyme
[14] WO2MINIF Auctions now compile!
[15] QMRKFEPG Refactor QDB to use a free monad algebra instead.
[16] F2XLL7XW Remove Ord Bid & sort in favor of sortBy
[17] NMWWP4ZN Trying out Hspec
[18] 4SCFOJGN Specs for recovering intervals from the log now pass.
[19] 5DRIWGLU Improving TimeLog specs
[20] NEDDHXUK Reformat via stylish-haskell
[21] 75N3UJ4J More progression toward lenses.
[22] GLFF5ZDK Factor winningBids for easier testing.
[23] ZP62WC47 Begin conversion to build with stack.
[24] EQXRXRZD Changed to use tasty instead of test-framework
[25] LAROLAYU WIP
[26] WJO37T74 Restored the single test to functionality.
[27] 7HPY3QPF Fix linting errors. (yay hlint!)
[*] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[*] NVOCQVAS Initial failing tests.

Change contents

edit in aftok.cabal at line 53

[3.157]→[3.157:206](∅→∅)

--, network-bitcoin >= 1.8 && < 1.9
edit in aftok.cabal at line 84

[3.1115]

[3.36]

, HUnit
edit in aftok.cabal at line 88

[3.1651]→[3.53:75](∅→∅)

, network-bitcoin
replacement in lib/Aftok/Auction.hs at line 8

[3.96]→[3.96:135](∅→∅)

import Data.Thyme.Clock as C

[3.96]

[2.3]

import Data.Thyme.Clock as C
edit in lib/Aftok/Auction.hs at line 35

[3.276]

[3.3]

data AuctionResult
= WinningBids [Bid]
| InsufficientBids Satoshi
deriving (Show, Eq)

bidsTotal :: [Bid] -> Satoshi
bidsTotal bids =
foldl' (\s b -> s + (b^.bidAmount)) (Satoshi 0) bids
replacement in lib/Aftok/Auction.hs at line 53

[3.328]→[3.328:369](∅→∅),[3.369]→[3.3:64](∅→∅)

winningBids :: Auction -> [Bid] -> [Bid]
winningBids auction = winningBids' (auction ^. raiseAmount)

[3.328]

[3.64]

runAuction :: Auction -> [Bid] -> AuctionResult
runAuction auction = runAuction' (auction ^. raiseAmount)
replacement in lib/Aftok/Auction.hs at line 56

[3.65]→[3.65:141](∅→∅)

winningBids' :: Satoshi -> [Bid] -> [Bid]
winningBids' raiseAmount' bids =

[3.65]

[3.323]

runAuction' :: Satoshi -> [Bid] -> AuctionResult
runAuction' raiseAmount' bids =
replacement in lib/Aftok/Auction.hs at line 75

[3.1147]→[3.210:257](∅→∅)

in takeWinningBids 0 $ sortBy bidOrder bids

[3.1147]

submittedTotal = bidsTotal bids
in if submittedTotal >= raiseAmount'
then WinningBids $ takeWinningBids 0 $ sortBy bidOrder bids
else InsufficientBids (raiseAmount' - submittedTotal)
replacement in test/Aftok/AuctionSpec.hs at line 1

[3.89]→[3.90:117](∅→∅)

{-# OPTIONS_GHC -Wwarn #-}

[3.89]

[3.117]

{-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-}
replacement in test/Aftok/AuctionSpec.hs at line 13

[3.309]→[2.574:615](∅→∅)

--import Data.Thyme.Clock as C

[3.309]

[3.309]

import Data.Thyme.Clock ()
replacement in test/Aftok/AuctionSpec.hs at line 15

[3.336]→[2.616:650](∅→∅)

import Text.Read (read)

[3.336]

[3.336]

import Text.Read (read)
replacement in test/Aftok/AuctionSpec.hs at line 18

[3.365]→[2.651:686](∅→∅)

--import Test.QuickCheck

[3.365]

[3.398]

import Test.HUnit.Base (assertFailure)
import Test.QuickCheck

uuidGen :: Gen UUID
uuidGen = fromWords <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary

genSatoshi :: Gen Satoshi
genSatoshi = Satoshi <$> arbitrary

genBid :: Gen Bid
genBid = Bid <$> (UserId <$> uuidGen)
<*> (Seconds <$> arbitrary `suchThat` (>= 0))
<*> genSatoshi `suchThat` (> Satoshi 0)
<*> arbitrary
replacement in test/Aftok/AuctionSpec.hs at line 34

[3.412]→[2.687:695](∅→∅)

spec =

[3.412]

[2.695]

spec =
replacement in test/Aftok/AuctionSpec.hs at line 40

[2.1190]→[2.1190:1199](∅→∅)

in do

[2.1190]

[2.1199]

in do
replacement in test/Aftok/AuctionSpec.hs at line 52

[2.1580]→[2.1580:1852](∅→∅)

let winners = winningBids' (Satoshi 1250) [testB0, testB1, testB2, testB3, testB4]
split = Bid (UserId nil) (Seconds 30) (Satoshi 50) (testB4 ^. bidTime)
in sortBy bidOrder winners `shouldBe` sortBy bidOrder [testB0, testB1, testB2, split]

[2.1580]

[3.839]

let result = runAuction' (Satoshi 1250) [testB0, testB1, testB2, testB3, testB4]
split = Bid (UserId nil) (Seconds 30) (Satoshi 50) (testB4 ^. bidTime)
expected = sortBy bidOrder [testB0, testB1, testB2, split]
in case result of
WinningBids winners ->
sortBy bidOrder winners `shouldBe` expected

InsufficientBids t ->
assertFailure "Sufficinent bids were presented, but auction algorithm asserted otherwise."
edit in test/Aftok/AuctionSpec.hs at line 62

[3.840]

[3.840]

it "ensures that the raise amount is fully consumed by the winning bids" $
forAll ((,) <$> genSatoshi <*> listOf genBid) $
\(raiseAmount', bids) ->
case runAuction' raiseAmount' bids of
WinningBids xs -> bidsTotal xs == raiseAmount'
InsufficientBids t -> t == (raiseAmount' - bidsTotal bids)
replacement in test/Aftok/TimeLogSpec.hs at line 24

[3.3401]→[3.3401:3434](∅→∅),[3.3434]→[3.1907:1962](∅→∅)

instance Arbitrary BtcAddr where
arbitrary = BtcAddr . pack <$> vectorOf 34 arbitrary

[3.3280]

[3.2088]

genBtcAddr :: Gen BtcAddr
genBtcAddr =
BtcAddr . pack <$> vectorOf 34 arbitrary
replacement in test/Aftok/TimeLogSpec.hs at line 28

[3.2089]→[3.3492:3543](∅→∅),[3.3543]→[3.1963:1990](∅→∅),[3.1990]→[3.1190:1315](∅→∅)

instance Arbitrary Interval where
arbitrary = do
startTime <- arbitrary
delta <- arbitrary :: Gen (Positive T.NominalDiffTime)
pure $ I.interval startTime (startTime .+^ getPositive delta)

[3.2089]

[3.3479]

genInterval :: Gen I.Interval
genInterval = do
startTime <- arbitrary
delta <- arbitrary :: Gen (Positive T.NominalDiffTime)
pure $ I.interval startTime (startTime .+^ getPositive delta)
replacement in test/Aftok/TimeLogSpec.hs at line 34

[3.3480]→[3.3480:3532](∅→∅)

newtype Intervals = Intervals (L.NonEmpty Interval)

[3.3480]

[3.3532]

genIntervals :: Gen (L.NonEmpty I.Interval)
genIntervals =
let deltas = fmap T.fromSeconds <$> ((listOf $ choose (0, 72 * 60 * 60)) :: Gen[Int])
replacement in test/Aftok/TimeLogSpec.hs at line 38

[3.3533]→[3.3533:3596](∅→∅),[3.3596]→[3.12561:12637](∅→∅),[3.12637]→[3.94:145](∅→∅),[3.3666]→[3.94:145](∅→∅),[3.145]→[3.3723:3800](∅→∅),[3.3723]→[3.3723:3800](∅→∅)

buildIntervals :: T.UTCTime -> [NominalDiffTime] -> [Interval]
buildIntervals t (d : s : dx) | d > 0 =
let ival = I.interval t (t .+^ d)
in ival : buildIntervals (ival ^. end .+^ s) dx
buildIntervals _ _ = []

instance Arbitrary Intervals where
arbitrary = do

[3.3533]

[3.12638]

buildIntervals :: T.UTCTime -> [NominalDiffTime] -> [I.Interval]
buildIntervals t (d : s : dx) | d > 0 =
let ival = I.interval t (t .+^ d)
in ival : buildIntervals (ival ^. I.end .+^ s) dx
buildIntervals _ _ = []
in do
edit in test/Aftok/TimeLogSpec.hs at line 45

[3.12665]→[3.146:236](∅→∅),[3.3828]→[3.146:236](∅→∅)

let deltas = fmap T.fromSeconds <$> ((listOf $ choose (0, 72 * 60 * 60)) :: Gen[Int])
replacement in test/Aftok/TimeLogSpec.hs at line 46

[3.3954]→[3.3954:3998](∅→∅)

pure . Intervals $ L.fromList intervals

[3.3954]

[3.2045]

pure $ L.fromList intervals
replacement in test/Aftok/TimeLogSpec.hs at line 48

[3.2046]→[3.2046:2081](∅→∅),[3.2081]→[3.12666:12718](∅→∅),[3.12718]→[3.4038:4126](∅→∅),[3.4038]→[3.4038:4126](∅→∅),[3.4126]→[3.2170:2219](∅→∅),[3.2170]→[3.2170:2219](∅→∅)

instance Arbitrary WorkIndex where
arbitrary =
let record = do addr <- arbitrary
Intervals ivals <- arbitrary
pure (addr, ivals)
in WorkIndex . M.fromList <$> listOf record

[3.2046]

[3.2219]

genWorkIndex :: Gen WorkIndex
genWorkIndex =
let record = do addr <- genBtcAddr
ivals <- genIntervals
pure (addr, ivals)
in WorkIndex . M.fromList <$> listOf record
replacement in test/Aftok/TimeLogSpec.hs at line 88

[3.494]→[3.3388:3444](∅→∅),[3.3444]→[3.12877:12904](∅→∅),[3.12904]→[3.237:351](∅→∅),[3.1964]→[3.237:351](∅→∅)

it "recovers a work index from events" $ property $
\(WorkIndex widx) ->
let mergeAdjacent ((Interval s e) : (Interval s' e') : xs) | e == s' = mergeAdjacent $ Interval s e' : xs

[3.494]

[3.351]

it "recovers a work index from events" $
forAll genWorkIndex $ \(WorkIndex widx) ->
let mergeAdjacent ((I.Interval s e) : (I.Interval s' e') : xs) | e == s' = mergeAdjacent $ I.Interval s e' : xs