{-# LANGUAGE NegativeLiterals    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Pinch.Protocol.CompactSpec (spec) where

import Data.ByteString       (ByteString)
import Data.Word             (Word8)
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck

import qualified Data.ByteString as B

import Pinch.Arbitrary        ()
import Pinch.Internal.Builder (runBuilder)
import Pinch.Internal.Message
import Pinch.Internal.TType
import Pinch.Internal.Util
import Pinch.Internal.Value   (SomeValue (..), Value (..))
import Pinch.Protocol
import Pinch.Protocol.Compact (compactProtocol)


serialize :: IsTType a => Value a -> ByteString
serialize = runBuilder . serializeValue compactProtocol


deserialize :: IsTType a => ByteString -> Either String (Value a)
deserialize = deserializeValue compactProtocol


serializeMsg :: Message -> ByteString
serializeMsg = runBuilder . serializeMessage compactProtocol

deserializeMsg :: ByteString -> Either String Message
deserializeMsg = deserializeMessage compactProtocol


-- | For each given pair, verifies that parsing the byte array yields the
-- value, and that serializing the value yields the byte array.
readWriteCases :: IsTType a => [([Word8], Value a)] -> Expectation
readWriteCases = mapM_ . uncurry $ \bytes value -> do
    let bs = B.pack bytes
    deserialize bs  `shouldBe` Right value
    serialize value `shouldBe` bs


readWriteMessageCases :: [([Word8], Message)] -> Expectation
readWriteMessageCases = mapM_ . uncurry $ \bytes msg -> do
    let bs = B.pack bytes
    deserializeMsg bs  `shouldBe` Right msg
    serializeMsg msg `shouldBe` bs


-- | For each pair, verifies that if the given TType is parsed, the request
-- fails to parse because the type ID was invalid.
invalidTypeIDCases :: [(SomeTType, [Word8])] -> Expectation
invalidTypeIDCases = mapM_ . uncurry $ \(SomeTType t) v -> go t v
  where
    go :: forall a. IsTType a => TType a -> [Word8] -> Expectation
    go _ bytes =
        case deserialize (B.pack bytes) :: Either String (Value a) of
            Right v -> expectationFailure $
              "Expected " ++ show bytes ++ " to fail to parse. " ++
              "Got: " ++ show v
            Left msg -> msg `shouldContain` "Unknown CType"


-- | For each pair, verifies that if the given TType is parsed, the request
-- fails to parse because the input was too short.
tooShortCases :: [(SomeTType, [Word8])] -> Expectation
tooShortCases = mapM_ . uncurry $ \(SomeTType t) v -> go t v
  where
    go :: forall a. IsTType a => TType a -> [Word8] -> Expectation
    go _ bytes =
        case deserialize (B.pack bytes) :: Either String (Value a) of
            Right v -> expectationFailure $
              "Expected " ++ show bytes ++ " to fail to parse. " ++
              "Got: " ++ show v
            Left msg -> msg `shouldContain` "too few bytes"


spec :: Spec
spec = describe "CompactProtocol" $ do

    prop "can roundtrip values" $ \(SomeValue someVal) ->
        deserialize (serialize someVal) === Right someVal

    prop "can roundtrip messages" $ \(msg :: Message) ->
        deserializeMsg (serializeMsg msg) == Right msg

    it "can read and write booleans" $ readWriteCases
        [ ([0x01], vbool True)
        , ([0x02], vbool False)
        ]

    it "can read and write binary" $ readWriteCases
        [ ([ 0x00 ], vbin "")
        , ([ 0x05                          -- length = 5
           , 0x68, 0x65, 0x6c, 0x6c, 0x6f  -- hello
           ], vbin "hello")
        ]

    it "can read and write 8-bit integers" $ readWriteCases
        [ ([0x01], vbyt 1)
        , ([0x05], vbyt 5)
        , ([0x7f], vbyt 127)
        , ([0xff], vbyt -1)
        , ([0x80], vbyt -128)
        ]

    it "can read and write 16-bit integers" $ readWriteCases
        [ ([0x02],             vi16 1)
        , ([0xfe, 0x03],       vi16 255)
        , ([0x80, 0x04],       vi16 256)
        , ([0x82, 0x04],       vi16 257)
        , ([0xfe, 0xff, 0x03], vi16 32767)
        , ([0x01],             vi16 -1)
        , ([0x03],             vi16 -2)
        , ([0xff, 0x03],       vi16 -256)
        , ([0xfd, 0x03],       vi16 -255)
        , ([0xff, 0xff, 0x03], vi16 -32768)
        ]

    it "can read and write 32-bit integers" $ readWriteCases
        [ ([0x02],                         vi32 1)
        , ([0xfe, 0x03],                   vi32 255)
        , ([0xfe, 0xff, 0x07],             vi32 65535)
        , ([0xfe, 0xff, 0xff, 0x0f],       vi32 16777215)
        , ([0xfe, 0xff, 0xff, 0xff, 0x0f], vi32 2147483647)
        , ([0x01],                         vi32 -1)
        , ([0xff, 0x03],                   vi32 -256)
        , ([0xff, 0xff, 0x07],             vi32 -65536)
        , ([0xff, 0xff, 0xff, 0x0f],       vi32 -16777216)
        , ([0xff, 0xff, 0xff, 0xff, 0x0f], vi32 -2147483648)
        ]

    it "can read and write 64-bit integers" $ readWriteCases
        [ ([0x02],                                           vi64 1)
        , ([0xfe, 0xff, 0xff, 0xff, 0x1f],                   vi64 4294967295)
        , ([0xfe, 0xff, 0xff, 0xff, 0xff, 0x3f],             vi64 1099511627775)
        , ([0xfe, 0xff, 0xff, 0xff, 0xff, 0xff, 0x7f],       vi64 281474976710655)
        , ([0xfe, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x01], vi64 72057594037927935)
        , ([0xfe, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x01], vi64 9223372036854775807)
        , ([0x01],                                           vi64 -1)
        , ([0xff, 0xff, 0xff, 0xff, 0x1f],                   vi64 -4294967296)
        , ([0xff, 0xff, 0xff, 0xff, 0xff, 0x3f],             vi64 -1099511627776)
        , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x7f],       vi64 -281474976710656)
        , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x01], vi64 -72057594037927936)
        , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x01], vi64 -9223372036854775808)
        ]

    it "can read and write doubles" $ readWriteCases
        [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], vdub 0.0)
        , ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf0, 0x3f], vdub 1.0)
        , ([0x38, 0xdf, 0x06, 0x00, 0x00, 0x00, 0xf0, 0x3f], vdub 1.0000000001)
        , ([0x9a, 0x99, 0x99, 0x99, 0x99, 0x99, 0xf1, 0x3f], vdub 1.1)
        , ([0x9a, 0x99, 0x99, 0x99, 0x99, 0x99, 0xf1, 0xbf], vdub -1.1)
        , ([0x18, 0x2d, 0x44, 0x54, 0xfb, 0x21, 0x09, 0x40], vdub 3.141592653589793)
        , ([0x38, 0xdf, 0x06, 0x00, 0x00, 0x00, 0xf0, 0xbf], vdub -1.0000000001)
        ]

    it "can read and write structs" $ readWriteCases
        [ ([0x00], vstruct [])

        , ([ 0x15                    -- ttype = i32, field ID = 1
           , 0x54                    -- 42
           , 0x00                    -- stop
           ], vstruct [(1, vi32_ 42)])

        , ([ 0x11                    -- ttype = bool true, field ID = 1
           , 0x52                    -- ttype = bool false, field ID = 6
           , 0x23, 0x2a              -- ttype = byte, field ID = 8, byte 42
           , 0x03, 0x40, 0x2b        -- ttype = byte, field ID = 32, byte 42
           , 0x00                    -- stop
           ], vstruct [(1, vbool_ True), (6, vbool_ False), (8, vbyt_ 42), (32, vbyt_ 43)])

        , ([ 0x29                    -- ttype = list, field ID = 2
           , 0x28

           , 0x03, 0x66, 0x6f, 0x6f  -- "foo"
           , 0x03, 0x62, 0x61, 0x72  -- "bar"

           , 0x00                    -- stop
           ], vstruct
           [ (2, vlist_ [vbin "foo", vbin "bar"])
           ])
        ]

    it "can read and write maps" $ readWriteCases
        [ ([ 0x00
           ], vmap ([] :: [(Value TBool, Value TByte)]))
        , ([ 0x01, 0x89              -- ktype = binary, vtype = list

           -- "world"
           , 0x05                          -- length = 5
           , 0x77, 0x6f, 0x72, 0x6c, 0x64  -- world

           -- [1, 2, 3]
           , 0x33                          -- type = byte, count = 3
           , 0x01, 0x02, 0x03              -- 1, 2, 3
           ], vmap
           [ (vbin "world", vlist [vbyt 1, vbyt 2, vbyt 3])
           ])
        ]

    it "can read and write sets" $ readWriteCases
        [ ([0x01
           ], vset ([] :: [Value TBool]))
        , ([ 0x11, 0x01
           ], vset [vbool True])
        ]

    it "can read and write lists" $ readWriteCases
        [ ([0x01
           ], vlist ([] :: [Value TBool]))
        , ([ 0x51, 0x01, 0x02, 0x02
           , 0x01, 0x01
           ], vlist
               [ vbool True
               , vbool False
               , vbool False
               , vbool True
               , vbool True
               ])
        ]

    it "fails if the input is too short" $ tooShortCases
        [ (SomeTType TBool, [])
        , (SomeTType TByte, [])
        , (SomeTType TInt16, [])
        , (SomeTType TInt32, [])
        , (SomeTType TInt64, [])
        , (SomeTType TDouble, [0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07])
        , (SomeTType TBinary, [0x01])

        , (SomeTType TMap, [0x02])
        , (SomeTType TMap, [0x02, 0x33])
        , (SomeTType TMap, [0x02, 0x33, 0x01])

        , (SomeTType TSet, [0x2a])
        , (SomeTType TSet, [0x2a, 0x33, 0x00])

        , (SomeTType TList, [0x29])
        , (SomeTType TList, [0x29, 0x33])
        ]

    it "denies invalid type IDs" $ invalidTypeIDCases
        [ (SomeTType TStruct, [0x0d, 0x00, 0x01])
        , (SomeTType TMap, [0x1a, 0xd1, 0x00])
        , (SomeTType TSet, [0x1d])
        , (SomeTType TList, [0x1d])
        ]

    it "can read and write messages" $ readWriteMessageCases
        [ ([ 0x82                                   -- Protocol id
           , 0x21                                   -- Version and Type = Call
           , 0x2a                                   -- seqId = 42
           , 0x06                                   -- name length = 6
           , 0x67, 0x65, 0x74, 0x46, 0x6f, 0x6f     -- 'getFoo'
           , 0x00                                   -- stop
           ], Message "getFoo" Call 42 (vstruct []))
        , ([ 0x82                                   -- Protocol id
           , 0x41                                   -- Version and Type = Reply
           , 0x01                                   -- seqId = 01
           , 0x06                                   -- name length = 6
           , 0x73, 0x65, 0x74, 0x42, 0x61, 0x72     -- 'setBar'
           , 0x00                                   -- stop
           ], Message "setBar" Reply 1 (vstruct []))
        ]