{-# 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 :: LazyByteString -> ByteString
lazyBsToStrict = LazyByteString -> ByteString
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 (Int -> RespReply -> ShowS
[RespReply] -> ShowS
RespReply -> String
(Int -> RespReply -> ShowS)
-> (RespReply -> String)
-> ([RespReply] -> ShowS)
-> Show RespReply
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RespReply -> ShowS
showsPrec :: Int -> RespReply -> ShowS
$cshow :: RespReply -> String
show :: RespReply -> String
$cshowList :: [RespReply] -> ShowS
showList :: [RespReply] -> ShowS
Show, RespReply -> RespReply -> Bool
(RespReply -> RespReply -> Bool)
-> (RespReply -> RespReply -> Bool) -> Eq RespReply
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RespReply -> RespReply -> Bool
== :: RespReply -> RespReply -> Bool
$c/= :: RespReply -> RespReply -> Bool
/= :: RespReply -> RespReply -> Bool
Eq, Eq RespReply
Eq RespReply =>
(RespReply -> RespReply -> Ordering)
-> (RespReply -> RespReply -> Bool)
-> (RespReply -> RespReply -> Bool)
-> (RespReply -> RespReply -> Bool)
-> (RespReply -> RespReply -> Bool)
-> (RespReply -> RespReply -> RespReply)
-> (RespReply -> RespReply -> RespReply)
-> Ord RespReply
RespReply -> RespReply -> Bool
RespReply -> RespReply -> Ordering
RespReply -> RespReply -> RespReply
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RespReply -> RespReply -> Ordering
compare :: RespReply -> RespReply -> Ordering
$c< :: RespReply -> RespReply -> Bool
< :: RespReply -> RespReply -> Bool
$c<= :: RespReply -> RespReply -> Bool
<= :: RespReply -> RespReply -> Bool
$c> :: RespReply -> RespReply -> Bool
> :: RespReply -> RespReply -> Bool
$c>= :: RespReply -> RespReply -> Bool
>= :: RespReply -> RespReply -> Bool
$cmax :: RespReply -> RespReply -> RespReply
max :: RespReply -> RespReply -> RespReply
$cmin :: RespReply -> RespReply -> RespReply
min :: RespReply -> RespReply -> RespReply
Ord, (forall x. RespReply -> Rep RespReply x)
-> (forall x. Rep RespReply x -> RespReply) -> Generic RespReply
forall x. Rep RespReply x -> RespReply
forall x. RespReply -> Rep RespReply x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RespReply -> Rep RespReply x
from :: forall x. RespReply -> Rep RespReply x
$cto :: forall x. Rep RespReply x -> RespReply
to :: forall x. Rep RespReply x -> RespReply
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 (Int -> RespExpr -> ShowS
[RespExpr] -> ShowS
RespExpr -> String
(Int -> RespExpr -> ShowS)
-> (RespExpr -> String) -> ([RespExpr] -> ShowS) -> Show RespExpr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RespExpr -> ShowS
showsPrec :: Int -> RespExpr -> ShowS
$cshow :: RespExpr -> String
show :: RespExpr -> String
$cshowList :: [RespExpr] -> ShowS
showList :: [RespExpr] -> ShowS
Show, RespExpr -> RespExpr -> Bool
(RespExpr -> RespExpr -> Bool)
-> (RespExpr -> RespExpr -> Bool) -> Eq RespExpr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RespExpr -> RespExpr -> Bool
== :: RespExpr -> RespExpr -> Bool
$c/= :: RespExpr -> RespExpr -> Bool
/= :: RespExpr -> RespExpr -> Bool
Eq, Eq RespExpr
Eq RespExpr =>
(RespExpr -> RespExpr -> Ordering)
-> (RespExpr -> RespExpr -> Bool)
-> (RespExpr -> RespExpr -> Bool)
-> (RespExpr -> RespExpr -> Bool)
-> (RespExpr -> RespExpr -> Bool)
-> (RespExpr -> RespExpr -> RespExpr)
-> (RespExpr -> RespExpr -> RespExpr)
-> Ord RespExpr
RespExpr -> RespExpr -> Bool
RespExpr -> RespExpr -> Ordering
RespExpr -> RespExpr -> RespExpr
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RespExpr -> RespExpr -> Ordering
compare :: RespExpr -> RespExpr -> Ordering
$c< :: RespExpr -> RespExpr -> Bool
< :: RespExpr -> RespExpr -> Bool
$c<= :: RespExpr -> RespExpr -> Bool
<= :: RespExpr -> RespExpr -> Bool
$c> :: RespExpr -> RespExpr -> Bool
> :: RespExpr -> RespExpr -> Bool
$c>= :: RespExpr -> RespExpr -> Bool
>= :: RespExpr -> RespExpr -> Bool
$cmax :: RespExpr -> RespExpr -> RespExpr
max :: RespExpr -> RespExpr -> RespExpr
$cmin :: RespExpr -> RespExpr -> RespExpr
min :: RespExpr -> RespExpr -> RespExpr
Ord, (forall x. RespExpr -> Rep RespExpr x)
-> (forall x. Rep RespExpr x -> RespExpr) -> Generic RespExpr
forall x. Rep RespExpr x -> RespExpr
forall x. RespExpr -> Rep RespExpr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RespExpr -> Rep RespExpr x
from :: forall x. RespExpr -> Rep RespExpr x
$cto :: forall x. Rep RespExpr x -> RespExpr
to :: forall x. Rep RespExpr x -> RespExpr
Generic)

data MessageSize
  = MSVariable
  | MSFixed Int

data NullableMessageSize
  = NMSVariable
  | NMSMinusOne
  | NMSFixed Int

-- Top level RESP item
parseReply :: Scanner RespReply
parseReply :: Scanner RespReply
parseReply = do
  Char
c <- Scanner Char
Scanner.anyChar8
  case Char
c of
    Char
'>' -> Scanner RespReply
parsePush
    Char
_ -> RespExpr -> RespReply
RespExpr (RespExpr -> RespReply) -> Scanner RespExpr -> Scanner RespReply
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Scanner RespExpr
parseExpression' Char
c

-- Non-top-level resp item
parseExpression :: Scanner RespExpr
parseExpression :: Scanner RespExpr
parseExpression = Scanner Char
Scanner.anyChar8 Scanner Char -> (Char -> Scanner RespExpr) -> Scanner RespExpr
forall a b. Scanner a -> (a -> Scanner b) -> Scanner b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Char -> Scanner RespExpr
parseExpression'

-- Non-top-level resp item, taking its first char as a parameter
parseExpression' :: Char -> Scanner RespExpr
parseExpression' :: Char -> Scanner RespExpr
parseExpression' Char
c = case Char
c of
  Char
'$' -> Scanner RespExpr
parseBlob
  Char
'+' -> Scanner RespExpr
parseString
  Char
'-' -> Scanner RespExpr
parseStringError
  Char
':' -> Int64 -> RespExpr
RespInteger (Int64 -> RespExpr) -> Scanner Int64 -> Scanner RespExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner Int64
forall a. Integral a => Scanner a
parseInteger
  Char
'*' -> ([RespExpr] -> RespExpr) -> Scanner RespExpr
parseArray [RespExpr] -> RespExpr
RespArray
  Char
'_' -> RespExpr
RespNull RespExpr -> Scanner () -> Scanner RespExpr
forall a b. a -> Scanner b -> Scanner a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner ()
parseEol 
  Char
'#' -> Bool -> RespExpr
RespBool (Bool -> RespExpr) -> (Char -> Bool) -> Char -> RespExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
't') (Char -> RespExpr) -> Scanner Char -> Scanner RespExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner Char
Scanner.anyChar8 Scanner RespExpr -> Scanner () -> Scanner RespExpr
forall a b. Scanner a -> Scanner b -> Scanner a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Scanner ()
parseEol
  Char
',' -> Scanner RespExpr
parseDouble
  Char
'!' -> Scanner RespExpr
parseBlobError
  Char
'=' -> Scanner RespExpr
parseVerbatimString
  Char
'(' -> Integer -> RespExpr
RespBigInteger (Integer -> RespExpr) -> Scanner Integer -> Scanner RespExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner Integer
forall a. Integral a => Scanner a
parseInteger
  Char
'%' -> [(RespExpr, RespExpr)] -> RespExpr
RespMap ([(RespExpr, RespExpr)] -> RespExpr)
-> Scanner [(RespExpr, RespExpr)] -> Scanner RespExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner [(RespExpr, RespExpr)]
parseMap
  Char
'~' -> ([RespExpr] -> RespExpr) -> Scanner RespExpr
parseArray [RespExpr] -> RespExpr
RespSet
  Char
'|' -> [(RespExpr, RespExpr)] -> RespExpr -> RespExpr
RespAttribute ([(RespExpr, RespExpr)] -> RespExpr -> RespExpr)
-> Scanner [(RespExpr, RespExpr)] -> Scanner (RespExpr -> RespExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner [(RespExpr, RespExpr)]
parseMap Scanner (RespExpr -> RespExpr)
-> Scanner RespExpr -> Scanner RespExpr
forall a b. Scanner (a -> b) -> Scanner a -> Scanner b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Scanner RespExpr
parseExpression
  Char
_ -> String -> Scanner RespExpr
forall a. String -> Scanner a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Scanner RespExpr) -> String -> Scanner RespExpr
forall a b. (a -> b) -> a -> b
$ String
"Unknown expression prefix: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Char -> String
forall a. Show a => a -> String
show Char
c

parsePush :: Scanner RespReply
parsePush :: Scanner RespReply
parsePush = do
  Int
len <- Scanner Int
parseMessageSize
  ByteString -> [RespExpr] -> RespReply
RespPush (ByteString -> [RespExpr] -> RespReply)
-> Scanner ByteString -> Scanner ([RespExpr] -> RespReply)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner ByteString
parsePushType Scanner ([RespExpr] -> RespReply)
-> Scanner [RespExpr] -> Scanner RespReply
forall a b. Scanner (a -> b) -> Scanner a -> Scanner b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Scanner RespExpr -> Scanner [RespExpr]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int -> Int
forall a. Enum a => a -> a
pred Int
len) Scanner RespExpr
parseExpression

