resp-1.0.0: test/Main.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
#if !MIN_VERSION_base(4,8,0)
import Data.Functor
import Control.Applicative
#endif
#if !MIN_VERSION_base(4,11,0)
# if MIN_VERSION_base(4,9,0)
import Data.Semigroup
import Data.Monoid (mempty)
# else
import Data.Monoid ((<>), mempty)
# endif
#endif
import Data.ByteString (ByteString)
import Data.RESP (RespReply(..), RespExpr(..))
import qualified Data.ByteString.UTF8 as BSU
import qualified Data.RESP as R3
-- import qualified Data.Text.Encoding as T
-- import qualified Data.Text as T
-- import Data.Text (Text)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import Scanner
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck (testProperty, Arbitrary(..), Gen, (===))
import qualified Test.Tasty.QuickCheck as QC
arbText :: Gen ByteString
arbText = BSU.fromString <$> arbitrary
arbBs :: Gen ByteString
arbBs = BS.pack <$> arbitrary
arbBsl :: Gen BSL.ByteString
arbBsl = BSL.pack <$> arbitrary
shrinkBs :: ByteString -> [ByteString]
shrinkBs = fmap BS.pack . shrink . BS.unpack
shrinkBsl :: BSL.ByteString -> [BSL.ByteString]
shrinkBsl = fmap BSL.pack . shrink . BSL.unpack
halfArbitrary :: Arbitrary a => Int -> Gen a
halfArbitrary n = QC.resize (n `div` 2) arbitrary
genLine :: Gen ByteString
genLine = fmap BSU.fromString $ QC.listOf $ QC.suchThat arbitrary (not . (`elem` ("\r\n" :: String)))
-- If you want access to this instance, please make a PR
-- to create a cabal sublibrary called `resp-quickcheck`.
-- This will avoid adding `quickcheck` as a dependency of
-- the main `resp` library.
instance Arbitrary RespExpr where
arbitrary = QC.sized $ \n -> case n of
_ | n <= 1 -> QC.oneof
[ RespString <$> genLine
, RespBlob <$> arbBs
, RespStreamingBlob <$> arbBsl
, RespStringError <$> genLine
, RespBlobError <$> arbBs
, RespInteger <$> arbitrary
, pure RespNull
, RespBool <$> arbitrary
, RespDouble <$> arbitrary
, RespVerbatimString <$> arbText
, RespVerbatimMarkdown <$> arbText
, RespBigInteger <$> arbitrary
]
_ -> QC.oneof
[ RespString <$> genLine
, RespBlob <$> arbBs
, RespStreamingBlob <$> arbBsl
, RespStringError <$> genLine
, RespBlobError <$> arbBs
, RespInteger <$> arbitrary
, pure RespNull
, RespBool <$> arbitrary
, RespDouble <$> arbitrary
, RespVerbatimString <$> arbText
, RespVerbatimMarkdown <$> arbText
, RespBigInteger <$> arbitrary
, RespArray <$> halfArbitrary n
, RespMap <$> halfArbitrary n
, RespSet <$> halfArbitrary n
, RespAttribute <$> halfArbitrary n <*> halfArbitrary n
]
shrink expr = case expr of
RespString a -> RespString <$> shrinkBs a
RespBlob a -> RespBlob <$> shrinkBs a
RespStreamingBlob a -> RespStreamingBlob <$> shrinkBsl a
RespStringError a -> RespStringError <$> shrinkBs a
RespBlobError a -> RespBlobError <$> shrinkBs a
RespArray a -> RespArray <$> shrink a
RespInteger a -> RespInteger <$> shrink a
RespBool a -> RespBool <$> shrink a
RespDouble a -> RespDouble <$> shrink a
RespVerbatimString a -> RespVerbatimString <$> shrinkBs a
RespVerbatimMarkdown a -> RespVerbatimMarkdown <$> shrinkBs a
RespBigInteger a -> RespBigInteger <$> shrink a
RespMap a -> RespMap <$> shrink a
RespSet a -> RespSet <$> shrink a
RespNull -> []
RespAttribute a b -> RespAttribute <$> shrink a <*> shrink b
instance Arbitrary RespReply where
arbitrary = QC.oneof
[ RespPush <$> arbBs <*> arbitrary
, RespExpr <$> arbitrary
]
shrink reply = case reply of
RespPush a b -> RespPush <$> shrinkBs a <*> shrink b
RespExpr a -> RespExpr <$> shrink a
showBs :: Show a => a -> ByteString
showBs = BSU.fromString . show
eol :: ByteString
eol = "\r\n"
toStrictBs :: BSL.ByteString -> ByteString
toStrictBs = BS.concat . BSL.toChunks
encodeExpr :: RespExpr -> ByteString
encodeExpr = BS.concat . encodeExpr'
encodeExpr' :: RespExpr -> [ByteString]
encodeExpr' e = case e of
RespString txt -> ["+", txt, eol]
RespBlob bs -> ["$", showBs $ BS.length bs, eol, bs, eol]
RespStreamingBlob bs
| BSL.null bs -> ["$?\r\n;0\r\n"]
| otherwise -> ["$?\r\n", ";", showBs $ BSL.length bs, eol, toStrictBs bs, "\r\n;0\r\n"]
RespStringError txt -> ["-", txt, eol]
RespBlobError bs -> ["!", showBs $ BS.length bs, eol, bs, eol]
RespArray els -> ["*", showBs $ length els, eol] <> concatMap encodeExpr' els
RespInteger n -> [":", showBs $ n, eol]
RespNull -> ["_\r\n"]
RespBool True -> ["#t\r\n"]
RespBool False -> ["#f\r\n"]
RespDouble n -> [",", showBs n, eol]
RespVerbatimString txt -> let bs = txt in
["=", showBs $ 4 + BS.length bs, eol, "txt:", bs, eol]
RespVerbatimMarkdown txt -> let bs = txt in
["=", showBs $ 4 + BS.length bs, eol, "mkd:", bs, eol]
RespBigInteger n -> ["(", showBs n, eol]
RespMap els -> ["%", showBs $ length els, eol] <> concatMap encodeTup els
RespSet els -> ["~", showBs $ length els, eol] <> concatMap encodeExpr' els
RespAttribute attrs expr ->
["|", showBs $ length attrs, eol] <> concatMap encodeTup attrs <> encodeExpr' expr
encodeTup :: (RespExpr, RespExpr) -> [ByteString]
encodeTup (a, b) = concatMap encodeExpr' [a, b]
encodeReply :: RespReply -> ByteString
encodeReply repl = BS.concat $ case repl of
RespPush t msgs -> [">", showBs $ succ $ length msgs, eol, "$", showBs $ BS.length t, eol, t, eol]
<> concatMap encodeExpr' msgs
RespExpr e -> encodeExpr' e
parseExpr :: ByteString -> Either String RespExpr
parseExpr = scanOnly R3.parseExpression
parseReply :: ByteString -> Either String RespReply
parseReply = scanOnly R3.parseReply
testStr :: ByteString -> ByteString -> Assertion
testStr bs expected = parseExpr bs @?= Right (RespString expected)
testStreamingBlob :: ByteString -> ByteString -> Assertion
testStreamingBlob bs expected = parseExpr bs @?= Right (RespStreamingBlob $ BSL.fromChunks [expected])
testArray :: ByteString -> [RespExpr] -> Assertion
testArray bs expected = parseExpr bs @?= Right (RespArray expected)
testDouble :: ByteString -> Double -> Assertion
testDouble bs d = parseExpr bs @?= Right (RespDouble d)
testDouble' :: ByteString -> (Double -> Assertion) -> Assertion
testDouble' bs f = case parseExpr bs of
Right (RespDouble d) -> f d
_ -> assertFailure "Expected to parse into a double"
blobProperties :: ByteString -> String -> (ByteString -> RespExpr) -> TestTree
blobProperties leader prefix constr = testProperty "quickcheck" $ \str -> let bs = BSU.fromString $ prefix <> str in
parseExpr (leader <> BS8.pack (show $ BS8.length bs) <> "\r\n" <> bs <> "\r\n") === Right (constr $ BS8.drop (length prefix) bs)
blobTestCases :: ByteString -> (ByteString -> RespExpr) -> [TestTree]
blobTestCases leader constr =
[ testCase "empty" $ parseExpr (leader <> "0\r\n\r\n") @?= Right (constr "")
, testCase "simple" $ parseExpr (leader <> "7\r\ntest me\r\n") @?= Right (constr "test me")
, testCase "multiline" $ parseExpr (leader <> "15\r\ntest me\r\nline 2\r\n") @?= Right (constr "test me\r\nline 2")
, testCase "unicode" $ parseExpr (leader <> "11\r\n( ͡° ͜ʖ ͡°)\r\n") @?= Right (constr "( ͡° ͜ʖ ͡°)")
, testCase "not enough bytes" $ parseExpr (leader <> "10\r\nhello\r\n") @?= Left "No more input"
, testCase "too many bytes" $ parseExpr (leader <> "2\r\nhello\r\n") @?= Left "Expected '\\r', but got 'l'"
, blobProperties leader "" constr
]
integerTestCases :: (Arbitrary a, Num a, Show a) => ByteString -> (a -> RespExpr) -> [TestTree]
integerTestCases prefix constr =
-- We currently parse a zero-digit integer as 0,
-- even though it's technically an invalid response
-- in the spec. Sometimes being lenient is efficient.
[ testCase "empty" $ parseExpr (prefix <> "\r\n") @?= Left "No more input"
, testCase "zero" $ parseExpr (prefix <> "0\r\n") @?= Right (constr 0)
, testCase "one" $ parseExpr (prefix <> "1\r\n") @?= Right (constr 1)
, testCase "forty-two" $ parseExpr (prefix <> "42\r\n") @?= Right (constr 42)
, testCase "forty-two" $ parseExpr (prefix <> "-42\r\n") @?= Right (constr (-42))
, testProperty "quickcheck" $ \i -> parseExpr (prefix <> BS8.pack (show i) <> "\r\n") == Right (constr i)
]
main :: IO ()
main = defaultMain $ testGroup "Tests"
[ testGroup "simple string"
[ testCase "empty string" $ testStr "+\r\n" ""
, testCase "nonempty string" $ testStr "+test me\r\n" "test me"
]
, testGroup "simple blobs" $ blobTestCases "$" RespBlob
, testGroup "blob errors" $ blobTestCases "!" RespBlobError
, testGroup "verbatim strings"
[ testGroup "text" $ pure $ blobProperties "=" "txt:" RespVerbatimString
, testGroup "markdown" $ pure $ blobProperties "=" "mkd:" RespVerbatimMarkdown
]
, testGroup "streaming blob parts"
[ testCase "empty" $ testStreamingBlob "$?\r\n;0\r\n\r\n" ""
, testCase "one-part" $ testStreamingBlob "$?\r\n;3\r\nwow\r\n;0\r\n" "wow"
, testCase "two-part" $ testStreamingBlob "$?\r\n;4\r\nhell\r\n;7\r\no world\r\n;0\r\n" "hello world"
, testCase "three-part" $ testStreamingBlob "$?\r\n;4\r\nhell\r\n;3\r\no w\r\n;4\r\norld\r\n;0\r\n" "hello world"
]
, testGroup "integer" $ integerTestCases ":" RespInteger
, testGroup "big integer" $ integerTestCases "(" RespBigInteger
, testGroup "null"
[ testCase "RESP2 bulk string null" $ parseExpr "$-1\r\n" @?= Right RespNull
]
, testGroup "array"
[ testCase "empty" $ parseExpr "*0\r\n" @?= Right (RespArray [])
, testCase "[hello, world]"
$ testArray
"*2\r\n$5\r\nhello\r\n$5\r\nworld\r\n"
[RespBlob "hello", RespBlob "world"]
, testCase "[1 .. 3]"
$ testArray
"*3\r\n:1\r\n:2\r\n:3\r\n"
$ RespInteger <$> [1..3]
, testCase "heterogeneous"
$ testArray
"*5\r\n:1\r\n:2\r\n:3\r\n:4\r\n$5\r\nhello\r\n"
$ map RespInteger [1..4] <> [RespBlob "hello"]
-- from website
, testCase "nested"
$ testArray
"*2\r\n*3\r\n:1\r\n:2\r\n:3\r\n*2\r\n+Hello\r\n-World\r\n"
$ RespArray <$> [RespInteger <$> [1..3], [RespString "Hello", RespStringError "World"]]
-- from markdown
, testCase "nested 2"
$ testArray
"*2\r\n*3\r\n:1\r\n$5\r\nhello\r\n:2\r\n#f\r\n"
[RespArray [RespInteger 1, RespBlob "hello", RespInteger 2], RespBool False]
-- website: "Null arrays"
, testCase "null" $ parseExpr "*-1\r\n" @?= Right RespNull
-- website: "Null elements in arrays"
, testCase "null element"
$ testArray
"*3\r\n$5\r\nhello\r\n$-1\r\n$5\r\nworld\r\n"
[RespBlob "hello", RespNull, RespBlob "world"]
-- from markdown spec
, testCase "streaming"
$ testArray
"*?\r\n:1\r\n:2\r\n:3\r\n.\r\n"
$ RespInteger <$> [1..3]
]
, testCase "null" $ parseExpr "_\r\n" @?= Right RespNull
, testGroup "boolean"
[ testCase "true" $ parseExpr "#t\r\n" @?= Right (RespBool True)
, testCase "false" $ parseExpr "#f\r\n" @?= Right (RespBool False)
]
, testGroup "double"
[ testCase "from int" $ testDouble ",42\r\n" 42
, testCase "with decimal pt" $ testDouble ",42.12\r\n" 42.12
, testCase "with exponent" $ testDouble ",42.12e2\r\n" 4212
, testCase "with positive exponent" $ testDouble ",42.12e+2\r\n" 4212
, testCase "negative with negative exponent" $ testDouble ",-42.12e-2\r\n" (-0.4212)
, testCase "inf" $ testDouble' ",inf\r\n" $ assertBool "is infinite" . isInfinite
, testCase "-inf" $ testDouble' ",-inf\r\n" $ \d -> do
assertBool "is infinite" $ isInfinite d
assertBool "== negate (1/0)" $ d == negate (1 / 0)
, testCase "nan" $ testDouble' ",nan\r\n" $ assertBool "is NaN" . isNaN
-- Looks like we can also parse all `show`n doubles
, testProperty "quickcheck" $ \d -> parseExpr ("," <> BS8.pack (show d) <> "\r\n") == Right (RespDouble d)
]
, testGroup "map"
[ testCase "empty" $ parseExpr "%0\r\n" @?= Right (RespMap [])
, testCase "simple" $ parseExpr "%2\r\n+first\r\n:1\r\n+second\r\n:2\r\n"
@?= Right (RespMap [(RespString "first", RespInteger 1), (RespString "second", RespInteger 2)])
, testGroup "streamed"
[ testCase "empty" $ parseExpr "%?\r\n.\r\n" @?= Right (RespMap [])
, testCase "streamed" $ parseExpr "%?\r\n+a\r\n:1\r\n+b\r\n:2\r\n.\r\n"
@?= Right (RespMap [(RespString "a", RespInteger 1), (RespString "b", RespInteger 2)])
]
]
, testGroup "set"
[ testCase "empty" $ parseExpr "~0\r\n" @?= Right (RespSet [])
, testCase "nonempty" $ parseExpr "~5\r\n+orange\r\n+apple\r\n#t\r\n:100\r\n:999\r\n"
@?= Right (RespSet [RespString "orange", RespString "apple", RespBool True, RespInteger 100, RespInteger 999])
, testGroup "streamed"
[ testCase "empty" $ parseExpr "~?\r\n.\r\n" @?= Right (RespSet [])
, testCase "streamed" $ parseExpr "~?\r\n+a\r\n:1\r\n+b\r\n:2\r\n.\r\n"
@?= Right (RespSet [RespString "a", RespInteger 1, RespString "b", RespInteger 2])
]
]
, testGroup "attribute"
[ testCase "empty" $ parseExpr "~0\r\n" @?= Right (RespSet [])
-- from markdown spec
, testCase "nonempty" $ parseExpr "|1\r\n+key-popularity\r\n%2\r\n$1\r\na\r\n,0.1923\r\n$1\r\nb\r\n,0.0012\r\n*2\r\n:2039123\r\n:9543892\r\n"
@?= Right (
RespAttribute
[ ( RespString "key-popularity"
, RespMap
[ ( RespBlob "a"
, RespDouble 0.1923
)
, ( RespBlob "b"
, RespDouble 0.0012
)
]
)
]
(RespArray
[ RespInteger 2039123
, RespInteger 9543892
])
)
]
, testGroup "push"
-- from markdown spec
[ testCase "empty" $ parseReply ">1\r\n+test\r\n\r\n" @?= Right (RespPush "test" [])
, testCase "simple message type" $ parseReply ">3\r\n+message\r\n+somechannel\r\n+this is the message\r\n"
@?= Right (RespPush "message" [RespString "somechannel", RespString "this is the message"])
, testCase "blob string els" $ parseReply ">3\r\n$7\r\nmessage\r\n$6\r\nsecond\r\n$5\r\nHello\r\n"
@?= Right (RespPush "message" [RespBlob "second", RespBlob "Hello"])
]
, testProperty "roundtrip expr" $ \ex -> parseExpr (encodeExpr ex) === Right ex
, testProperty "roundtrip reply" $ \reply -> parseReply (encodeReply reply) === Right reply
]