diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2016 Ilya Ostrovskiy + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/relapse.cabal b/relapse.cabal new file mode 100644 --- /dev/null +++ b/relapse.cabal @@ -0,0 +1,46 @@ +name: relapse +version: 0.1.0.0 +synopsis: Sensible RLP encoding +description: An implementation of RLP as specified in the Ethereum Wiki, using Attoparsec +homepage: https://github.com/iostat/relapse#readme +license: MIT +license-file: LICENSE +author: Ilya Ostrovskiy +maintainer: firstname at thenumbertwohundred thewordproof dotcc +copyright: 2017 Ilya Ostrovskiy +category: Data +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Data.RLP + , Data.RLP.Types + build-depends: base >= 4.7 && < 5 + , attoparsec + , bytestring + default-language: Haskell2010 + +test-suite relapse-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base + , containers + , bytestring + , base16-bytestring + , text + , vector + , aeson + , tasty + , tasty-hspec + , include-file + , relapse + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + other-modules: RLPTest + +source-repository head + type: git + location: https://github.com/iostat/relapse diff --git a/src/Data/RLP.hs b/src/Data/RLP.hs new file mode 100644 --- /dev/null +++ b/src/Data/RLP.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +module Data.RLP + ( RLPObject(..) + , RLPEncodable(..) + , rlpParser + , unpackRLP + , unpackRLPFully + , packRLP + , module Data.RLP.Types + ) where + +import Control.Applicative ((<|>)) +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 +import Debug.Trace +singleByteParser :: Parser RLPObject +singleByteParser = (String . S.singleton) <$> satisfy (<= 0x7F) + +shortParser :: Word8 -> (a -> RLPObject) -> (S.ByteString -> Parser a) -> a -> Parser RLPObject +shortParser base constructor postProcessor def = do + len <- fromIntegral . subtract base <$> satisfy (\x -> x >= base && x <= (base + 55)) + if len == 0 + then return (constructor def) + else constructor <$> (take len >>= postProcessor) + +longParser :: Word8 -> (a -> RLPObject) -> (S.ByteString -> Parser a) -> Parser RLPObject +longParser base constructor postProcessor = do + lengthLength <- fromIntegral . subtract base <$> satisfy (\x -> x > base && x <= (base + 8)) + payloadLen <- unpackBE . S.unpack <$> take lengthLength + constructor <$> (take payloadLen >>= postProcessor) + +shortStringParser :: Parser RLPObject +shortStringParser = shortParser 0x80 String return S.empty + +longStringParser :: Parser RLPObject +longStringParser = longParser 0xB7 String return + +shortListParser :: Parser RLPObject +shortListParser = shortParser 0xC0 Array parseListPayload [] + +longListParser :: Parser RLPObject +longListParser = longParser 0xF7 Array parseListPayload + +parseListPayload :: S.ByteString -> Parser [RLPObject] +parseListPayload pl = case parse rlpParser pl of + Done rem res -> if S8.null rem + then return [res] + else (res:) <$> parseListPayload rem + Partial _ -> + fail "Partial result when parsing an RLP list member, this should be impossible." + Fail rem ctxs err -> + fail $ "RLP list member parse failed: " ++ intercalate ", " ctxs ++ ": " ++ err + ++ ". Remaining data: \"" ++ S8.unpack rem ++ "\"" + +rlpParser :: Parser RLPObject +rlpParser = try (singleByteParser "single byte") + <|> try (longStringParser "long string") -- long string/list go first since we dont want the error + <|> try (shortStringParser "short string") -- message saying it failed parsing a long list cause it fell + <|> try (longListParser "long list") -- through after failing to correctly parse a short one + <|> try (shortListParser "short list") + + +unpackRLP :: S.ByteString -> Either String RLPObject +unpackRLP input = case parseOnly rlpParser input of + Left err -> Left $ "Parse failed: " ++ err -- to have consistent errors w/ `parseRLPFully` + r -> r + +unpackRLPFully :: S.ByteString -> Either String RLPObject +unpackRLPFully input = handleResult $ parse rlpParser input + where handleResult = \case + Done rem res -> if S8.null rem + then Right res + else Left $ "Incomplete parse, leftover data: " ++ S8.unpack rem + Fail rem ctxs err -> + Left $ "Parse failed: " ++ intercalate ", " ctxs ++ ": " ++ err + ++ ". Remaining data: \"" ++ S8.unpack rem ++ "\"" + Partial cont -> handleResult (cont S8.empty) + +packRLP :: RLPObject -> S.ByteString +packRLP o = case o of + String s -> packString s + Array xs -> packList xs + where packString s | len == 0 = S.singleton 0x80 + | len == 1 = packSingleChar (S.head s) + | len <= 55 = S.cons (0x80 + fromIntegral len) s + | otherwise = prefixLength 0xB7 s + where len = S.length s + + packSingleChar c | c <= 0x7F = S.singleton c + | otherwise = S.pack [0x81, c] + + packList xs | payloadLength <= 55 = S.cons (0xC0 + fromIntegral payloadLength) packedPayload + | otherwise = prefixLength 0xF7 packedPayload + where packedPayload = S.concat (packRLP <$> xs) + payloadLength = S.length packedPayload + + prefixLength base str = (prefixed `S.cons` pLen) `S.append` str + where len = S.length str + pLen = S.pack (packFiniteBE len) + pLenLen = fromIntegral (S.length pLen) + prefixed = base + pLenLen diff --git a/src/Data/RLP/Types.hs b/src/Data/RLP/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/RLP/Types.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS -fno-warn-orphans #-} +module Data.RLP.Types where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 + +import Data.Bits +import Data.Char (ord) +import Data.Foldable +import Data.Int +import Data.List (foldl') +import Data.Word + +data RLPObject = String S.ByteString | Array [RLPObject] deriving (Eq, Ord, Read, Show) + +class RLPEncodable a where + rlpEncode :: a -> RLPObject + rlpDecode :: RLPObject -> Either String a + +rlpEncodeFinite :: (FiniteBits n, Integral n) => n -> RLPObject +rlpEncodeFinite = rlpEncode . S.pack . packFiniteBE +{-# INLINE rlpEncodeFinite #-} + +rlpDecodeIntegralBE :: (Bits n, Integral n) => RLPObject -> Either String n +rlpDecodeIntegralBE = \case + String s -> Right . unpackBE $ S.unpack s + x -> rlpDecodeFail "String" x +{-# INLINE rlpDecodeIntegralBE #-} + +rlpDecodeFail :: String -> RLPObject -> Either String a +rlpDecodeFail myType instead = + Left $ "Expected an RLPObject that's isomorphic to " ++ myType ++ ", instead got " ++ show instead +{-# INLINE rlpDecodeFail #-} + +-- todo: more efficient? +unpackBE :: (Bits n, Integral n) => [Word8] -> n +unpackBE words = foldl' (.|.) 0 shifted + where shifts = [((wc - 1) * 8), ((wc - 2) * 8)..0] + wc = length words + doShift word shift = fromIntegral word `shiftL` shift + shifted = zipWith doShift words shifts +{-# INLINE unpackBE #-} + +-- todo: ditto +packFiniteBE :: (FiniteBits n, Integral n) => n -> [Word8] +packFiniteBE n = packWithByteCount byteCount n + where byteCount = (finiteBitSize n + 7) `quot` 8 +{-# INLINE packFiniteBE #-} + +packIntegerBE :: Integer -> [Word8] +packIntegerBE n = packWithByteCount byteCount n + where byteCount = (bitCount + 7) `quot` 8 + bitCount = floor (logBase 2 $ fromIntegral n) + 1 +{-# INLINE packIntegerBE #-} + +packWithByteCount :: (Bits n, Integral n) => Int -> n -> [Word8] +packWithByteCount byteCount n = dropWhile (== 0) $ zipWith f rep shifts + where rep = replicate byteCount n + shifts = [((byteCount - 1) * 8), ((byteCount - 2) * 8)..0] + f r s = fromIntegral (r `shiftR` s) +{-# INLINE packWithByteCount #-} + +instance RLPEncodable S.ByteString where + rlpEncode = String + rlpDecode = \case + String s -> Right s + x -> rlpDecodeFail "String" x + +instance RLPEncodable String where + rlpEncode = String . S8.pack + rlpDecode = \case + String s -> Right (S8.unpack s) + x -> rlpDecodeFail "String" x + +instance RLPEncodable Int where + rlpEncode = rlpEncodeFinite + rlpDecode = rlpDecodeIntegralBE + +instance RLPEncodable Word16 where + rlpEncode = rlpEncodeFinite + rlpDecode = rlpDecodeIntegralBE + +instance RLPEncodable Word32 where + rlpEncode = rlpEncodeFinite + rlpDecode = rlpDecodeIntegralBE + +instance RLPEncodable Word64 where + rlpEncode = rlpEncodeFinite + rlpDecode = rlpDecodeIntegralBE + +instance (RLPEncodable a) => RLPEncodable [a] where + rlpEncode = Array . toList . fmap rlpEncode + rlpDecode = \case + Array xs -> sequence $ rlpDecode <$> xs + x -> rlpDecodeFail "Array" x + +instance RLPEncodable RLPObject where -- ayy lmao + rlpEncode = id + rlpDecode = Right + +instance RLPEncodable Integer where + rlpEncode = rlpEncode . S.pack . packIntegerBE + rlpDecode = rlpDecodeIntegralBE + +instance RLPEncodable Char where + rlpEncode = rlpEncodeFinite . ord + rlpDecode = \case + String s | S.length s == 1 -> Right (S8.head s) + x -> rlpDecodeFail "String of length 1" x diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} +import Control.Monad (forM_, when) +import Data.Either (isRight) +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +import qualified Data.ByteString as S +import qualified Data.ByteString.Base16 as SB16 + +import qualified Test.Tasty as Tasty +import Test.Tasty.Hspec + +import Data.RLP +import RLPTest + +main :: IO () +main = do + putStrLn "" -- cabal doesn't put a \n before running the test and that makes me D:< + test <- testSpec "ReLaPse" specsFromJSON + Tasty.defaultMain test + +specsFromJSON :: Spec +specsFromJSON = do + it "should be able to load the embedded tests" $ + officialRLPTests `shouldSatisfy` isRight + + case officialRLPTests of + Left err -> runIO . putStrLn $ "Could not load official tests: " ++ err + Right tests -> + describe "Official RLP Tests" $ forM_ tests makeTest + +makeTest :: (T.Text, RLPTest) -> SpecWith () +makeTest (name, test) = describe (T.unpack name) $ do + let theInput = input test + preOutput = output test + decOutput = SB16.decode (TE.encodeUtf8 preOutput) + + it "should fully read the base-16 encoded expected output in the test case" $ + decOutput `shouldSatisfy` didDecodeFully + + when (didDecodeFully decOutput) $ do + let (theOutput, _) = decOutput + describe "the input" $ do + let theInput = input test + theEncode = rlpEncode theInput + theDecode = rlpDecode theEncode + + it "should decode to something after being encoded" $ + theDecode `shouldSatisfy` isRight + + case theDecode of + Left err -> return () + Right decoded -> do + it "should maintain (decode . encode) == id" $ + decoded `shouldBe` theInput + + it "should serialize to the expected output" $ do + let packed = packRLP theEncode + packed `shouldBe` theOutput + + describe "the output" $ do + let unpackedOutput = unpackRLPFully theOutput + it "should unpack completely to an RLP object" $ + unpackedOutput `shouldSatisfy` isRight + + case unpackedOutput of + Left err -> return () + Right unpackedRlpObj -> do + let decodedUnpack = rlpDecode unpackedRlpObj + it "should decode to something that can satisfy the input's type" $ + decodedUnpack `shouldSatisfy` isRight + + case decodedUnpack of + Left err -> return () + Right du' -> + it "should decode back to the input" $ + du' `shouldBe` theInput + + +didDecodeFully :: (S.ByteString, S.ByteString) -> Bool +didDecodeFully (_, "") = True +didDecodeFully (_, _) = False diff --git a/test/RLPTest.hs b/test/RLPTest.hs new file mode 100644 --- /dev/null +++ b/test/RLPTest.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +module RLPTest where + +import Control.Monad (sequence) +import Data.Aeson +import Data.Aeson.Types (typeMismatch) +import Data.ByteString +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map.Strict as M +import Data.Maybe (fromJust) +import Data.Semigroup ((<>)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V + +import Development.IncludeFile + +import qualified Data.RLP as RLP + +data RLPTestInput = StringInput ByteString + | NumberInput Integer + | ListInput [RLPTestInput] + deriving (Read, Show) + +-- The test JSON takes advantage of the fact that you can mix and match types in JSON arrays +-- so naturally, that doesn't play well with haskell, and we can't *REALLY* make FromJSON and ToJSON +-- maintain identity. So we cheat :P. Our biggest issue is that RLP doesn't have an "Integer" type +-- it's effectively stored as a big-endian String. So we need to really handle the case of +-- StringInput == NumberInput and vice versa +instance Eq RLPTestInput where + (StringInput s1) == (StringInput s2) = s1 == s2 + (NumberInput n1) == (NumberInput n2) = n1 == n2 + (ListInput l1) == (ListInput l2) = l1 == l2 + + StringInput{} == ListInput{} = False -- impossible + (StringInput s) == (NumberInput n) = RLP.unpackBE (unpack s) == n -- todo this case + + NumberInput{} == ListInput{} = False -- also impossible + n@NumberInput{} == s@StringInput{} = s == n -- take advantage of the commutative case + + o1 == o2 = False + +instance RLP.RLPEncodable RLPTestInput where + rlpEncode (StringInput s) = RLP.String s + rlpEncode (NumberInput n) = RLP.rlpEncode n + rlpEncode (ListInput xs) = RLP.Array $ RLP.rlpEncode <$> xs + + rlpDecode (RLP.String s) = Right (StringInput s) -- todo this totes wont work for NumInputs + rlpDecode (RLP.Array xs) = ListInput <$> sequence (RLP.rlpDecode <$> xs) + +data RLPTest = RLPTest { input :: RLPTestInput, output :: T.Text } + deriving (Eq, Read, Show) + +instance FromJSON RLPTestInput where + parseJSON (String s) | T.null s = return (StringInput "") + | otherwise = case T.head s of + '#' -> return . NumberInput . read . T.unpack $ T.tail s + _ -> return . StringInput $ TE.encodeUtf8 s + parseJSON (Number n) = return . NumberInput $ round n + parseJSON (Array a) = ListInput . V.toList <$> V.forM a parseJSON + parseJSON x = typeMismatch "RLPTestInput" x + +instance ToJSON RLPTestInput where + toJSON (StringInput s) = String $ TE.decodeUtf8 s + toJSON (NumberInput n) = Number $ fromIntegral n + toJSON (ListInput xs) = toJSON xs + +instance FromJSON RLPTest where + parseJSON (Object o) = RLPTest <$> (o .: "in") <*> (o .: "out") + parseJSON x = typeMismatch "RLPTest" x + +instance ToJSON RLPTest where + toJSON RLPTest{..} = object [ "in" .= input, "out" .= output ] + toEncoding RLPTest{..} = pairs ( "in" .= input <> "out" .= output ) + +$(includeFileInSource "test/resources/rlptest.json" "officialRLPTests'") + +officialRLPTests :: Either String [(T.Text, RLPTest)] +officialRLPTests = M.toList <$> eitherDecode (BL.fromStrict officialRLPTests')