parsePushType :: Scanner ByteString
parsePushType :: Scanner ByteString
parsePushType = do
  Char
c <- Scanner Char
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 Char
c of
    Char
'$' -> (ByteString -> ByteString)
-> (LazyByteString -> ByteString)
-> Scanner ByteString
-> Scanner ByteString
forall a.
(ByteString -> a)
-> (LazyByteString -> a) -> Scanner a -> Scanner a
parseBlob' ByteString -> ByteString
forall a. a -> a
id LazyByteString -> ByteString
lazyBsToStrict (Scanner ByteString -> Scanner ByteString)
-> Scanner ByteString -> Scanner ByteString
forall a b. (a -> b) -> a -> b
$ String -> Scanner ByteString
forall a. String -> Scanner a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Push message type can't be null"
    Char
'+' -> Scanner ByteString
parseLine
    Char
_ -> String -> Scanner ByteString
forall a. String -> Scanner a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid push message type"

parseMap :: Scanner [(RespExpr, RespExpr)]
parseMap :: Scanner [(RespExpr, RespExpr)]
parseMap = do
  MessageSize
len <- Scanner MessageSize
parseComplexMessageSize
  case MessageSize
len of
    MSFixed Int
n -> Int
-> Scanner (RespExpr, RespExpr) -> Scanner [(RespExpr, RespExpr)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Scanner (RespExpr, RespExpr)
parseTwoEls
    MessageSize
MSVariable -> Scanner [(RespExpr, RespExpr)]
parseVarMapPairs

-- See https://github.com/redis/redis-specifications/blob/master/protocol/RESP3.md#streamed-aggregated-data-types
parseVarMapPairs :: Scanner [(RespExpr, RespExpr)]
parseVarMapPairs :: Scanner [(RespExpr, RespExpr)]
parseVarMapPairs = do
  Char
c <- Scanner Char
Scanner.anyChar8
  case Char
c of
    Char
'.' -> [] [(RespExpr, RespExpr)]
-> Scanner () -> Scanner [(RespExpr, RespExpr)]
forall a b. a -> Scanner b -> Scanner a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner ()
parseEol
    Char
_ -> (:) ((RespExpr, RespExpr)
 -> [(RespExpr, RespExpr)] -> [(RespExpr, RespExpr)])
-> Scanner (RespExpr, RespExpr)
-> Scanner ([(RespExpr, RespExpr)] -> [(RespExpr, RespExpr)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,) (RespExpr -> RespExpr -> (RespExpr, RespExpr))
-> Scanner RespExpr -> Scanner (RespExpr -> (RespExpr, RespExpr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Scanner RespExpr
parseExpression' Char
c Scanner (RespExpr -> (RespExpr, RespExpr))
-> Scanner RespExpr -> Scanner (RespExpr, RespExpr)
forall a b. Scanner (a -> b) -> Scanner a -> Scanner b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Scanner RespExpr
parseExpression) Scanner ([(RespExpr, RespExpr)] -> [(RespExpr, RespExpr)])
-> Scanner [(RespExpr, RespExpr)] -> Scanner [(RespExpr, RespExpr)]
forall a b. Scanner (a -> b) -> Scanner a -> Scanner b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Scanner [(RespExpr, RespExpr)]
parseVarMapPairs

parseTwoEls :: Scanner (RespExpr, RespExpr)
parseTwoEls :: Scanner (RespExpr, RespExpr)
parseTwoEls = (,) (RespExpr -> RespExpr -> (RespExpr, RespExpr))
-> Scanner RespExpr -> Scanner (RespExpr -> (RespExpr, RespExpr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner RespExpr
parseExpression Scanner (RespExpr -> (RespExpr, RespExpr))
-> Scanner RespExpr -> Scanner (RespExpr, RespExpr)
forall a b. Scanner (a -> b) -> Scanner a -> Scanner b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Scanner RespExpr
parseExpression

-- See: https://github.com/redis/redis-specifications/issues/25
--    , https://github.com/redis/redis-specifications/issues/23
parseVerbatimString :: Scanner RespExpr
parseVerbatimString :: Scanner RespExpr
parseVerbatimString = do
  Int
len <- Scanner Int
parseMessageSize
  ByteString
entireBlob <- Int -> Scanner ByteString
Scanner.take Int
len
  let body :: ByteString
body = Int -> ByteString -> ByteString
BS8.drop Int
4 ByteString
entireBlob
  Scanner ()
parseEol
  case Int -> ByteString -> ByteString
BS8.take Int
3 ByteString
entireBlob of
    ByteString
"txt" -> RespExpr -> Scanner RespExpr
forall a. a -> Scanner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RespExpr -> Scanner RespExpr) -> RespExpr -> Scanner RespExpr
forall a b. (a -> b) -> a -> b
$ ByteString -> RespExpr
RespVerbatimString ByteString
body
    ByteString
"mkd" -> RespExpr -> Scanner RespExpr
forall a. a -> Scanner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RespExpr -> Scanner RespExpr) -> RespExpr -> Scanner RespExpr
forall a b. (a -> b) -> a -> b
$ ByteString -> RespExpr
RespVerbatimMarkdown ByteString
body
    ByteString
_ -> String -> Scanner RespExpr
forall a. String -> Scanner a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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 :: Scanner RespExpr
parseBlobError = do
  Int
len <- Scanner Int
parseMessageSize
  ByteString -> RespExpr
RespBlobError (ByteString -> RespExpr) -> Scanner ByteString -> Scanner RespExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Scanner ByteString
Scanner.take Int
len Scanner RespExpr -> Scanner () -> Scanner RespExpr
forall a b. Scanner a -> Scanner b -> Scanner a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Scanner ()
parseEol

bsContains :: Char -> ByteString -> Bool
bsContains :: Char -> ByteString -> Bool
bsContains Char
c = (Char -> Bool) -> ByteString -> Bool
BS8.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)

-- Scanning to NaN is a function so that we don't
-- feel guilty about inlining the patterns
parseLineAsNaN :: Scanner Double
parseLineAsNaN :: Scanner Double
parseLineAsNaN = (Double
0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0) Double -> Scanner ByteString -> Scanner Double
forall a b. a -> Scanner b -> Scanner a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner ByteString
parseLine

parseLineAsInf :: Scanner Double
parseLineAsInf :: Scanner Double
parseLineAsInf = (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0) Double -> Scanner ByteString -> Scanner Double
forall a b. a -> Scanner b -> Scanner a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner ByteString
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 :: Scanner RespExpr
parseDouble = do
  Char
c <- Scanner Char
Scanner.anyChar8
  Double -> RespExpr
RespDouble (Double -> RespExpr) -> Scanner Double -> Scanner RespExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Char
c of
    Char
'+' -> Char -> Scanner Double
go1 (Char -> Scanner Double) -> Scanner Char -> Scanner Double
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Scanner Char
Scanner.anyChar8
    Char
'-' -> (Double -> Double) -> Scanner Double -> Scanner Double
forall a b. (a -> b) -> Scanner a -> Scanner b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> Double
forall a. Num a => a -> a
negate (Scanner Double -> Scanner Double)
-> Scanner Double -> Scanner Double
forall a b. (a -> b) -> a -> b
$ Char -> Scanner Double
go1 (Char -> Scanner Double) -> Scanner Char -> Scanner Double
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Scanner Char
Scanner.anyChar8
    Char
'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.
      Scanner Double
parseLineAsInf
    Char
'n' -> Scanner Double
parseLineAsNaN
    Char
'N' -> Scanner Double
parseLineAsNaN
    Char
_ -> Char -> Scanner Double
go1 Char
c

  where
    -- takes first non-sign char of the significand
    go1 :: Char -> Scanner Double
    go1 :: Char -> Scanner Double
go1 Char
'i' = Scanner Double
parseLineAsInf
    go1 Char
'n' = Scanner Double
parseLineAsNaN
    go1 Char
'N' = Scanner Double
parseLineAsNaN
    go1 Char
c1 = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Scanner Rational -> Scanner Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      ByteString
decStr <- (Char -> Bool) -> Scanner ByteString
Scanner.takeWhileChar8 ((Char -> Bool) -> Scanner ByteString)
-> (Char -> Bool) -> Scanner ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> ByteString -> Bool
`bsContains` ByteString
".\reE")
      let dec :: Integer
dec = Char -> ByteString -> Integer
forall a. Integral a => Char -> ByteString -> a
parseNatural1 Char
c1 ByteString
decStr :: Integer
      Char
c2 <- Scanner Char
Scanner.anyChar8
      case Char
c2 of
        Char
'\r' -> Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
dec Rational -> Scanner () -> Scanner Rational
forall a b. a -> Scanner b -> Scanner a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Scanner ()
expectChar Char
'\n' 
        Char
'.' -> do
          ByteString
decStr1 <- (Char -> Bool) -> Scanner ByteString
Scanner.takeWhileChar8 ((Char -> Bool) -> Scanner ByteString)
-> (Char -> Bool) -> Scanner ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> ByteString -> Bool
`bsContains` ByteString
"\reE")
          let dec1 :: Rational
