{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
module Data.RLP
    ( RLPObject(..)
    , RLPEncodable(..)
    , rlpParser
    , unpackRLP
    , unpackRLPFully
    , packRLP
    , rlpSerialize
    , rlpDeserialize
    , module Data.RLP.Types
    ) where

import           Control.Applicative        ((<|>))
import           Control.Monad              ((<=<))
import           Data.Attoparsec.ByteString
import           Data.Attoparsec.Combinator
import           Data.Bits                  (Bits, FiniteBits, finiteBitSize,
                                             shiftL, shiftR, (.|.))
import qualified Data.ByteString            as S
import qualified Data.ByteString.Char8      as S8
import           Data.List                  (foldl', intercalate)
import           Data.Word
import           Numeric                    (showHex)
import           Prelude                    hiding (take)
import qualified Prelude                    as P

import           Data.RLP.Types

singleByteParser :: Parser RLPObject
singleByteParser :: Parser RLPObject
singleByteParser = ByteString -> RLPObject
String (ByteString -> RLPObject)
-> (Word8 -> ByteString) -> Word8 -> RLPObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString
S.singleton (Word8 -> RLPObject) -> Parser ByteString Word8 -> Parser RLPObject
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString Word8
satisfy (Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x7F)

shortParser :: Word8 -> (a -> RLPObject) -> (S.ByteString -> Parser a) -> a -> Parser RLPObject
shortParser :: Word8
-> (a -> RLPObject)
-> (ByteString -> Parser a)
-> a
-> Parser RLPObject
shortParser Word8
base a -> RLPObject
constructor ByteString -> Parser a
postProcessor a
def = do
    Int
len <- Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> (Word8 -> Word8) -> Word8 -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
subtract Word8
base (Word8 -> Int) -> Parser ByteString Word8 -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString Word8
satisfy (\Word8
x -> Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
base Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= (Word8
base Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
55))
    if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
    then RLPObject -> Parser RLPObject
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> RLPObject
constructor a
def)
    else a -> RLPObject
constructor (a -> RLPObject) -> Parser a -> Parser RLPObject
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Parser ByteString
take Int
len Parser ByteString -> (ByteString -> Parser a) -> Parser a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Parser a
postProcessor)

longParser :: Word8 -> (a -> RLPObject) -> (S.ByteString -> Parser a) -> Parser RLPObject
longParser :: Word8
-> (a -> RLPObject) -> (ByteString -> Parser a) -> Parser RLPObject
longParser Word8
base a -> RLPObject
constructor ByteString -> Parser a
postProcessor = do
    Int
lengthLength <- Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> (Word8 -> Word8) -> Word8 -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
subtract Word8
base (Word8 -> Int) -> Parser ByteString Word8 -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString Word8
satisfy (\Word8
x -> Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
base Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= (Word8
base Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
8))
    Int
payloadLen <- [Word8] -> Int
forall n. (Bits n, Integral n) => [Word8] -> n
unpackBE ([Word8] -> Int) -> (ByteString -> [Word8]) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
S.unpack (ByteString -> Int) -> Parser ByteString -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteString
take Int
lengthLength
    a -> RLPObject
constructor (a -> RLPObject) -> Parser a -> Parser RLPObject
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Parser ByteString
take Int
payloadLen Parser ByteString -> (ByteString -> Parser a) -> Parser a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Parser a
postProcessor)

shortStringParser :: Parser RLPObject
shortStringParser :: Parser RLPObject
shortStringParser = Word8
-> (ByteString -> RLPObject)
-> (ByteString -> Parser ByteString)
-> ByteString
-> Parser RLPObject
forall a.
Word8
-> (a -> RLPObject)
-> (ByteString -> Parser a)
-> a
-> Parser RLPObject
shortParser Word8
0x80 ByteString -> RLPObject
String ByteString -> Parser ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
S.empty

longStringParser :: Parser RLPObject
longStringParser :: Parser RLPObject
longStringParser = Word8
-> (ByteString -> RLPObject)
-> (ByteString -> Parser ByteString)
-> Parser RLPObject
forall a.
Word8
-> (a -> RLPObject) -> (ByteString -> Parser a) -> Parser RLPObject
longParser Word8
0xB7 ByteString -> RLPObject
String ByteString -> Parser ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return

shortListParser :: Parser RLPObject
shortListParser :: Parser RLPObject
shortListParser = Word8
-> ([RLPObject] -> RLPObject)
-> (ByteString -> Parser [RLPObject])
-> [RLPObject]
-> Parser RLPObject
forall a.
Word8
-> (a -> RLPObject)
-> (ByteString -> Parser a)
-> a
-> Parser RLPObject
shortParser Word8
0xC0 [RLPObject] -> RLPObject
Array ByteString -> Parser [RLPObject]
parseListPayload []

