content: {-# LANGUAGE FlexibleContexts           #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE MultiWayIf                 #-}
  {-# LANGUAGE RankNTypes                 #-}
  {-# LANGUAGE ScopedTypeVariables        #-}
  {-# LANGUAGE TypeFamilies               #-}
  {-# LANGUAGE TypeOperators              #-}
  {-# LANGUAGE UndecidableInstances       #-}
  module Tests.Boundary
    ( testTree -- :: TestTree
    ) where
  
  import qualified Data.ByteString as BS
  import qualified Data.ByteString.Lazy as BSL
  import           Data.Either
  import           Data.Int
  import           Data.Word
  import qualified Data.Text as T
  
  import           Codec.CBOR.Decoding
  import           Codec.CBOR.Encoding
  import           Codec.CBOR.Read
  import           Codec.CBOR.Write
  import           Tests.Util
  
  import           Test.Tasty
  import           Test.Tasty.QuickCheck
  
  
  -- | CBOR can represent 64 bit negative and positive integers, hence we need
  -- wrapper for Integer to represent the whole range.
  newtype Int65 = Int65 Integer
    deriving (Eq, Ord, Enum, Num, Integral, Real, Show)
  
  instance Bounded Int65 where
    maxBound = Int65 (2^(64 :: Int) - 1)
    minBound = Int65 (-2^(64 :: Int))
  
  instance Arbitrary Int65 where
    arbitrary = arbitraryBoundedIntegral
  
  encodeInt65 :: Int65 -> Encoding
  encodeInt65 (Int65 n) = encodeInteger n
  
  
  -- | Wrapper for bounded, integral type 'a' that potentially contains values
  -- outside of range of 'a'.
  newtype B a = B { unB :: BRep a }
  
  type family BRep a where
    BRep Word   = Word64
    BRep Word8  = Word64
    BRep Word16 = Word64
    BRep Word32 = Word64
    BRep Word64 = Word64
    BRep Int    = Int65
    BRep Int8   = Int64
    BRep Int16  = Int64
    BRep Int32  = Int64
    BRep Int64  = Int65
  
  instance Show (BRep a) => Show (B a) where
    showsPrec p = showsPrec p . unB
  
  instance (Arbitrary (BRep a), Num (BRep a), Bounded a, Integral a
           ) => Arbitrary (B a) where
    arbitrary = B <$> arbitraryWithBounds (undefined::a)
  
  -- | Check if deserialisation of values of type 'a' deals properly with the ones
  -- out of range, i.e. fails to decode them.
  boundaryTest
    :: forall a rep. (Bounded a, Integral a, Show a, rep ~ BRep a,
                      Ord rep, Num rep)
    => (rep -> Encoding)          -- ^ encode
    -> (forall s. Decoder s a)  -- ^ decode
    -> B a
    -> Property
  boundaryTest enc dec a = if outsideRange
                             then collect "outside" $ isLeft  a'
                             else collect "inside"  $ isRight a'
    where
      a' = deserialiseFromBytes dec . toLazyByteString . enc $ unB a
  
      -- Note that this is always true for a ~ rep.
      outsideRange = unB a < fromIntegral (minBound :: a)
                  || unB a > fromIntegral (maxBound :: a)
  
  mkBoundaryTest
    :: forall a rep. (Bounded a, Integral a, Show a, rep ~ BRep a,
                      Arbitrary rep, Ord rep, Show rep, Num rep)
    => String
    -> (rep -> Encoding)
    -> (forall s. Decoder s a)
    -> (forall s. Decoder s a)
    -> [TestTree]
  mkBoundaryTest aName enc dec decCan =
    [ testProperty aName                     $ boundaryTest enc dec
    , testProperty (aName ++ " (canonical)") $ boundaryTest enc decCan
    ]
  
  ----------------------------------------
  
  -- | Check if deserialisation of map/list length deals properly with the ones
  -- out of range, i.e. fails to decode them.
  lenBoundaryTest
    :: (Word -> Encoding)
    -> (forall s. Decoder s Int)
    -> Length
    -> Property
  lenBoundaryTest enc dec a = if outsideRange
                              then collect "outside" $ isLeft  a'
                              else collect "inside"  $ isRight a'
    where
      a' = deserialiseFromBytes dec . toLazyByteString . enc $ unLength a
  
      outsideRange = fromIntegral (unLength a) < (0::Int)
  
  mkLenBoundaryTest
    :: String
    -> (Word -> Encoding)
    -> (forall s. Decoder s Int)
    -> (forall s. Decoder s Int)
    -> [TestTree]
  mkLenBoundaryTest aName enc dec decCan =
    [ testProperty aName                     $ lenBoundaryTest enc dec
    , testProperty (aName ++ " (canonical)") $ lenBoundaryTest enc decCan
    ]
  
  ----------------------------------------
  
  data StringLengthPrefix = StringLP Word BSL.ByteString
    deriving Show
  instance Arbitrary StringLengthPrefix where
    arbitrary = (\l -> StringLP (unLength l) (mkLengthPrefix True l)) <$> arbitrary
  
  data BytesLengthPrefix = BytesLP Word BSL.ByteString
    deriving Show
  instance Arbitrary BytesLengthPrefix where
    arbitrary = (\l -> BytesLP (unLength l) (mkLengthPrefix False l)) <$> arbitrary
  
  -- | Test that positive length prefixes of string/bytes are parsed successfully,
  -- whereas negative are not.
  stringBytesBoundaryTest :: [TestTree]
  stringBytesBoundaryTest =
    [ testProperty "String" $ \(StringLP w bs) ->
        case deserialiseFromBytes decodeString bs of
          Right (_rest, string)           -> w == 0 && T.length string == 0
          Left (DeserialiseFailure _ msg) -> if fromIntegral w < (0::Int)
                                             then msg == "expected string"
                                             else msg == "end of input"
    , testProperty "Bytes" $ \(BytesLP w bs) ->
        case deserialiseFromBytes decodeBytes bs of
          Right (_rest, bytes)            -> w == 0 && BS.length bytes == 0
          Left (DeserialiseFailure _ msg) -> if fromIntegral w < (0::Int)
                                             then msg == "expected bytes"
                                             else msg == "end of input"
    ]
  
  ----------------------------------------
  
  testTree :: TestTree
  testTree = localOption (QuickCheckTests 1000) . testGroup "Boundary checks" $ concat
    [ mkBoundaryTest "Word"    encodeWord64  decodeWord    decodeWordCanonical
    , mkBoundaryTest "Word8"   encodeWord64  decodeWord8   decodeWord8Canonical
    , mkBoundaryTest "Word16"  encodeWord64  decodeWord16  decodeWord16Canonical
    , mkBoundaryTest "Word32"  encodeWord64  decodeWord32  decodeWord32Canonical
    , mkBoundaryTest "Word64"  encodeWord64  decodeWord64  decodeWord64Canonical
    , mkBoundaryTest "Int"     encodeInt65   decodeInt     decodeIntCanonical
    , mkBoundaryTest "Int8"    encodeInt64   decodeInt8    decodeInt8Canonical
    , mkBoundaryTest "Int16"   encodeInt64   decodeInt16   decodeInt16Canonical
    , mkBoundaryTest "Int32"   encodeInt64   decodeInt32   decodeInt32Canonical
    , mkBoundaryTest "Int64"   encodeInt65   decodeInt64   decodeInt64Canonical
  
    , mkLenBoundaryTest "ListLen" encodeListLen decodeListLen decodeListLenCanonical
    , mkLenBoundaryTest "MapLen"  encodeMapLen  decodeMapLen  decodeMapLenCanonical
  
    , stringBytesBoundaryTest
    ]
  