diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for resp + +## 1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +BSD 3-Clause License + +Copyright (c) 2024, Owen Shepherd + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +# resp + +[![GHC version badge](https://img.shields.io/badge/ghc-%3E%3D7.4.2-blue?logo=haskell)](https://www.haskell.org/) [![CI status badge](https://img.shields.io/github/actions/workflow/status/414owen/resp/haskell-ci.yml)](https://github.com/414owen/neresp/actions/workflows/haskell-ci.yml) [![Hackage version badge](https://img.shields.io/hackage/v/resp)](https://hackage.haskell.org/package/resp) [![license](https://img.shields.io/github/license/414owen/resp)](https://github.com/414owen/resp/blob/master/LICENSE) + +This is a [RESP3](https://redis.io/docs/reference/protocol-spec/) parser, +implemented as a non-backtracking incremental scanner, using the +[`scanner`](https://hackage.haskell.org/package/scanner) library. + +It aims to parse valid RESP3 messages as fast as possible, with +very little emphasis on error messages. diff --git a/resp.cabal b/resp.cabal new file mode 100644 --- /dev/null +++ b/resp.cabal @@ -0,0 +1,59 @@ +cabal-version: 3.0 +name: resp +version: 1.0.0 +license: BSD-3-Clause +license-file: LICENSE +author: Owen Shepherd +maintainer: owen@owen.cafe +category: Data +build-type: Simple +synopsis : A fast, non-backtracking parser for the redis RESP3 protocol +description: RESP is redis' serialization protocol. This package provides a + lightweight and correct parser for RESP3, which can be used + incrementally (eg. over a network connection). +extra-doc-files: CHANGELOG.md + , README.md +tested-with: GHC==9.6.2 + , GHC==9.4.5 + , GHC==9.2.8 + , GHC==9.0.2 + , GHC==8.10.7 + , GHC==8.8.4 + , GHC==8.6.5 + , GHC==8.4.4 + , GHC==8.2.2 + , GHC==8.0.2 + , GHC==7.10.3 + , GHC==7.8.4 + , GHC==7.6.3 + , GHC==7.4.2 + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: Data.RESP + build-depends: base >=4.3 && <5 + , bytestring >= 0.9 && < 0.13 + , scanner >= 0.1 && < 0.4 + if(impl(ghc < 7.6)) + build-depends: ghc-prim > 0.1 && < 0.3 + hs-source-dirs: src + default-language: Haskell98 + +test-suite resp-test + import: warnings + default-language: Haskell98 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base >=4.3 && <5 + , bytestring >= 0.9 && < 0.13 + , QuickCheck >= 2.1 && < 3 + , resp + , scanner >= 0.1 && < 0.4 + , tasty >= 0.1 && < 1.6 + , tasty-hunit >= 0.1 && < 0.11 + , tasty-quickcheck >= 0.1 && < 0.11 + , utf8-string >= 0.3 && < 2 diff --git a/src/Data/RESP.hs b/src/Data/RESP.hs new file mode 100644 --- /dev/null +++ b/src/Data/RESP.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE ApplicativeDo #-} +#endif +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveGeneric #-} + +module Data.RESP + ( RespReply(..) + , RespExpr(..) + , parseReply + , parseExpression + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BSL +import qualified Scanner as Scanner + +#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.Char (digitToInt) +import Data.Int (Int64) +import Scanner (Scanner) +import Control.Monad (when, replicateM) +import GHC.Generics (Generic) + +-- This type synonym was introduced in bytestring 0.11.2.0 +type LazyByteString = BSL.ByteString + +#if MIN_VERSION_bytestring(0,10,0) +lazyBsToStrict :: LazyByteString -> ByteString +lazyBsToStrict = BSL.toStrict +#else +lazyBsToStrict :: LazyByteString -> ByteString +lazyBsToStrict = BS.concat . BSL.toChunks +#endif + +-- | Top-level resp reply. +-- Cannot be nested. +data RespReply + = RespPush !ByteString ![RespExpr] + | RespExpr !RespExpr + deriving (Show, Eq, Ord, Generic) + +-- | RESP3 Expression. +-- +-- This descriminates the difference between RespString and RespBlob, +-- even though both contain bytestrings, in order to not throw away +-- information. A caller might care whether the response was delivered +-- with "+", or "$". +-- +-- We do not, however descriminate between the different encodings of +-- null. As far as I can tell, these are considered a mistake in the +-- previous versions of the RESP spec, and clients should treat the +-- different encodings the same. +-- +-- Why don't we parse `RespString` into `Text`? Well, the caller might +-- not actually need to decode it into text, and so we let the caller +-- decide. This way, we don't have to deal with encoding errors. +-- +-- Similarly, we don't parse a `RespMap` into a `HashMap`, because +-- that would involve imposing our choice of data structure on the caller. +-- They might want to use `HashMap`, `Map`, or just use the `lookup` +-- function. +-- +-- Given these choices, our purview is simple: Parse the text protocol +-- into a Haskell datatype, maintaining all useful information, and not +-- imposing our taste onto the caller. +data RespExpr + = RespString !ByteString + | RespBlob !ByteString + | RespStreamingBlob !LazyByteString + | RespStringError !ByteString + | RespBlobError !ByteString + | RespArray ![RespExpr] + | RespInteger !Int64 + | RespNull + | RespBool !Bool + | RespDouble !Double + | RespVerbatimString !ByteString + | RespVerbatimMarkdown !ByteString + | RespBigInteger !Integer + | RespMap ![(RespExpr, RespExpr)] + | RespSet ![RespExpr] + | RespAttribute ![(RespExpr, RespExpr)] RespExpr + deriving (Show, Eq, Ord, Generic) + +data MessageSize + = MSVariable + | MSFixed Int + +data NullableMessageSize + = NMSVariable + | NMSMinusOne + | NMSFixed Int + +-- Top level RESP item +parseReply :: Scanner RespReply +parseReply = do + c <- Scanner.anyChar8 + case c of + '>' -> parsePush + _ -> RespExpr <$> parseExpression' c + +-- Non-top-level resp item +parseExpression :: Scanner RespExpr +parseExpression = Scanner.anyChar8 >>= parseExpression' + +-- Non-top-level resp item, taking its first char as a parameter +parseExpression' :: Char -> Scanner RespExpr +parseExpression' c = case c of + '$' -> parseBlob + '+' -> parseString + '-' -> parseStringError + ':' -> RespInteger <$> parseInteger + '*' -> parseArray RespArray + '_' -> RespNull <$ parseEol + '#' -> RespBool . (== 't') <$> Scanner.anyChar8 <* parseEol + ',' -> parseDouble + '!' -> parseBlobError + '=' -> parseVerbatimString + '(' -> RespBigInteger <$> parseInteger + '%' -> RespMap <$> parseMap + '~' -> parseArray RespSet + '|' -> RespAttribute <$> parseMap <*> parseExpression + _ -> fail $ "Unknown expression prefix: " <> show c + +parsePush :: Scanner RespReply +parsePush = do + len <- parseMessageSize + RespPush <$> parsePushType <*> replicateM (pred len) parseExpression + +parsePushType :: Scanner ByteString +parsePushType = do + c <- Scanner.anyChar8 + -- No idea whether this can be a simple string or not, + -- the spec isn't specific enough. + -- + -- The spec doesn't say that the push type *can't* be a + -- streamed blob string (or null), but let's face it, only a sadist would + -- return one of those. I'll try to get these possibilities excluded from + -- the spec, but in the meantime, we're going to have to parse all the + -- blobstrings. + case c of + '$' -> parseBlob' id lazyBsToStrict $ fail "Push message type can't be null" + '+' -> parseLine + _ -> fail "Invalid push message type" + +parseMap :: Scanner [(RespExpr, RespExpr)] +parseMap = do + len <- parseComplexMessageSize + case len of + MSFixed n -> replicateM n parseTwoEls + MSVariable -> parseVarMapPairs + +-- See https://github.com/redis/redis-specifications/blob/master/protocol/RESP3.md#streamed-aggregated-data-types +parseVarMapPairs :: Scanner [(RespExpr, RespExpr)] +parseVarMapPairs = do + c <- Scanner.anyChar8 + case c of + '.' -> [] <$ parseEol + _ -> (:) <$> ((,) <$> parseExpression' c <*> parseExpression) <*> parseVarMapPairs + +parseTwoEls :: Scanner (RespExpr, RespExpr) +parseTwoEls = (,) <$> parseExpression <*> parseExpression + +-- See: https://github.com/redis/redis-specifications/issues/25 +-- , https://github.com/redis/redis-specifications/issues/23 +parseVerbatimString :: Scanner RespExpr +parseVerbatimString = do + len <- parseMessageSize + entireBlob <- Scanner.take len + let body = BS8.drop 4 entireBlob + parseEol + case BS8.take 3 entireBlob of + "txt" -> pure $ RespVerbatimString body + "mkd" -> pure $ RespVerbatimMarkdown body + _ -> fail "Unknown verbatim string type" + +-- I suspect that this can't be streamed, or null +-- See: https://github.com/redis/redis-specifications/issues/23 +parseBlobError :: Scanner RespExpr +parseBlobError = do + len <- parseMessageSize + RespBlobError <$> Scanner.take len <* parseEol + +bsContains :: Char -> ByteString -> Bool +bsContains c = BS8.any (== c) + +-- Scanning to NaN is a function so that we don't +-- feel guilty about inlining the patterns +parseLineAsNaN :: Scanner Double +parseLineAsNaN = (0 / 0) <$ parseLine + +parseLineAsInf :: Scanner Double +parseLineAsInf = (1 / 0) <$ parseLine + +-- (inf|-inf|nan|(+|-)?\d+(\.\d+)?([eE](+|-)?\d+)) +-- +-- Due to Redis bugs prior to 7.2, we also have to deal with +-- /(-)?nan(\(.*\))?/i, even though they're not part of the +-- RESP spec... +parseDouble :: Scanner RespExpr +parseDouble = do + c <- Scanner.anyChar8 + RespDouble <$> case c of + '+' -> go1 =<< Scanner.anyChar8 + '-' -> fmap negate $ go1 =<< Scanner.anyChar8 + 'i' -> do + -- Note: We're not validating that the rest of the line + -- is actually "nf", because `,i` uniquely determines the + -- set of valid responses. + parseLineAsInf + 'n' -> parseLineAsNaN + 'N' -> parseLineAsNaN + _ -> go1 c + + where + -- takes first non-sign char of the significand + go1 :: Char -> Scanner Double + go1 'i' = parseLineAsInf + go1 'n' = parseLineAsNaN + go1 'N' = parseLineAsNaN + go1 c1 = fromRational <$> do + decStr <- Scanner.takeWhileChar8 $ not . (`bsContains` ".\reE") + let dec = parseNatural1 c1 decStr :: Integer + c2 <- Scanner.anyChar8 + case c2 of + '\r' -> fromIntegral dec <$ expectChar '\n' + '.' -> do + decStr1 <- Scanner.takeWhileChar8 $ not . (`bsContains` "\reE") + let dec1 = fromIntegral (parseNatural' dec decStr1) / (10 ^ BS.length decStr1) :: Rational + c3 <- Scanner.anyChar8 + case c3 of + '\r' -> dec1 <$ expectChar '\n' + _ {- c3 `elem` "eE" -} -> go2 dec1 + _ {- c3 `elem` "eE" -} -> go2 $ fromIntegral dec + + -- from first char of exponent (after [eE]) + go2 :: Rational -> Scanner Rational + go2 n = do + c <- Scanner.anyChar8 + (negExp, exponent') <- case c of + '-' -> (True,) . parseNatural <$> parseLine + '+' -> (False,) . parseNatural <$> parseLine + _ {- isDigit c -} -> (False,) . parseNatural1 c <$> parseLine + let expMul = fromIntegral (10 ^ (exponent' :: Integer) :: Integer) :: Rational + pure $ if negExp then n / expMul else n * expMul + +parseNatural :: Integral a => ByteString -> a +parseNatural = parseNatural' 0 + +parseNatural' :: Integral a => a -> ByteString -> a +parseNatural' = BS8.foldl' (\a b -> a * 10 + fromIntegral (digitToInt b)) + +parseNatural1 :: Integral a => Char -> ByteString -> a +parseNatural1 = parseNatural' . fromIntegral . digitToInt + +-- RESP2 calls these 'multi bulk' +-- RESP3 calls it an 'array' +-- +-- This is used to parse arrays and sets, meaning that we parse +-- "~-1\r\n" as RespNull, although this isn't a valid form in the spec. +parseArray :: ([RespExpr] -> RespExpr) -> Scanner RespExpr +parseArray construct = do + messageSize <- parseComplexNullableMessageSize + case messageSize of + NMSFixed n -> construct <$> replicateM n parseExpression + NMSMinusOne -> pure RespNull + NMSVariable -> construct <$> parseVarArrayItems + +-- See https://github.com/redis/redis-specifications/blob/master/protocol/RESP3.md#streamed-aggregated-data-types +parseVarArrayItems :: Scanner [RespExpr] +parseVarArrayItems = do + c <- Scanner.anyChar8 + case c of + '.' -> [] <$ parseEol + _ -> (:) <$> parseExpression' c <*> parseVarArrayItems + +-- RESP2 calls these 'bulk strings' +-- RESP3 calls them 'blob strings' (in the markdown, on the website they're still 'bulk strings') +parseBlob :: Scanner RespExpr +parseBlob = parseBlob' RespBlob RespStreamingBlob $ pure RespNull + +-- general case for something that's pretty blobstring-like +parseBlob' + :: (ByteString -> a) + -> (LazyByteString -> a) + -> Scanner a + -> Scanner a +parseBlob' strictConstr lazyConstr nullConstr = do + ms <- parseComplexNullableMessageSize + case ms of + NMSFixed n -> strictConstr <$> Scanner.take n <* parseEol + NMSVariable -> lazyConstr . BSL.fromChunks <$> streamingBlobParts + NMSMinusOne -> nullConstr + +parseMessageSize :: Scanner Int +parseMessageSize = parseNatural <$> parseLine + +-- Used for blobs and arrays +parseComplexNullableMessageSize :: Scanner NullableMessageSize +parseComplexNullableMessageSize = do + line <- parseLine + case line of + "?" -> pure NMSVariable + "-1" -> pure NMSMinusOne + _ -> pure $ NMSFixed $ parseNatural line + +-- Used for maps, attributes, sets +parseComplexMessageSize :: Scanner MessageSize +parseComplexMessageSize = do + line <- parseLine + case line of + "?" -> pure MSVariable + _ -> pure $ MSFixed $ parseNatural line + +streamingBlobParts :: Scanner [ByteString] +streamingBlobParts = do + expectChar ';' + ms <- parseMessageSize + case ms of + 0 -> pure mempty + n -> (:) <$> Scanner.take n <* parseEol <*> streamingBlobParts + +parseString :: Scanner RespExpr +parseString = RespString <$> parseLine + +-- Cautious interpretation, until we can clarify that the +-- error tag is mandatory. +-- https://github.com/redis/redis-specifications/issues/24 +parseStringError :: Scanner RespExpr +parseStringError = RespStringError <$> parseLine + +parseInteger :: Integral a => Scanner a +parseInteger = do + c <- Scanner.anyChar8 + case c of + '+' -> parseNatural <$> parseLine + '-' -> negate . parseNatural <$> parseLine + _ -> parseNatural1 c <$> parseLine + +parseLine :: Scanner ByteString +parseLine = Scanner.takeWhileChar8 (/= '\r') <* parseEol + +expectChar :: Char -> Scanner () +expectChar c = do + d <- Scanner.anyChar8 + when (c /= d) $ fail $ "Expected " <> show c <> ", but got " <> show d + +parseEol :: Scanner () +parseEol = do + expectChar '\r' + expectChar '\n' diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,375 @@ +{-# 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 + ]