longListParser :: Parser RLPObject
longListParser :: Parser RLPObject
longListParser = Word8
-> ([RLPObject] -> RLPObject)
-> (ByteString -> Parser [RLPObject])
-> Parser RLPObject
forall a.
Word8
-> (a -> RLPObject) -> (ByteString -> Parser a) -> Parser RLPObject
longParser Word8
0xF7 [RLPObject] -> RLPObject
Array ByteString -> Parser [RLPObject]
parseListPayload

parseListPayload :: S.ByteString -> Parser [RLPObject]
parseListPayload :: ByteString -> Parser [RLPObject]
parseListPayload ByteString
pl = case Parser RLPObject -> ByteString -> Result RLPObject
forall a. Parser a -> ByteString -> Result a
parse Parser RLPObject
rlpParser ByteString
pl of
    Done ByteString
rem RLPObject
res -> if ByteString -> Bool
S8.null ByteString
rem
        then [RLPObject] -> Parser [RLPObject]
forall (m :: * -> *) a. Monad m => a -> m a
return [RLPObject
res]
        else (RLPObject
resRLPObject -> [RLPObject] -> [RLPObject]
forall a. a -> [a] -> [a]
:) ([RLPObject] -> [RLPObject])
-> Parser [RLPObject] -> Parser [RLPObject]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Parser [RLPObject]
parseListPayload ByteString
rem
    Partial ByteString -> Result RLPObject
_    ->
        String -> Parser [RLPObject]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Partial result when parsing an RLP list member, this should be impossible."
    Fail ByteString
rem [String]
ctxs String
err ->
        String -> Parser [RLPObject]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser [RLPObject]) -> String -> Parser [RLPObject]
forall a b. (a -> b) -> a -> b
$ String
"RLP list member parse failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ctxs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Remaining data: \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
S8.unpack ByteString
rem String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""

rlpParser :: Parser RLPObject
rlpParser :: Parser RLPObject
rlpParser =  Parser RLPObject -> Parser RLPObject
forall i a. Parser i a -> Parser i a
try (Parser RLPObject
singleByteParser  Parser RLPObject -> String -> Parser RLPObject
forall i a. Parser i a -> String -> Parser i a
<?> String
"single byte")
         Parser RLPObject -> Parser RLPObject -> Parser RLPObject
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser RLPObject -> Parser RLPObject
forall i a. Parser i a -> Parser i a
try (Parser RLPObject
longStringParser  Parser RLPObject -> String -> Parser RLPObject
forall i a. Parser i a -> String -> Parser i a
<?> String
"long string")  -- long string/list go first since we dont want the error
         Parser RLPObject -> Parser RLPObject -> Parser RLPObject
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser RLPObject -> Parser RLPObject
forall i a. Parser i a -> Parser i a
try (Parser RLPObject
shortStringParser Parser RLPObject -> String -> Parser RLPObject
forall i a. Parser i a -> String -> Parser i a
<?> String
"short string") -- message saying it failed parsing a long list cause it fell
         Parser RLPObject -> Parser RLPObject -> Parser RLPObject
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser RLPObject -> Parser RLPObject
forall i a. Parser i a -> Parser i a
try (Parser RLPObject
longListParser    Parser RLPObject -> String -> Parser RLPObject
forall i a. Parser i a -> String -> Parser i a
<?> String
"long list")    -- through after failing to correctly parse a short one
         Parser RLPObject -> Parser RLPObject -> Parser RLPObject
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser RLPObject -> Parser RLPObject
forall i a. Parser i a -> Parser i a
try (Parser RLPObject
shortListParser   Parser RLPObject -> String -> Parser RLPObject
forall i a. Parser i a -> String -> Parser i a
<?> String
"short list")


unpackRLP :: S.ByteString -> Either String RLPObject
unpackRLP :: ByteString -> Either String RLPObject
unpackRLP ByteString
input = case Parser RLPObject -> ByteString -> Either String RLPObject
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser RLPObject
rlpParser ByteString
input of
    Left String
err -> String -> Either String RLPObject
forall a b. a -> Either a b
Left (String -> Either String RLPObject)
-> String -> Either String RLPObject
forall a b. (a -> b) -> a -> b
$ String
"Parse failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err -- to have consistent errors w/ `parseRLPFully`
    Either String RLPObject
r        -> Either String RLPObject
r

