{-# 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 (RespMessage(..), RespExpr(..)) import qualified Data.ByteString.UTF8 as BSU import qualified Data.RESP as R3 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 RespMessage where arbitrary = QC.oneof [ RespPush <$> arbBs <*> arbitrary , RespReply <$> arbitrary ] shrink reply = case reply of RespPush a b -> RespPush <$> shrinkBs a <*> shrink b RespReply a -> RespReply <$> 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] encodeMessage :: RespMessage -> ByteString encodeMessage repl = BS.concat $ case repl of RespPush t msgs -> [">", showBs $ succ $ length msgs, eol, "$", showBs $ BS.length t, eol, t, eol] <> concatMap encodeExpr' msgs RespReply e -> encodeExpr' e parseExpr :: ByteString -> Either String RespExpr parseExpr = scanOnly R3.parseExpression parseMessage :: ByteString -> Either String RespMessage parseMessage = scanOnly R3.parseMessage 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" $ parseMessage ">1\r\n+test\r\n\r\n" @?= Right (RespPush "test" []) , testCase "simple message type" $ parseMessage ">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" $ parseMessage ">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 -> parseMessage (encodeMessage reply) === Right reply ]