packages feed

relapse (empty) → 0.1.0.0

raw patch · 8 files changed

+455/−0 lines, 8 filesdep +aesondep +attoparsecdep +basesetup-changed

Dependencies added: aeson, attoparsec, base, base16-bytestring, bytestring, containers, include-file, relapse, tasty, tasty-hspec, text, vector

Files

+ LICENSE view
@@ -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.
+ README.md view
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ relapse.cabal view
@@ -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
+ src/Data/RLP.hs view
@@ -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
+ src/Data/RLP/Types.hs view
@@ -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
+ test/Main.hs view
@@ -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
+ test/RLPTest.hs view
@@ -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')