dec1 = Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> ByteString -> Integer
forall a. Integral a => a -> ByteString -> a
parseNatural' Integer
dec ByteString
decStr1) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ (Rational
10 Rational -> Int -> Rational
forall a b. (Num a, Integral b) => a -> b -> a
^ ByteString -> Int
BS.length ByteString
decStr1) :: Rational
          Char
c3 <- Scanner Char
Scanner.anyChar8
          case Char
c3 of
            Char
'\r' -> Rational
dec1 Rational -> Scanner () -> Scanner Rational
forall a b. a -> Scanner b -> Scanner a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Scanner ()
expectChar Char
'\n'
            Char
_ {- c3 `elem` "eE" -} -> Rational -> Scanner Rational
go2 Rational
dec1
        Char
_ {- c3 `elem` "eE" -} -> Rational -> Scanner Rational
go2 (Rational -> Scanner Rational) -> Rational -> Scanner Rational
forall a b. (a -> b) -> a -> b
$ Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
dec

    -- from first char of exponent (after [eE])
    go2 :: Rational -> Scanner Rational
    go2 :: Rational -> Scanner Rational
go2 Rational
n = do
      Char
c <- Scanner Char
Scanner.anyChar8
      (Bool
negExp, Integer
exponent') <- case Char
c of
        Char
'-' -> (Bool
True,) (Integer -> (Bool, Integer))
-> (ByteString -> Integer) -> ByteString -> (Bool, Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Integer
forall a. Integral a => ByteString -> a
parseNatural (ByteString -> (Bool, Integer))
-> Scanner ByteString -> Scanner (Bool, Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner ByteString
parseLine
        Char
'+' -> (Bool
False,) (Integer -> (Bool, Integer))
-> (ByteString -> Integer) -> ByteString -> (Bool, Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Integer
forall a. Integral a => ByteString -> a
parseNatural (ByteString -> (Bool, Integer))
-> Scanner ByteString -> Scanner (Bool, Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner ByteString
parseLine
        Char
_ {- isDigit c -} -> (Bool
False,) (Integer -> (Bool, Integer))
-> (ByteString -> Integer) -> ByteString -> (Bool, Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> Integer
forall a. Integral a => Char -> ByteString -> a
parseNatural1 Char
c (ByteString -> (Bool, Integer))
-> Scanner ByteString -> Scanner (Bool, Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner ByteString
parseLine
      let expMul :: Rational
expMul = Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
10 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
exponent' :: Integer) :: Integer) :: Rational
      Rational -> Scanner Rational
forall a. a -> Scanner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rational -> Scanner Rational) -> Rational -> Scanner Rational
forall a b. (a -> b) -> a -> b
$ if Bool
negExp then Rational
n Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
expMul else Rational
n Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
expMul

parseNatural :: Integral a => ByteString -> a
parseNatural :: forall a. Integral a => ByteString -> a
parseNatural = a -> ByteString -> a
forall a. Integral a => a -> ByteString -> a
parseNatural' a
0

parseNatural' :: Integral a => a -> ByteString -> a
parseNatural' :: forall a. Integral a => a -> ByteString -> a
parseNatural' = (a -> Char -> a) -> a -> ByteString -> a
forall a. (a -> Char -> a) -> a -> ByteString -> a
BS8.foldl' (\a
a Char
b -> a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
10 a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
b))

parseNatural1 :: Integral a => Char -> ByteString -> a
parseNatural1 :: forall a. Integral a => Char -> ByteString -> a
parseNatural1 = a -> ByteString -> a
forall a. Integral a => a -> ByteString -> a
parseNatural' (a -> ByteString -> a) -> (Char -> a) -> Char -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> a) -> (Char -> Int) -> Char -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
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 :: ([RespExpr] -> RespExpr) -> Scanner RespExpr
parseArray [RespExpr] -> RespExpr
construct = do
  NullableMessageSize
messageSize <- Scanner NullableMessageSize
parseComplexNullableMessageSize
  case NullableMessageSize
messageSize of
    NMSFixed Int
n -> [RespExpr] -> RespExpr
construct ([RespExpr] -> RespExpr) -> Scanner [RespExpr] -> Scanner RespExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Scanner RespExpr -> Scanner [RespExpr]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Scanner RespExpr
parseExpression
    NullableMessageSize
NMSMinusOne -> RespExpr -> Scanner RespExpr
forall a. a -> Scanner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RespExpr
RespNull
    NullableMessageSize
NMSVariable -> [RespExpr] -> RespExpr
construct ([RespExpr] -> RespExpr) -> Scanner [RespExpr] -> Scanner RespExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner [RespExpr]
parseVarArrayItems

-- See https://github.com/redis/redis-specifications/blob/master/protocol/RESP3.md#streamed-aggregated-data-types
parseVarArrayItems :: Scanner [RespExpr]
parseVarArrayItems :: Scanner [RespExpr]
parseVarArrayItems = do
  Char
c <- Scanner Char
Scanner.anyChar8
  case Char
c of
    Char
'.' -> [] [RespExpr] -> Scanner () -> Scanner [RespExpr]
forall a b. a -> Scanner b -> Scanner a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner ()
parseEol
    Char
_ -> (:) (RespExpr -> [RespExpr] -> [RespExpr])
-> Scanner RespExpr -> Scanner ([RespExpr] -> [RespExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Scanner RespExpr
parseExpression' Char
c Scanner ([RespExpr] -> [RespExpr])
-> Scanner [RespExpr] -> Scanner [RespExpr]
forall a b. Scanner (a -> b) -> Scanner a -> Scanner b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Scanner [RespExpr]
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 :: Scanner RespExpr
parseBlob = (ByteString -> RespExpr)
-> (LazyByteString -> RespExpr)
-> Scanner RespExpr
-> Scanner RespExpr
forall a.
(ByteString -> a)
-> (LazyByteString -> a) -> Scanner a -> Scanner a
parseBlob' ByteString -> RespExpr
RespBlob LazyByteString -> RespExpr
RespStreamingBlob (Scanner RespExpr -> Scanner RespExpr)
-> Scanner RespExpr -> Scanner RespExpr
forall a b. (a -> b) -> a -> b
$ RespExpr -> Scanner RespExpr
forall a. a -> Scanner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RespExpr
RespNull

-- general case for something that's pretty blobstring-like
parseBlob'
  :: (ByteString -> a)
  -> (LazyByteString -> a)
  -> Scanner a
  -> Scanner a
parseBlob' :: forall a.
(ByteString -> a)
-> (LazyByteString -> a) -> Scanner a -> Scanner a
parseBlob' ByteString -> a
strictConstr LazyByteString -> a
lazyConstr Scanner a
nullConstr = do
  NullableMessageSize
ms <- Scanner NullableMessageSize
parseComplexNullableMessageSize
  case NullableMessageSize
ms of
    NMSFixed Int
n -> ByteString -> a
strictConstr (ByteString -> a) -> Scanner ByteString -> Scanner a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Scanner ByteString
Scanner.take Int
n Scanner a -> Scanner () -> Scanner a
forall a b. Scanner a -> Scanner b -> Scanner a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Scanner ()
parseEol
    NullableMessageSize
NMSVariable -> LazyByteString -> a
lazyConstr (LazyByteString -> a)
-> ([ByteString] -> LazyByteString) -> [ByteString] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> LazyByteString
BSL.fromChunks ([ByteString] -> a) -> Scanner [ByteString] -> Scanner a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner [ByteString]
streamingBlobParts
    NullableMessageSize
NMSMinusOne -> Scanner a
nullConstr

parseMessageSize :: Scanner Int
parseMessageSize :: Scanner Int
parseMessageSize = ByteString -> Int
forall a. Integral a => ByteString -> a
parseNatural (ByteString -> Int) -> Scanner ByteString -> Scanner Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner ByteString
parseLine

-- Used for blobs and arrays
parseComplexNullableMessageSize :: Scanner NullableMessageSize
parseComplexNullableMessageSize :: Scanner NullableMessageSize
parseComplexNullableMessageSize = do
  ByteString
line <- Scanner ByteString
parseLine
  case ByteString
line of
    ByteString
"?" -> NullableMessageSize -> Scanner NullableMessageSize
forall a. a -> Scanner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NullableMessageSize
NMSVariable
    ByteString
"-1" -> NullableMessageSize -> Scanner NullableMessageSize
forall a. a -> Scanner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NullableMessageSize
NMSMinusOne
    ByteString
_ -> NullableMessageSize -> Scanner NullableMessageSize
forall a. a -> Scanner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NullableMessageSize -> Scanner NullableMessageSize)
-> NullableMessageSize -> Scanner NullableMessageSize
forall a b. (a -> b) -> a -> b
$ Int -> NullableMessageSize
NMSFixed (Int -> NullableMessageSize) -> Int -> NullableMessageSize
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
forall a. Integral a => ByteString -> a
parseNatural ByteString
line

-- Used for maps, attributes, sets
parseComplexMessageSize :: Scanner MessageSize
parseComplexMessageSize :: Scanner MessageSize
parseComplexMessageSize = do
  ByteString
line <- Scanner ByteString
parseLine
  case ByteString
line of
    ByteString
"?" -> MessageSize -> Scanner MessageSize
forall a. a -> Scanner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MessageSize
MSVariable
    ByteString
_ -> MessageSize -> Scanner MessageSize
forall a. a -> Scanner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MessageSize -> Scanner MessageSize)
-> MessageSize -> Scanner MessageSize
forall a b. (a -> b) -> a -> b
$ Int -> MessageSize
MSFixed (Int -> MessageSize) -> Int -> MessageSize
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
forall a. Integral a => ByteString -> a
parseNatural ByteString
line

streamingBlobParts :: Scanner [ByteString]
streamingBlobParts :: Scanner [ByteString]
streamingBlobParts = do
  Char -> Scanner ()
expectChar Char
';'
  Int
ms <- Scanner Int
parseMessageSize
  case Int
ms of
    Int
0 -> [ByteString] -> Scanner [ByteString]
forall a. a -> Scanner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ByteString]
forall a. Monoid a => a
mempty
    Int
n -> (:) (ByteString -> [ByteString] -> [ByteString])
-> Scanner ByteString -> Scanner ([ByteString] -> [ByteString])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Scanner ByteString
Scanner.take Int
n Scanner ([ByteString] -> [ByteString])
-> Scanner () -> Scanner ([ByteString] -> [ByteString])
forall a b. Scanner a -> Scanner b -> Scanner a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Scanner ()
parseEol Scanner ([ByteString] -> [ByteString])
-> Scanner [ByteString] -> Scanner [ByteString]
forall a b. Scanner (a -> b) -> Scanner a -> Scanner b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Scanner [ByteString]
streamingBlobParts

parseString :: Scanner RespExpr
parseString :: Scanner RespExpr
parseString = ByteString -> RespExpr
RespString (ByteString -> RespExpr) -> Scanner ByteString -> Scanner RespExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner ByteString
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 :: Scanner RespExpr
parseStringError = ByteString -> RespExpr
RespStringError (ByteString -> RespExpr) -> Scanner ByteString -> Scanner RespExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner ByteString
parseLine

parseInteger :: Integral a => Scanner a
parseInteger :: forall a. Integral a => Scanner a
parseInteger = do
  Char
c <- Scanner Char
Scanner.anyChar8
  case Char
c of
    Char
'+' -> ByteString -> a
forall a. Integral a => ByteString -> a
parseNatural (ByteString -> a) -> Scanner ByteString -> Scanner a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner ByteString
parseLine
    Char
'-' -> a -> a
forall a. Num a => a -> a
negate (a -> a) -> (ByteString -> a) -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> a
forall a. Integral a => ByteString -> a
parseNatural (ByteString -> a) -> Scanner ByteString -> Scanner a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner ByteString
parseLine
    Char
_ -> Char -> ByteString -> a
forall a. Integral a => Char -> ByteString -> a
parseNatural1 Char
c (ByteString -> a) -> Scanner ByteString -> Scanner a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner ByteString
parseLine

parseLine :: Scanner ByteString
parseLine :: Scanner ByteString
parseLine = (Char -> Bool) -> Scanner ByteString
Scanner.takeWhileChar8 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') Scanner ByteString -> Scanner () -> Scanner ByteString
forall a b. Scanner a -> Scanner b -> Scanner a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Scanner ()
parseEol

expectChar :: Char -> Scanner ()
expectChar :: Char -> Scanner ()
expectChar Char
c = do
  Char
d <- Scanner Char
Scanner.anyChar8
  Bool -> Scanner () -> Scanner ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
d) (Scanner () -> Scanner ()) -> Scanner () -> Scanner ()
forall a b. (a -> b) -> a -> b
$ String -> Scanner ()
forall a. String -> Scanner a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Scanner ()) -> String -> Scanner ()
forall a b. (a -> b) -> a -> b
$ String
"Expected " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Char -> String
forall a. Show a => a -> String
show Char
c String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", but got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Char -> String
forall a. Show a => a -> String
show Char
d

parseEol :: Scanner ()
parseEol :: Scanner ()
parseEol = do
  Char -> Scanner ()
expectChar Char
'\r'
  Char -> Scanner ()
expectChar Char
'\n'