{-# 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")
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")
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")
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
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