unpackRLPFully :: S.ByteString -> Either String RLPObject
unpackRLPFully :: ByteString -> Either String RLPObject
unpackRLPFully ByteString
input = Result RLPObject -> Either String RLPObject
forall b. IResult ByteString b -> Either String b
handleResult (Result RLPObject -> Either String RLPObject)
-> Result RLPObject -> Either String RLPObject
forall a b. (a -> b) -> a -> b
$ Parser RLPObject -> ByteString -> Result RLPObject
forall a. Parser a -> ByteString -> Result a
parse Parser RLPObject
rlpParser ByteString
input
    where handleResult :: IResult ByteString b -> Either String b
handleResult = \case
            Done ByteString
rem b
res -> if ByteString -> Bool
S8.null ByteString
rem
                then b -> Either String b
forall a b. b -> Either a b
Right b
res
                else String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ String
"Incomplete parse, leftover data: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
S8.unpack ByteString
rem
            Fail ByteString
rem [String]
ctxs String
err ->
                String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ String
"Parse failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ctxs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Remaining data: \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
S8.unpack ByteString
rem String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
            Partial ByteString -> IResult ByteString b
cont -> IResult ByteString b -> Either String b
handleResult (ByteString -> IResult ByteString b
cont ByteString
S8.empty)

packRLP :: RLPObject -> S.ByteString
packRLP :: RLPObject -> ByteString
packRLP RLPObject
o = case RLPObject
o of
    String ByteString
s -> ByteString -> ByteString
packString ByteString
s
    Array [RLPObject]
xs -> [RLPObject] -> ByteString
packList [RLPObject]
xs
    where packString :: ByteString -> ByteString
packString ByteString
s | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0  = Word8 -> ByteString
S.singleton Word8
0x80
                       | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1  = Word8 -> ByteString
packSingleChar (ByteString -> Word8
S.head ByteString
s)
                       | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
55 = Word8 -> ByteString -> ByteString
S.cons (Word8
0x80 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) ByteString
s
                       | Bool
otherwise = Word8 -> ByteString -> ByteString
prefixLength Word8
0xB7 ByteString
s
                       where len :: Int
len = ByteString -> Int
S.length ByteString
s

          packSingleChar :: Word8 -> ByteString
packSingleChar Word8
c | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x7F = Word8 -> ByteString
S.singleton Word8
c
                           | Bool
otherwise = [Word8] -> ByteString
S.pack [Word8
0x81, Word8
c]

          packList :: [RLPObject] -> ByteString
packList [RLPObject]
xs | Int
payloadLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
55 = Word8 -> ByteString -> ByteString
S.cons (Word8
0xC0 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
payloadLength) ByteString
packedPayload
                      | Bool
otherwise = Word8 -> ByteString -> ByteString
prefixLength Word8
0xF7 ByteString
packedPayload
                      where packedPayload :: ByteString
packedPayload = [ByteString] -> ByteString
S.concat (RLPObject -> ByteString
packRLP (RLPObject -> ByteString) -> [RLPObject] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RLPObject]
xs)
                            payloadLength :: Int
payloadLength = ByteString -> Int
S.length ByteString
packedPayload

          prefixLength :: Word8 -> ByteString -> ByteString
prefixLength Word8
base ByteString
str = (Word8
prefixed Word8 -> ByteString -> ByteString
`S.cons` ByteString
pLen) ByteString -> ByteString -> ByteString
`S.append` ByteString
str
              where len :: Int
len      = ByteString -> Int
S.length ByteString
str
                    pLen :: ByteString
pLen     = [Word8] -> ByteString
S.pack (Int -> [Word8]
forall n. (FiniteBits n, Integral n) => n -> [Word8]
packFiniteBE Int
len)
                    pLenLen :: Word8
pLenLen  = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
pLen)
                    prefixed :: Word8
prefixed = Word8
base Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
pLenLen

rlpSerialize :: RLPEncodable a => a -> S.ByteString
rlpSerialize :: a -> ByteString
rlpSerialize = RLPObject -> ByteString
packRLP (RLPObject -> ByteString) -> (a -> RLPObject) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> RLPObject
forall a. RLPEncodable a => a -> RLPObject
rlpEncode

rlpDeserialize :: RLPEncodable a => S.ByteString -> Either String a
rlpDeserialize :: ByteString -> Either String a
rlpDeserialize = RLPObject -> Either String a
forall a. RLPEncodable a => RLPObject -> Either String a
rlpDecode (RLPObject -> Either String a)
-> (ByteString -> Either String RLPObject)
-> ByteString
-> Either String a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteString -> Either String RLPObject
unpackRLP