bencoding (empty) → 0.1.0.0
raw patch · 9 files changed
+817/−0 lines, 9 filesdep +AttoBencodedep +QuickCheckdep +attoparsecsetup-changed
Dependencies added: AttoBencode, QuickCheck, attoparsec, base, bencode, bencoding, bytestring, containers, criterion, deepseq, pretty, test-framework, test-framework-quickcheck2, text
Files
- .travis.yml +10/−0
- LICENSE +19/−0
- README.md +57/−0
- Setup.hs +2/−0
- bench/Main.hs +93/−0
- bencoding.cabal +87/−0
- pp/pp.hs +14/−0
- src/Data/BEncode.hs +505/−0
- tests/properties.hs +30/−0
+ .travis.yml view
@@ -0,0 +1,10 @@+language: haskell++notifications:+ email: false++install:+ cabal install --enable-tests --enable-benchmark --force-reinstalls --only-dependencies++script:+ cabal configure --enable-tests --enable-benchmark && cabal build && cabal test
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2012 Sam T.++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
@@ -0,0 +1,57 @@+# Synopsis++[BEncode][bencode] is [JSON][json-ref]-like format used in bittorrent+protocol but might be used anywhere else.++# Description++This package implements fast seamless encoding/decoding to/from+bencode format for many native datatypes. To achive+[more performance][cmp] we use [bytestring builders][bytestring-builder]+and hand optimized [attoparsec][attoparsec] parser so this library is+considered as replacement for BEncode and AttoBencode packages.++## Format++Bencode is pretty similar to JSON: it has dictionaries(JSON objects),+lists(JSON arrays), strings and integers. However bencode has a few+advantages:++* Compactness: no spaces in between any values — nor lists nor dicts+ nor anywhere else.+* Dictionaries always sorted lexicographically by the keys. This allow+ us to test data on equality without decoding from raw bytestring.+ Moreover this allow to hash encoded data (this property is heavily+ used by core bittorrent protocol).+* All strings prefixed with its length. This simplifies and speed up+ string parsing.++Hovewer there are some disadvantages comparing with JSON:++* Bencode is certainly less human readable.+* Bencode is rarely used, except bittorrent protocol of course.++# Documentation++For documentation see haddock generated documentation.++# Build Status++[![Build Status][travis-img]][travis-log]++# Authors++This library is written and maintained by Sam T. <pxqr.sta@gmail.com>++Feel free to report bugs and suggestions via github issue tracker or the mail.+++[cmp]: http://htmlpreview.github.com/?https://github.com/pxqr/bencoding/master/bench/comparison.html++[bencode]: https://wiki.theory.org/BitTorrentSpecification#Bencoding+[json-ref]: http://www.json.org/+[attoparsec]: http://hackage.haskell.org/package/attoparsec-0.10.4.0+[bytestring-builder]: http://hackage.haskell.org/packages/archive/bytestring/0.10.2.0/doc/html/Data-ByteString-Builder.html++[travis-img]: https://travis-ci.org/pxqr/bencoding.png+[travis-log]: https://travis-ci.org/pxqr/bencoding
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE PackageImports #-}+module Main (main) where++import Control.DeepSeq+import Data.Maybe+import Data.Attoparsec.ByteString as Atto+import Data.ByteString as B+import Data.ByteString.Lazy as BL+import Data.List as L+import Criterion.Main+import System.Environment++import "bencode" Data.BEncode as A+import Data.AttoBencode as B+import Data.AttoBencode.Parser as B+import "bencoding" Data.BEncode as C++instance NFData A.BEncode where+ rnf (A.BInt i) = rnf i+ rnf (A.BString s) = rnf s+ rnf (A.BList l) = rnf l+ rnf (A.BDict m) = rnf m++instance NFData B.BValue where+ rnf (B.BInt i) = rnf i+ rnf (B.BString s) = rnf s+ rnf (B.BList l) = rnf l+ rnf (B.BDict d) = rnf d++instance NFData C.BEncode where+ rnf (C.BInteger i) = rnf i+ rnf (C.BString s) = rnf s+ rnf (C.BList l) = rnf l+ rnf (C.BDict d) = rnf d++getRight :: Either String a -> a+getRight (Left e) = error e+getRight (Right x) = x++main :: IO ()+main = do+ (path : args) <- getArgs+ torrentFile <- B.readFile path+ let lazyTorrentFile = fromChunks [torrentFile]++ case rnf (torrentFile, lazyTorrentFile) of+ () -> return ()++ withArgs args $+ defaultMain+ [ bench "decode/bencode" $ nf A.bRead lazyTorrentFile+ , bench "decode/AttoBencode" $ nf (getRight . Atto.parseOnly bValue) torrentFile+ , bench "decode/bencoding" $ nf (getRight . C.decode) torrentFile++ , let Just v = A.bRead lazyTorrentFile in+ bench "encode/bencode" $ nf A.bPack v+ , let Right v = Atto.parseOnly bValue torrentFile in+ bench "encode/AttoBencode" $ nf B.encode v+ , let Right v = C.decode torrentFile in+ bench "encode/bencoding" $ nf C.encode v++ , bench "decode+encode/bencode" $ nf (A.bPack . fromJust . A.bRead)+ lazyTorrentFile+ , bench "decode+encode/AttoBencode" $ nf (B.encode . getRight . Atto.parseOnly bValue)+ torrentFile+ , bench "decode+encode/bencoding" $ nf (C.encode . getRight . C.decode)+ torrentFile++ , bench "list10000int/bencode/encode" $ nf+ (A.bPack . A.BList . L.map (A.BInt . fromIntegral))+ [0..10000 :: Int]++ , bench "list10000int/attobencode/encode" $ nf B.encode [1..20000 :: Int]+ , bench "list10000int/bencoding/encode" $ nf C.encoded [1..20000 :: Int]+++ , let d = A.bPack $ A.BList $+ L.map A.BInt (L.replicate 1000 (0 :: Integer))+ in d `seq` (bench "list1000int/bencode/decode" $ nf+ (fromJust . A.bRead :: BL.ByteString -> A.BEncode) d)++ , let d = BL.toStrict (C.encoded (L.replicate 10000 ()))+ in d `seq` (bench "list10000unit/bencoding/decode" $ nf+ (C.decoded :: B.ByteString -> Either String [()]) d)++ , let d = BL.toStrict $ C.encoded $ L.replicate 10000 (0 :: Int)+ in d `seq` (bench "list10000int/bencoding/decode" $ nf+ (C.decoded :: B.ByteString -> Either String [Int]) d)++ , let d = L.replicate 10000 0+ in bench "list10000int/bencoding/encode>>decode" $ nf+ (getRight . C.decoded . BL.toStrict . C.encoded :: [Int] -> [Int] ) d+ ]
+ bencoding.cabal view
@@ -0,0 +1,87 @@+name: bencoding+version: 0.1.0.0+synopsis: A library for encoding and decoding of BEncode data.+homepage: https://github.com/pxqr/bencoding+bug-reports: https://github.com/pxqr/bencoding/issues+license: MIT+license-file: LICENSE+author: Sam T.+maintainer: Sam T. <pxqr.sta@gmail.com>+copyright: (c) 2013, Sam T.+category: Data+build-type: Simple+cabal-version: >= 1.8+description:++ A library for encoding and decoding of BEncode data.+ .+ [/Release notes/]+ .+ * /0.1.0.0:/ Initial version.+++extra-source-files: README.md .travis.yml++source-repository head+ type: git+ location: git://github.com/pxqr/bencoding.git+++library+ exposed-modules: Data.BEncode+ build-depends: base == 4.*+ , containers >= 0.4+ , bytestring >= 0.10.2.0+ , attoparsec >= 0.10+ , text >= 0.11+ , pretty++ hs-source-dirs: src+ extensions: PatternGuards+ ghc-options: -Wall -fno-warn-unused-do-bind+++executable pp+ main-is: pp.hs+ build-depends: base == 4.*+ , bytestring+ , bencoding+ hs-source-dirs: pp+ ghc-options: -Wall+++test-suite properties+ type: exitcode-stdio-1.0+ main-is: properties.hs+ hs-source-dirs: tests++ build-depends: base == 4.*+ , containers >= 0.4+ , bytestring >= 0.10.2.0+ , attoparsec >= 0.10++ , test-framework+ , test-framework-quickcheck2+ , QuickCheck+ , bencoding++ ghc-options: -Wall -fno-warn-orphans+++benchmark bench-comparison+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench++ build-depends: base == 4.*+ , attoparsec >= 0.10+ , bytestring >= 0.10.2.0++ , criterion+ , deepseq++ , bencoding+ , bencode >= 0.5+ , AttoBencode >= 0.2++ ghc-options: -O2 -Wall -fno-warn-orphans
+ pp/pp.hs view
@@ -0,0 +1,14 @@+module Main (main) where++import Data.BEncode+import qualified Data.ByteString as B+import System.IO+import System.Environment++main :: IO ()+main = do+ path : _ <- getArgs+ content <- B.readFile path+ case decode content of+ Left e -> hPutStrLn stderr e+ Right be -> printPretty be
+ src/Data/BEncode.hs view
@@ -0,0 +1,505 @@+-- TODO: make int's instances platform independent so we can make library portable.+-- |+-- Copyright : (c) Sam T. 2013+-- License : MIT+-- Maintainer : pxqr.sta@gmail.com+-- Stability : stable+-- Portability : non-portable+--+-- This module provides convinient and fast way to serialize, deserealize+-- and construct/destructure Bencoded values with optional fields.+--+-- It supports four different types of values:+--+-- * byte strings — represented as 'ByteString';+--+-- * integers — represented as 'Integer';+--+-- * lists - represented as ordinary lists;+--+-- * dictionaries — represented as 'Map';+--+-- To serialize any other types we need to make conversion.+-- To make conversion more convenient there is type class for it: 'BEncodable'.+-- Any textual strings are considered as UTF8 encoded 'Text'.+--+-- The complete Augmented BNF syntax for bencoding format is:+--+--+-- > <BE> ::= <DICT> | <LIST> | <INT> | <STR>+-- >+-- > <DICT> ::= "d" 1 * (<STR> <BE>) "e"+-- > <LIST> ::= "l" 1 * <BE> "e"+-- > <INT> ::= "i" <SNUM> "e"+-- > <STR> ::= <NUM> ":" n * <CHAR>; where n equals the <NUM>+-- >+-- > <SNUM> ::= "-" <NUM> / <NUM>+-- > <NUM> ::= 1 * <DIGIT>+-- > <CHAR> ::= %+-- > <DIGIT> ::= "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9"+--+--+-- This module is considered to be imported qualified.+--+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Trustworthy #-}+module Data.BEncode+ ( -- * Datatype+ BEncode(..)++ -- * Construction && Destructuring+ , BEncodable (..), dictAssoc, Result++ -- ** Dictionaries+ -- *** Building+ , (-->), (-->?), fromAssocs, fromAscAssocs++ -- *** Extraction+ , reqKey, optKey, (>--), (>--?)++ -- * Serialization+ , encode, decode+ , encoded, decoded++ -- * Predicates+ , isInteger, isString, isList, isDict++ -- * Extra+ , builder, parser, decodingError, printPretty+ ) where+++import Control.Applicative+import Control.Monad+import Data.Int+import Data.Maybe (mapMaybe)+import Data.Monoid ((<>))+import Data.Foldable (foldMap)+import Data.Traversable (traverse)+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Set (Set)+import qualified Data.Set as S+import Data.Attoparsec.ByteString.Char8 (Parser)+import qualified Data.Attoparsec.ByteString.Char8 as P+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as Lazy+import Data.ByteString.Internal as B (c2w, w2c)+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Builder.Prim as BP (int64Dec, primBounded)+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import Data.Version+import Text.PrettyPrint hiding ((<>))+import qualified Text.ParserCombinators.ReadP as ReadP++++type Dict = Map ByteString BEncode++-- | 'BEncode' is straightforward ADT for b-encoded values.+-- Please note that since dictionaries are sorted, in most cases we can+-- compare BEncoded values without serialization and vice versa.+-- Lists is not required to be sorted through.+-- Also note that 'BEncode' have JSON-like instance for 'Pretty'.+--+data BEncode = BInteger {-# UNPACK #-} !Int64+ | BString !ByteString+ | BList [BEncode]+ | BDict Dict+ deriving (Show, Read, Eq, Ord)++type Result = Either String++class BEncodable a where+ toBEncode :: a -> BEncode+ fromBEncode :: BEncode -> Result a+++decodingError :: String -> Result a+decodingError s = Left ("fromBEncode: unable to decode " ++ s)+{-# INLINE decodingError #-}++instance BEncodable BEncode where+ {-# SPECIALIZE instance BEncodable BEncode #-}+ toBEncode = id+ {-# INLINE toBEncode #-}++ fromBEncode = Right+ {-# INLINE fromBEncode #-}++instance BEncodable Int where+ {-# SPECIALIZE instance BEncodable Int #-}+ toBEncode = BInteger . fromIntegral+ {-# INLINE toBEncode #-}++ fromBEncode (BInteger i) = Right (fromIntegral i)+ fromBEncode _ = decodingError "integer"+ {-# INLINE fromBEncode #-}++instance BEncodable Bool where+ toBEncode = toBEncode . fromEnum+ {-# INLINE toBEncode #-}++ fromBEncode b = do+ i <- fromBEncode b+ case i :: Int of+ 0 -> return False+ 1 -> return True+ _ -> decodingError "bool"+ {-# INLINE fromBEncode #-}+++instance BEncodable Integer where+ toBEncode = BInteger . fromIntegral+ {-# INLINE toBEncode #-}++ fromBEncode b = fromIntegral <$> (fromBEncode b :: Result Int)+ {-# INLINE fromBEncode #-}+++instance BEncodable ByteString where+ toBEncode = BString+ {-# INLINE toBEncode #-}++ fromBEncode (BString s) = Right s+ fromBEncode _ = decodingError "string"+ {-# INLINE fromBEncode #-}+++instance BEncodable Text where+ toBEncode = toBEncode . T.encodeUtf8+ {-# INLINE toBEncode #-}++ fromBEncode b = T.decodeUtf8 <$> fromBEncode b+ {-# INLINE fromBEncode #-}++instance BEncodable a => BEncodable [a] where+ {-# SPECIALIZE instance BEncodable [BEncode] #-}++ toBEncode = BList . map toBEncode+ {-# INLINE toBEncode #-}++ fromBEncode (BList xs) = mapM fromBEncode xs+ fromBEncode _ = decodingError "list"+ {-# INLINE fromBEncode #-}+++instance BEncodable a => BEncodable (Map ByteString a) where+ {-# SPECIALIZE instance BEncodable (Map ByteString BEncode) #-}++ toBEncode = BDict . M.map toBEncode+ {-# INLINE toBEncode #-}++ fromBEncode (BDict d) = traverse fromBEncode d+ fromBEncode _ = decodingError "dictionary"+ {-# INLINE fromBEncode #-}++instance (Eq a, BEncodable a) => BEncodable (Set a) where+ {-# SPECIALIZE instance (Eq a, BEncodable a) => BEncodable (Set a) #-}+ toBEncode = BList . map toBEncode . S.toAscList+ {-# INLINE toBEncode #-}++ fromBEncode (BList xs) = S.fromAscList <$> traverse fromBEncode xs+ fromBEncode _ = decodingError "Data.Set"+ {-# INLINE fromBEncode #-}++instance BEncodable () where+ {-# SPECIALIZE instance BEncodable () #-}+ toBEncode () = BList []+ {-# INLINE toBEncode #-}++ fromBEncode (BList []) = Right ()+ fromBEncode _ = decodingError "Unable to decode unit value"+ {-# INLINE fromBEncode #-}++instance (BEncodable a, BEncodable b) => BEncodable (a, b) where+ {-# SPECIALIZE instance (BEncodable a, BEncodable b) => BEncodable (a, b) #-}+ toBEncode (a, b) = BList [toBEncode a, toBEncode b]+ {-# INLINE toBEncode #-}++ fromBEncode (BList [a, b]) = (,) <$> fromBEncode a <*> fromBEncode b+ fromBEncode _ = decodingError "Unable to decode a pair."+ {-# INLINE fromBEncode #-}++instance (BEncodable a, BEncodable b, BEncodable c) => BEncodable (a, b, c) where+ {-# SPECIALIZE instance (BEncodable a, BEncodable b, BEncodable c)+ => BEncodable (a, b, c) #-}+ {-# INLINE toBEncode #-}+ toBEncode (a, b, c) = BList [toBEncode a, toBEncode b, toBEncode c]++ fromBEncode (BList [a, b, c]) =+ (,,) <$> fromBEncode a <*> fromBEncode b <*> fromBEncode c+ fromBEncode _ = decodingError "Unable to decode a triple"+ {-# INLINE fromBEncode #-}++instance (BEncodable a, BEncodable b, BEncodable c, BEncodable d)+ => BEncodable (a, b, c, d) where+ {-# SPECIALIZE instance (BEncodable a, BEncodable b, BEncodable c, BEncodable d)+ => BEncodable (a, b, c, d) #-}+ {-# INLINE toBEncode #-}+ toBEncode (a, b, c, d) = BList [ toBEncode a, toBEncode b+ , toBEncode c, toBEncode d+ ]++ fromBEncode (BList [a, b, c, d]) =+ (,,,) <$> fromBEncode a <*> fromBEncode b+ <*> fromBEncode c <*> fromBEncode d+ fromBEncode _ = decodingError "Unable to decode a tuple4"+ {-# INLINE fromBEncode #-}++instance (BEncodable a, BEncodable b, BEncodable c, BEncodable d, BEncodable e)+ => BEncodable (a, b, c, d, e) where+ {-# SPECIALIZE instance ( BEncodable a, BEncodable b+ , BEncodable c, BEncodable d+ , BEncodable e)+ => BEncodable (a, b, c, d, e) #-}+ {-# INLINE toBEncode #-}+ toBEncode (a, b, c, d, e) = BList [ toBEncode a, toBEncode b+ , toBEncode c, toBEncode d+ , toBEncode e+ ]++ fromBEncode (BList [a, b, c, d, e]) =+ (,,,,) <$> fromBEncode a <*> fromBEncode b+ <*> fromBEncode c <*> fromBEncode d <*> fromBEncode e+ fromBEncode _ = decodingError "Unable to decode a tuple5"+ {-# INLINE fromBEncode #-}++instance BEncodable Version where+ {-# SPECIALIZE instance BEncodable Version #-}+ {-# INLINE toBEncode #-}+ toBEncode = toBEncode . BC.pack . showVersion++ fromBEncode (BString bs)+ | [(v, _)] <- ReadP.readP_to_S parseVersion (BC.unpack bs)+ = return v+ fromBEncode _ = decodingError "Data.Version"+ {-# INLINE fromBEncode #-}++dictAssoc :: [(ByteString, BEncode)] -> BEncode+dictAssoc = BDict . M.fromList+{-# INLINE dictAssoc #-}++{--------------------------------------------------------------------+ Building dictionaries+--------------------------------------------------------------------}++data Assoc = Required ByteString BEncode+ | Optional ByteString (Maybe BEncode)++(-->) :: BEncodable a => ByteString -> a -> Assoc+key --> val = Required key (toBEncode val)+{-# INLINE (-->) #-}++(-->?) :: BEncodable a => ByteString -> Maybe a -> Assoc+key -->? mval = Optional key (toBEncode <$> mval)+{-# INLINE (-->?) #-}++mkAssocs :: [Assoc] -> [(ByteString, BEncode)]+mkAssocs = mapMaybe unpackAssoc+ where+ unpackAssoc (Required n v) = Just (n, v)+ unpackAssoc (Optional n (Just v)) = Just (n, v)+ unpackAssoc (Optional _ Nothing) = Nothing++fromAssocs :: [Assoc] -> BEncode+fromAssocs = BDict . M.fromList . mkAssocs+{-# INLINE fromAssocs #-}++-- | A faster version of 'fromAssocs'.+-- Should be used only when keys are sorted by ascending.+fromAscAssocs :: [Assoc] -> BEncode+fromAscAssocs = BDict . M.fromList . mkAssocs+{-# INLINE fromAscAssocs #-}++{--------------------------------------------------------------------+ Extraction+--------------------------------------------------------------------}++reqKey :: BEncodable a => Map ByteString BEncode -> ByteString -> Result a+reqKey d key+ | Just b <- M.lookup key d = fromBEncode b+ | otherwise = Left ("required field `" ++ BC.unpack key ++ "' not found")++optKey :: BEncodable a => Map ByteString BEncode -> ByteString -> Result (Maybe a)+optKey d key+ | Just b <- M.lookup key d+ , Right r <- fromBEncode b = return (Just r)+ | otherwise = return Nothing++(>--) :: BEncodable a => Map ByteString BEncode -> ByteString -> Result a+(>--) = reqKey+{-# INLINE (>--) #-}++(>--?) :: BEncodable a => Map ByteString BEncode -> ByteString -> Result (Maybe a)+(>--?) = optKey+{-# INLINE (>--?) #-}++{--------------------------------------------------------------------+ Predicated+--------------------------------------------------------------------}++isInteger :: BEncode -> Bool+isInteger (BInteger _) = True+isInteger _ = False+{-# INLINE isInteger #-}++isString :: BEncode -> Bool+isString (BString _) = True+isString _ = False+{-# INLINE isString #-}++isList :: BEncode -> Bool+isList (BList _) = True+isList _ = False+{-# INLINE isList #-}++isDict :: BEncode -> Bool+isDict (BList _) = True+isDict _ = False+{-# INLINE isDict #-}++{--------------------------------------------------------------------+ Encoding+--------------------------------------------------------------------}++encode :: BEncode -> Lazy.ByteString+encode = B.toLazyByteString . builder++decode :: ByteString -> Result BEncode+decode = P.parseOnly parser++decoded :: BEncodable a => ByteString -> Result a+decoded = decode >=> fromBEncode++encoded :: BEncodable a => a -> Lazy.ByteString+encoded = encode . toBEncode++{--------------------------------------------------------------------+ Internals+--------------------------------------------------------------------}++builder :: BEncode -> B.Builder+builder = go+ where+ go (BInteger i) = B.word8 (c2w 'i') <>+ BP.primBounded BP.int64Dec i <> -- TODO FIXME+ B.word8 (c2w 'e')+ go (BString s) = buildString s+ go (BList l) = B.word8 (c2w 'l') <>+ foldMap go l <>+ B.word8 (c2w 'e')+ go (BDict d) = B.word8 (c2w 'd') <>+ foldMap mkKV (M.toAscList d) <>+ B.word8 (c2w 'e')+ where+ mkKV (k, v) = buildString k <> go v++ buildString s = B.intDec (B.length s) <>+ B.word8 (c2w ':') <>+ B.byteString s+ {-# INLINE buildString #-}++-- | TODO try to replace peekChar with something else+parser :: Parser BEncode+parser = valueP+ where+ valueP = do+ mc <- P.peekChar+ case mc of+ Nothing -> fail "end of input"+ Just c ->+ case c of+ -- if we have digit it always should be string length+ di | di <= '9' -> BString <$> stringP+ 'i' -> P.anyChar *> ((BInteger <$> integerP) <* P.anyChar)+ 'l' -> P.anyChar *> ((BList <$> listBody) <* P.anyChar)+ 'd' -> do+ P.anyChar+ (BDict . M.fromDistinctAscList <$> many ((,) <$> stringP <*> valueP))+ <* P.anyChar+ t -> fail ("bencode unknown tag: " ++ [t])++ listBody = do+ c <- P.peekChar+ case c of+ Just 'e' -> return []+ _ -> (:) <$> valueP <*> listBody++ stringP :: Parser ByteString+ stringP = do+ n <- P.decimal :: Parser Int+ P.char ':'+ P.take n+ {-# INLINE stringP #-}++ integerP :: Parser Int64+ integerP = do+ c <- P.peekChar+ case c of+ Just '-' -> do+ P.anyChar+ negate <$> P.decimal+ _ -> P.decimal+ {-# INLINE integerP #-}++{--------------------------------------------------------------------+ Pretty Printing+--------------------------------------------------------------------}++printPretty :: BEncode -> IO ()+printPretty = print . ppBEncode++ppBS :: ByteString -> Doc+ppBS = text . map w2c . B.unpack++ppBEncode :: BEncode -> Doc+ppBEncode (BInteger i) = int (fromIntegral i)+ppBEncode (BString s) = ppBS s+ppBEncode (BList l) = brackets $ hsep (punctuate comma (map ppBEncode l))+ppBEncode (BDict d) = braces $ vcat (punctuate comma (map ppKV (M.toAscList d)))+ where+ ppKV (k, v) = ppBS k <+> colon <+> ppBEncode v++{--------------------------------------------------------------------+ Other instances+--------------------------------------------------------------------}++instance BEncodable Word8 where+ {-# SPECIALIZE instance BEncodable Word8 #-}+ toBEncode = toBEncode . (fromIntegral :: Word8 -> Word64)+ {-# INLINE toBEncode #-}+ fromBEncode b = (fromIntegral :: Word64 -> Word8) <$> fromBEncode b+ {-# INLINE fromBEncode #-}++instance BEncodable Word16 where+ {-# SPECIALIZE instance BEncodable Word16 #-}+ toBEncode = toBEncode . (fromIntegral :: Word16 -> Word64)+ {-# INLINE toBEncode #-}+ fromBEncode b = (fromIntegral :: Word64 -> Word16) <$> fromBEncode b+ {-# INLINE fromBEncode #-}++instance BEncodable Word32 where+ {-# SPECIALIZE instance BEncodable Word32 #-}+ toBEncode = toBEncode . (fromIntegral :: Word32 -> Word64)+ {-# INLINE toBEncode #-}+ fromBEncode b = (fromIntegral :: Word64 -> Word32) <$> fromBEncode b+ {-# INLINE fromBEncode #-}++instance BEncodable Word64 where+ {-# SPECIALIZE instance BEncodable Word64 #-}+ toBEncode = toBEncode . (fromIntegral :: Word64 -> Int)+ {-# INLINE toBEncode #-}+ fromBEncode b = (fromIntegral :: Int -> Word64) <$> fromBEncode b+ {-# INLINE fromBEncode #-}++instance BEncodable Word where -- TODO: make platform independent+ {-# SPECIALIZE instance BEncodable Word #-}+ toBEncode = toBEncode . (fromIntegral :: Word -> Int)+ {-# INLINE toBEncode #-}+ fromBEncode b = (fromIntegral :: Int -> Word) <$> fromBEncode b+ {-# INLINE fromBEncode #-}
+ tests/properties.hs view
@@ -0,0 +1,30 @@+module Main (main) where++import Control.Applicative+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Test.Framework (defaultMain)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck++import Data.BEncode++instance Arbitrary B.ByteString where+ arbitrary = fmap B.pack arbitrary++instance Arbitrary BEncode where+ arbitrary = frequency+ [ (50, BInteger <$> arbitrary)+ , (40, BString <$> arbitrary)+ , (5, BList <$> (arbitrary `suchThat` ((10 >) . length)))+ ]++prop_EncDec :: BEncode -> Bool+prop_EncDec x = case decode (L.toStrict (encode x)) of+ Left _ -> False+ Right x' -> x == x'++main :: IO ()+main = defaultMain+ [ testProperty "encode <-> decode" prop_EncDec+ ]