{-# LANGUAGE CPP               #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE ApplicativeDo     #-}
#endif
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE DeriveGeneric     #-}

{-|
RESP is the wire protocol that Redis uses.
The latest version is RESP3, which at time of writing
seems relatively complete, but may still be evolving.

This module parses the entire RESP3 spec (as of 2024-01-26),
but also parses some invalid RESP forms that Redis may return,
eg `-nan`, and parses RESP2 forms that have been removed from
the spec (eg `$-1\\r\\n`).
-}

module Data.RESP
  ( RespMessage(..)
  , RespExpr(..)
  , parseMessage
  , 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)

#if MIN_VERSION_bytestring(0,10,0)
lazyBsToStrict :: BSL.ByteString -> ByteString
lazyBsToStrict :: ByteString -> ByteString
lazyBsToStrict = ByteString -> ByteString
BSL.toStrict
#else
lazyBsToStrict :: BSL.ByteString -> ByteString
lazyBsToStrict = BS.concat . BSL.toChunks
#endif

-- | A message from the server (eg. Redis) to the client.
-- This can be a push message (for pub/sub), or a reply to a command
-- issued by the client.
data RespMessage
  = RespPush !ByteString ![RespExpr]
  | RespReply !RespExpr
  deriving (Int -> RespMessage -> ShowS
[RespMessage] -> ShowS
RespMessage -> String
(Int -> RespMessage -> ShowS)
-> (RespMessage -> String)
-> ([RespMessage] -> ShowS)
-> Show RespMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RespMessage -> ShowS
showsPrec :: Int -> RespMessage -> ShowS
$cshow :: RespMessage -> String
show :: RespMessage -> String
$cshowList :: [RespMessage] -> ShowS
showList :: [RespMessage] -> ShowS
Show, RespMessage -> RespMessage -> Bool
(RespMessage -> RespMessage -> Bool)
-> (RespMessage -> RespMessage -> Bool) -> Eq RespMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RespMessage -> RespMessage -> Bool
== :: RespMessage -> RespMessage -> Bool
$c/= :: RespMessage -> RespMessage -> Bool
/= :: RespMessage -> RespMessage -> Bool
Eq, Eq RespMessage
Eq RespMessage
-> (RespMessage -> RespMessage -> Ordering)
-> (RespMessage -> RespMessage -> Bool)
-> (RespMessage -> RespMessage -> Bool)
-> (RespMessage -> RespMessage -> Bool)
-> (RespMessage -> RespMessage -> Bool)
-> (RespMessage -> RespMessage -> RespMessage)
-> (RespMessage -> RespMessage -> RespMessage)
-> Ord RespMessage
RespMessage -> RespMessage -> Bool
RespMessage -> RespMessage -> Ordering
RespMessage -> RespMessage -> RespMessage
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 :: RespMessage -> RespMessage -> Ordering
compare :: RespMessage -> RespMessage -> Ordering
$c< :: RespMessage -> RespMessage -> Bool
< :: RespMessage -> RespMessage -> Bool
$c<= :: RespMessage -> RespMessage -> Bool
<= :: RespMessage -> RespMessage -> Bool
$c> :: RespMessage -> RespMessage -> Bool
> :: RespMessage -> RespMessage -> Bool
$c>= :: RespMessage -> RespMessage -> Bool
>= :: RespMessage -> RespMessage -> Bool
$cmax :: RespMessage -> RespMessage -> RespMessage
max :: RespMessage -> RespMessage -> RespMessage
$cmin :: RespMessage -> RespMessage -> RespMessage
min :: RespMessage -> RespMessage -> RespMessage
Ord, (forall x. RespMessage -> Rep RespMessage x)
-> (forall x. Rep RespMessage x -> RespMessage)
-> Generic RespMessage
forall x. Rep RespMessage x -> RespMessage
forall x. RespMessage -> Rep RespMessage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RespMessage -> Rep RespMessage x
from :: forall x. RespMessage -> Rep RespMessage x
$cto :: forall x. Rep RespMessage x -> RespMessage
to :: forall x. Rep RespMessage x -> RespMessage
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 `Data.Text.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 `Data.HashMap.HashMap`,
-- because that would involve imposing our choice of data structure on
-- the caller. The caller might want to use `Data.HashMap.HashMap`,
-- `Data.Map.Map`, iterate over the elements, or just use the `lookup`
-- function.
data RespExpr
  = RespString !ByteString
  | RespBlob !ByteString
  | RespStreamingBlob !BSL.ByteString
  | 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

-- | Parse a RESP3 message
parseMessage :: Scanner RespMessage
parseMessage :: Scanner RespMessage
parseMessage = do
  Char
c <- Scanner Char
Scanner.anyChar8
  case Char
c of
    Char
'>' -> Scanner RespMessage
parsePush
    Char
_ -> RespExpr -> RespMessage
RespReply (RespExpr -> RespMessage)
-> Scanner RespExpr -> Scanner RespMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Scanner RespExpr
parseExpression' Char
c

-- | Parse a RESP3 expression
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'

-- | Parse a RESP3 expression, 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 RespMessage
parsePush :: Scanner RespMessage
parsePush = do
  Int
len <- Scanner Int
parseMessageSize
  ByteString -> [RespExpr] -> RespMessage
RespPush (ByteString -> [RespExpr] -> RespMessage)
-> Scanner ByteString -> Scanner ([RespExpr] -> RespMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scanner ByteString
parsePushType Scanner ([RespExpr] -> RespMessage)
-> Scanner [RespExpr] -> Scanner RespMessage
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)
-> (ByteString -> ByteString)
-> Scanner ByteString
-> Scanner ByteString
forall a.
(ByteString -> a) -> (ByteString -> a) -> Scanner a -> Scanner a
parseBlob' ByteString -> ByteString
forall a. a -> a
id ByteString -> 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)
-> (ByteString -> RespExpr) -> Scanner RespExpr -> Scanner RespExpr
forall a.
(ByteString -> a) -> (ByteString -> a) -> Scanner a -> Scanner a
parseBlob' ByteString -> RespExpr
RespBlob ByteString -> 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)
  -> (BSL.ByteString -> a)
  -> Scanner a
  -> Scanner a
parseBlob' :: forall a.
(ByteString -> a) -> (ByteString -> a) -> Scanner a -> Scanner a
parseBlob' ByteString -> a
strictConstr ByteString -> 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 -> ByteString -> a
lazyConstr (ByteString -> a)
-> ([ByteString] -> ByteString) -> [ByteString] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
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'