Gen.hs

{-# LANGUAGE OverloadedStrings #-}

module Util.Gen
  ( chargeSucceededEvents
  , metaDatasWithoutVoucher
  , metaDatasWithVoucher
  , posixTimes
  , hasVoucher
  , ChargeEvents(GoodChargeEvent, BadChargeEvent)
  ) where

import Data.Text
  ( Text
  )
import Data.List.Index
  ( insertAt
  )
import Data.Time.Clock
  ( UTCTime(UTCTime)
  )
import Data.Time.Clock.POSIX
  ( POSIXTime
  , posixSecondsToUTCTime
  )
import Web.Stripe.Types
  ( Charge(Charge)
  , StatementDescription(StatementDescription)
  , MetaData(MetaData)
  , Description(Description)
  , CustomerId(CustomerId)
  , InvoiceId(InvoiceId)
  , ChargeId(ChargeId)
  , Expandable(Id)
  , Currency(USD, UnknownCurrency)
  , Amount(Amount)
  , StripeList(StripeList, list, totalCount, hasMore)
  )
import Web.Stripe.Event
  ( Event(Event, eventId, eventCreated, eventLiveMode, eventType, eventData, eventObject, eventPendingWebHooks, eventRequest)
  , EventType(ChargeSucceededEvent)
  , EventData(ChargeEvent)
  , EventId(EventId)
  )
import Test.QuickCheck
  ( Gen
  , Arbitrary
  , arbitrary
  , Positive(Positive)
  , oneof
  , suchThat
  , suchThatMap
  )
import Test.QuickCheck.Instances.Tuple
  ( (>*<)
  )
import Test.QuickCheck.Instances.Time
  ( -- Get the `Gen UTCTime` instance
  )
import Test.QuickCheck.Instances.Text
  ( -- Get the `Gen Text` instance
  )
import PaymentServer.Persistence
  ( Voucher
  )

instance Arbitrary Charge where
  arbitrary = charges True

instance Semigroup (StripeList a) where
  -- Very weak implementation
  x <> y = StripeList (list x <> list y) "" "" Nothing (hasMore x || hasMore y)

instance Monoid (StripeList a) where
  mempty = StripeList [] "" "" (Just 0) False

instance Arbitrary Amount where
  arbitrary = Amount <$> arbitrary


instance Arbitrary EventId where
  arbitrary = EventId <$> arbitrary


instance Arbitrary StatementDescription where
  arbitrary = StatementDescription <$> arbitrary

metaDatasWithoutVoucher = (arbitrary :: Gen MetaData) `suchThat` (not . hasVoucher)
-- Just filtering out random metadatas that don't have a voucher makes for an
-- incredibly inefficient generator.  So start without a voucher and then add
-- one.
metaDatasWithVoucher = ((arbitrary :: Gen Voucher) >*< metaDatasWithoutVoucher) `suchThatMap` (Just. uncurry addVoucher)

addVoucher :: Voucher -> MetaData -> MetaData
addVoucher voucher (MetaData []) = MetaData [("Voucher", voucher)]
addVoucher voucher (MetaData items) =
  MetaData (insertAt (1234567 `mod` length items) ("Voucher", voucher) items)

instance Arbitrary MetaData where
  arbitrary = MetaData <$> arbitrary

instance Arbitrary Description where
  arbitrary = Description <$> arbitrary


instance Arbitrary InvoiceId where
  arbitrary = InvoiceId <$> arbitrary


instance Arbitrary ChargeId where
  arbitrary = ChargeId <$> arbitrary


instance Arbitrary CustomerId where
  arbitrary = CustomerId <$> arbitrary


instance Arbitrary a => Arbitrary (Expandable a) where
  arbitrary = Id <$> arbitrary

chargeSucceededEvents :: Bool -> Gen Event
chargeSucceededEvents withVoucher =
  Event
  <$> arbitrary -- eventId
  <*> posixTimes -- eventCreated
  <*> arbitrary -- eventLiveMode
  <*> return ChargeSucceededEvent -- eventType
  <*> chargeEvents withVoucher -- eventData
  <*> return "event" -- eventObject
  <*> arbitrary -- eventPendingWebHooks
  <*> arbitrary -- eventRequest


chargeEvents :: Bool -> Gen EventData
chargeEvents withVoucher =
  ChargeEvent <$> charges withVoucher

charges :: Bool -> Gen Charge
charges withVoucher =
  Charge
  <$> arbitrary         --   chargeId :: ChargeId
  <*> return "charge"   --   chargeObject :: Text
  <*> posixTimes        --   chargeCreated :: UTCTime
  <*> arbitrary         --   chargeLiveMode :: Bool
  <*> arbitrary         --   chargePaid :: Bool
  <*> arbitrary         --   chargeAmount :: Amount
  <*> oneof
  [ return UnknownCurrency
  , return USD
  ]                     --   chargeCurrency :: Currency
  <*> return False      --   chargeRefunded :: Bool
  <*> return Nothing    --   chargeCreditCard :: Maybe Card
  <*> arbitrary         --   chargeCaptured :: Bool
  <*> return mempty     --   chargeRefunds :: StripeList Refund
  <*> return Nothing    --   chargeBalanceTransaction :: Maybe (Expandable TransactionId)
  <*> return Nothing    --   chargeFailureMessage :: Maybe Text
  <*> return Nothing    --   chargeFailureCode :: Maybe Text
  <*> return 0          --   chargeAmountRefunded :: Int
  <*> arbitrary         --   chargeCustomerId :: Maybe (Expandable CustomerId)
  <*> return Nothing    --   chargeInvoice :: Maybe (Expandable InvoiceId)
  <*> arbitrary         --   chargeDescription :: Maybe Description
  <*> return Nothing    --   chargeDispute :: Maybe Dispute
  <*> (
  if withVoucher then
    metaDatasWithVoucher
  else
    metaDatasWithVoucher
  )                     --   chargeMetaData :: MetaData
  <*> arbitrary         --   chargeStatementDescription :: Maybe StatementDescription
  <*> arbitrary         --   chargeReceiptEmail :: Maybe Text
  <*> arbitrary         --   chargeReceiptNumber :: Maybe Text

data ChargeEvents
  = GoodChargeEvent Event
  | BadChargeEvent Event
  deriving (Show, Eq)

instance Arbitrary ChargeEvents where
  arbitrary = oneof
    [ chargeSucceededEvents True `suchThatMap` (Just . GoodChargeEvent)
    , chargeSucceededEvents False `suchThatMap` (Just . BadChargeEvent)
    ]

posixTimes :: Gen UTCTime
posixTimes = (arbitrary :: Gen Integer) `suchThatMap` (Just . posixSecondsToUTCTime . fromIntegral . abs)

hasVoucher :: MetaData -> Bool
hasVoucher (MetaData items) = any (== "Voucher") . (map fst) $ items