bencoding 0.1.0.0 → 0.2.0.0

raw patch · 6 files changed

+473/−130 lines, 6 filesdep +ghc-primdep ~bytestringdep ~deepseqPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-prim

Dependency ranges changed: bytestring, deepseq

API changes (from Hackage documentation)

Files

• README.md +19/−16
• bench/Main.hs +51/−24
• bencoding.cabal +28/−21
• pp/pp.hs +2/−2
• src/Data/BEncode.hs +333/−66
• tests/properties.hs +40/−1

@@ -1,17 +1,18 @@-# Synopsis+### Synopsis  [BEncode][bencode] is [JSON][json-ref]-like format used in bittorrent protocol but might be used anywhere else. -# Description+### 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.+[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+#### Format  Bencode is pretty similar to JSON: it has dictionaries(JSON objects), lists(JSON arrays), strings and integers. However bencode has a few@@ -31,27 +32,29 @@ * Bencode is certainly less human readable. * Bencode is rarely used, except bittorrent protocol of course. -# Documentation+### Documentation -For documentation see haddock generated documentation.+For documentation see package [hackage][hackage] page. -# Build Status+### Build Status  [![Build Status][travis-img]][travis-log] -# Authors--This library is written and maintained by Sam T. <pxqr.sta@gmail.com>+### Maintainer <pxqr.sta@gmail.com> -Feel free to report bugs and suggestions via github issue tracker or the mail.+Feel free to report bugs and suggestions via [issue tracker][issues]+or the mail.  -[cmp]: http://htmlpreview.github.com/?https://github.com/pxqr/bencoding/master/bench/comparison.html+[cmp]: http://htmlpreview.github.com/?https://raw.github.com/wiki/cobit/bencoding/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+[travis-img]: https://travis-ci.org/cobit/bencoding.png+[travis-log]: https://travis-ci.org/cobit/bencoding++[hackage]: http://hackage.haskell.org/package/bencoding+[issues]: https://github.com/cobit/bencoding/issues

@@ -1,4 +1,5 @@ {-# LANGUAGE PackageImports #-}+{-# LANGUAGE DeriveGeneric  #-} module Main (main) where  import Control.DeepSeq@@ -10,11 +11,14 @@ import Criterion.Main import System.Environment +import GHC.Generics+ 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@@ -27,16 +31,26 @@     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+getRight = either error id +data List a = Cons a (List a) | Nil+              deriving Generic++instance BEncodable a => BEncodable (List a)++instance NFData a => NFData (List a) where+  rnf  Nil        = ()+  rnf (Cons x xs) = rnf (x, xs)++replicate' :: Int -> a -> List a+replicate' c x+    |   c >= 0  = go c+    | otherwise = Nil+  where+    go 0 = Nil+    go n = Cons x $ go (pred n)+ main :: IO () main = do   (path : args) <- getArgs@@ -48,9 +62,12 @@    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+       [ 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@@ -59,19 +76,21 @@        , 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 "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/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]+       , 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 $@@ -88,6 +107,14 @@             (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+         in bench "list10000int/bencoding/encode>>decode" $+            nf  (getRight . C.decoded . BL.toStrict . C.encoded+                 :: [Int] ->  [Int] )+                d++       , let d = replicate' 10000 0+         in bench "list10000int/bencoding/encode>>decode/generic" $+            nf (getRight . C.decoded . BL.toStrict . C.encoded+                :: List Int -> List Int)+               d        ]

@@ -1,8 +1,8 @@ name:                  bencoding-version:               0.1.0.0+version:               0.2.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+homepage:              https://github.com/cobit/bencoding+bug-reports:           https://github.com/cobit/bencoding/issues license:               MIT license-file:          LICENSE author:                Sam T.@@ -10,7 +10,8 @@ copyright:             (c) 2013, Sam T. category:              Data build-type:            Simple-cabal-version:         >= 1.8+cabal-version:         >= 1.10+tested-with:           GHC==7.4.1, GHC==7.6.3 description:    A library for encoding and decoding of BEncode data.@@ -18,64 +19,71 @@   [/Release notes/]   .     * /0.1.0.0:/ Initial version.+  .+    * /0.2.0.0:/ Added default decoders/encoders using GHC Generics.  -extra-source-files:    README.md .travis.yml+extra-source-files:    README.md+                       .travis.yml  source-repository head   type:                git-  location:            git://github.com/pxqr/bencoding.git-+  location:            git://github.com/cobit/bencoding.git  library+  default-language:    Haskell2010+  default-extensions:  PatternGuards+  hs-source-dirs:      src   exposed-modules:     Data.BEncode   build-depends:       base       == 4.*+                     , ghc-prim+                     , deepseq    == 1.3.*                      , containers >= 0.4-                     , bytestring >= 0.10.2.0+                     , bytestring >= 0.10.0.2                      , attoparsec >= 0.10                      , text       >= 0.11                      , pretty--  hs-source-dirs:      src-  extensions:          PatternGuards   ghc-options:         -Wall -fno-warn-unused-do-bind - executable pp+  default-language:    Haskell2010+  hs-source-dirs:      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+  default-language:    Haskell2010   hs-source-dirs:      tests-+  main-is:             properties.hs   build-depends:       base       == 4.*+                     , ghc-prim+                      , containers >= 0.4-                     , bytestring >= 0.10.2.0+                     , bytestring >= 0.10.0.2                      , 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+  default-language:    Haskell2010   hs-source-dirs:      bench-+  main-is:             Main.hs   build-depends:       base == 4.*+                     , ghc-prim+                      , attoparsec >= 0.10-                     , bytestring >= 0.10.2.0+                     , bytestring >= 0.10.0.2                       , criterion                      , deepseq@@ -83,5 +91,4 @@                      , bencoding                      , bencode     >= 0.5                      , AttoBencode >= 0.2-   ghc-options:         -O2 -Wall -fno-warn-orphans

@@ -10,5 +10,5 @@   path : _ <- getArgs   content  <- B.readFile path   case decode content of-    Left e -> hPutStrLn stderr e-    Right be -> printPretty be+    Left  e  -> hPutStrLn stderr e+    Right be -> print $ ppBEncode be

@@ -1,4 +1,6 @@--- TODO: make int's instances platform independent so we can make library portable.+-- TODO: make int's instances platform independent so we can make+-- library portable.+ -- | --   Copyright   :  (c) Sam T. 2013 --   License     :  MIT@@ -6,8 +8,9 @@ --   Stability   :  stable --   Portability :  non-portable -----   This module provides convinient and fast way to serialize, deserealize---   and construct/destructure Bencoded values with optional fields.+--   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: --@@ -19,9 +22,10 @@ -- --     * 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'.+--    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: --@@ -42,41 +46,70 @@ --    This module is considered to be imported qualified. -- {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Trustworthy       #-}+{-# LANGUAGE CPP               #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE DefaultSignatures      #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE ScopedTypeVariables    #-}+#endif+ module Data.BEncode        ( -- * Datatype          BEncode(..)+       , Dict+       , ppBEncode -         -- * Construction && Destructuring-       , BEncodable (..), dictAssoc, Result+         -- * Conversion+       , BEncodable (..)+       , Result +         -- * Serialization+       , encode+       , decode+       , encoded+       , decoded+          -- ** Dictionaries          -- *** Building-       , (-->), (-->?), fromAssocs, fromAscAssocs+       , Assoc+       , (-->)+       , (-->?)+       , fromAssocs+       , fromAscAssocs           -- *** Extraction-       , reqKey, optKey, (>--), (>--?)--         -- * Serialization-       , encode, decode-       , encoded, decoded+       , decodingError+       , reqKey+       , optKey+       , (>--)+       , (>--?)           -- * Predicates-       , isInteger, isString, isList, isDict+       , isInteger+       , isString+       , isList+       , isDict           -- * Extra-       , builder, parser, decodingError, printPretty+       , builder+       , parser        ) where   import Control.Applicative+import Control.DeepSeq 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.Maybe         (mapMaybe)+import Data.Monoid        -- (mempty, (<>))+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)@@ -87,24 +120,26 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString.Lazy.Builder as B+import qualified Data.ByteString.Lazy.Builder.ASCII as B 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 -+#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif +-- | BEncode key-value dictionary. 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'.+-- | '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. -- data BEncode = BInteger {-# UNPACK #-} !Int64              | BString  !ByteString@@ -112,17 +147,196 @@              | BDict    Dict                deriving (Show, Read, Eq, Ord) +instance NFData BEncode where+    rnf (BInteger i) = rnf i+    rnf (BString  s) = rnf s+    rnf (BList    l) = rnf l+    rnf (BDict    d) = rnf d++-- | Result used in decoding operations. type Result = Either String +-- | This class is used to define new datatypes that could be easily+-- serialized using bencode format.+--+--   By default 'BEncodable' have a generic implementation; suppose+--   the following datatype:+--+-- > data List a = Cons { _head  :: a+-- >                    , __tail :: (List a) }+-- >             | Nil+-- >               deriving Generic+--+--   If we don't need to obey any particular specification or+--   standard, the default instance could be derived automatically+--   from the 'Generic' instance:+--+-- > instance BEncodable a => BEncodable (List a)+--+--   Example of derived 'toBEncode' result:+--+-- > > toBEncode (Cons 123 $ Cons 1 Nil)+-- > BDict (fromList [("head",BInteger 123),("tail",BList [])])+--+--  Note that '_' prefixes are omitted.+-- class BEncodable a where+  -- | See an example of implementation here 'Assoc'   toBEncode   :: a -> BEncode++#if __GLASGOW_HASKELL__ >= 702+  default toBEncode+    :: Generic a+    => GBEncodable (Rep a) BEncode+    => a -> BEncode++  toBEncode = gto . from+#endif++  -- | See an example of implementation here 'reqKey'.   fromBEncode :: BEncode -> Result a +#if __GLASGOW_HASKELL__ >= 702+  default fromBEncode+    :: Generic a+    => GBEncodable (Rep a) BEncode+    => BEncode -> Result a +  fromBEncode x = to <$> gfrom x+#endif++-- | Typically used to throw an decoding error in fromBEncode; when+-- BEncode value to match expected value. decodingError :: String -> Result a decodingError s = Left ("fromBEncode: unable to decode " ++ s) {-# INLINE decodingError #-} +{--------------------------------------------------------------------+  Generics+--------------------------------------------------------------------}++{- NOTE: SELECTORS FOLDING/UNFOLDING+Both List and Map are monoids:++* if fields are named, we fold record to the map;+* otherwise we collect fields using list;++and then unify them using BDict and BList constrs.+-}++#if __GLASGOW_HASKELL__ >= 702++class GBEncodable f e where+  gto   :: f a -> e+  gfrom :: e -> Result (f a)++instance BEncodable f+      => GBEncodable (K1 R f) BEncode where+  {-# INLINE gto #-}+  gto = toBEncode . unK1++  {-# INLINE gfrom #-}+  gfrom x = K1 <$> fromBEncode x++instance (Eq e, Monoid e)+      => GBEncodable U1 e where+  {-# INLINE gto #-}+  gto U1 = mempty++  {-# INLINE gfrom #-}+  gfrom x+    | x == mempty = pure U1+    |   otherwise = decodingError "U1"++instance (GBEncodable a [BEncode], GBEncodable b [BEncode])+      => GBEncodable (a :*: b) [BEncode] where+  {-# INLINE gto #-}+  gto (a :*: b) = gto a ++ gto b++  {-# INLINE gfrom #-}+  gfrom (x : xs) = (:*:) <$> gfrom [x] <*> gfrom xs+  gfrom []       = decodingError "generic: not enough fields"++instance (GBEncodable a Dict, GBEncodable b Dict)+      => GBEncodable (a :*: b) Dict where+  {-# INLINE gto #-}+  gto (a :*: b) = gto a <> gto b++  {-# INLINE gfrom #-}+  -- Just look at this! >.<+  gfrom dict = (:*:) <$> gfrom dict <*> gfrom dict+++instance (GBEncodable a e, GBEncodable b e)+      =>  GBEncodable (a :+: b) e where+  {-# INLINE gto #-}+  gto (L1 x) = gto x+  gto (R1 x) = gto x++  {-# INLINE gfrom #-}+  gfrom x = case gfrom x of+    Right lv -> return (L1 lv)+    Left  le -> do+      case gfrom x of+        Right rv -> return (R1 rv)+        Left  re -> decodingError $ "generic: both" ++ le ++ " " ++ re++selRename :: String -> String+selRename = dropWhile ('_'==)++gfromM1S :: forall c. Selector c+         => GBEncodable f BEncode+         => Dict -> Result (M1 i c f p)+gfromM1S dict+  | Just va <- M.lookup (BC.pack (selRename name)) dict = M1 <$> gfrom va+  | otherwise = decodingError $ "generic: Selector not found " ++ show name+  where+    name = selName (error "gfromM1S: impossible" :: M1 i c f p)++instance (Selector s, GBEncodable f BEncode)+       => GBEncodable (M1 S s f) Dict where+  {-# INLINE gto #-}+  gto s @ (M1 x) = BC.pack (selRename (selName s)) `M.singleton` gto x++  {-# INLINE gfrom #-}+  gfrom = gfromM1S++-- TODO DList+instance GBEncodable f BEncode+      => GBEncodable (M1 S s f) [BEncode] where+  {-# INLINE gto #-}+  gto (M1 x) = [gto x]++  gfrom [x] = M1 <$> gfrom x+  gfrom _   = decodingError "generic: empty selector"+  {-# INLINE gfrom #-}++instance (Constructor c, GBEncodable f Dict, GBEncodable f [BEncode])+       => GBEncodable (M1 C c f) BEncode where+  {-# INLINE gto #-}+  gto con @ (M1 x)+      | conIsRecord con = BDict (gto x)+      |    otherwise    = BList (gto x)++  {-# INLINE gfrom #-}+  gfrom (BDict a) = M1 <$> gfrom a+  gfrom (BList a) = M1 <$> gfrom a+  gfrom _         = decodingError "generic: Constr"++instance GBEncodable f e+      => GBEncodable (M1 D d f) e where+  {-# INLINE gto #-}+  gto (M1 x) = gto x++  {-# INLINE gfrom #-}+  gfrom x = M1 <$> gfrom x++#endif++{--------------------------------------------------------------------+  Basic instances+--------------------------------------------------------------------}+ instance BEncodable BEncode where   {-# SPECIALIZE instance BEncodable BEncode #-}   toBEncode = id@@ -280,84 +494,128 @@   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)+-- | /Assoc/ used to easily build dictionaries with required and+-- optional keys. Suppose we have we following datatype we want to+-- serialize:+--+--  > data FileInfo = FileInfo+--  >   { fileLength :: Integer+--  >   , fileMD5sum :: Maybe ByteString+--  >   , filePath   :: [ByteString]+--  >   , fileTags   :: Maybe [Text]+--  >   } deriving (Show, Read, Eq)+--+-- We need to make /instance BEncodable FileInfo/, though we don't+-- want to check the both /maybes/ manually. The more declarative and+-- convenient way to define the 'toBEncode' method is to use+-- dictionary builders:+--+--  > instance BEncodable FileInfo where+--  >   toBEncode FileInfo {..} = fromAssocs+--  >     [ "length" -->  fileLength+--  >     , "md5sum" -->? fileMD5sum+--  >     , "path"   -->  filePath+--  >     , "tags"   -->? fileTags+--  >     ]+--  >     ...+--+newtype Assoc = Assoc { unAssoc :: Maybe (ByteString, BEncode) } +-- | Make required key value pair. (-->) :: BEncodable a => ByteString -> a -> Assoc-key --> val = Required key (toBEncode val)+key --> val = Assoc $ Just $ (key, toBEncode val) {-# INLINE (-->) #-} +-- | Like (-->) but if the value is not present then the key do not+-- appear in resulting bencoded dictionary.+-- (-->?) :: BEncodable a => ByteString -> Maybe a -> Assoc-key -->? mval = Optional key (toBEncode <$> mval)+key -->? mval = Assoc $ ((,) 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-+-- | Build BEncode dictionary using key -> value description. fromAssocs :: [Assoc] -> BEncode-fromAssocs = BDict . M.fromList . mkAssocs+fromAssocs = BDict . M.fromList . mapMaybe unAssoc {-# INLINE fromAssocs #-} --- | A faster version of 'fromAssocs'.---   Should be used only when keys are sorted by ascending.+-- | A faster version of 'fromAssocs'. Should be used only when keys+-- in builder list are sorted by ascending. fromAscAssocs :: [Assoc] -> BEncode-fromAscAssocs = BDict . M.fromList . mkAssocs+fromAscAssocs = BDict . M.fromAscList . mapMaybe unAssoc {-# INLINE fromAscAssocs #-}  {---------------------------------------------------------------------  Extraction+  Dictionary extraction --------------------------------------------------------------------} -reqKey :: BEncodable a => Map ByteString BEncode -> ByteString -> Result a+-- | Dictionary extractor are similar to dictionary builders, but play+-- the opposite role: they are used to define 'fromBEncode' method in+-- declarative style. Using the same /FileInfo/ datatype 'fromBEncode'+-- looks like:+--+--  > instance BEncodable FileInfo where+--  >   ...+--  >   fromBEncode (BDict d) =+--  >     FileInfo <$> d >--  "length"+--  >              <*> d >--? "md5sum"+--  >              <*> d >--  "path"+--  >              <*> d >--? "tags"+--  >   fromBEncode _ = decodingError "FileInfo"+--+--  The /reqKey/ is used to extract required key — if lookup is failed+--  then whole destructuring fail.+reqKey :: BEncodable a => Dict -> ByteString -> Result a reqKey d key   | Just b <- M.lookup key d = fromBEncode b-  |        otherwise         = Left ("required field `" ++ BC.unpack key ++ "' not found")+  |        otherwise         = Left msg+  where+    msg = "required field `" ++ BC.unpack key ++ "' not found" -optKey :: BEncodable a => Map ByteString BEncode -> ByteString -> Result (Maybe a)+-- | Used to extract optional key — if lookup is failed returns+-- 'Nothing'.+optKey :: BEncodable a => Dict -> 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+-- | Infix version of the 'reqKey'.+(>--) :: BEncodable a => Dict -> ByteString -> Result a (>--) = reqKey {-# INLINE (>--) #-} -(>--?) :: BEncodable a => Map ByteString BEncode -> ByteString -> Result (Maybe a)+-- | Infix version of the 'optKey'.+(>--?) :: BEncodable a => Dict -> ByteString -> Result (Maybe a) (>--?) = optKey {-# INLINE (>--?) #-}  {---------------------------------------------------------------------  Predicated+  Predicates --------------------------------------------------------------------} +-- | Test if bencoded value is an integer. isInteger :: BEncode -> Bool isInteger (BInteger _) = True isInteger _            = False {-# INLINE isInteger #-} +-- | Test if bencoded value is a string, both raw and utf8 encoded. isString :: BEncode -> Bool isString (BString _) = True isString _           = False {-# INLINE isString #-} +-- | Test if bencoded value is a list. isList :: BEncode -> Bool isList (BList _) = True isList _         = False {-# INLINE isList #-} +-- | Test if bencoded value is a dictionary. isDict :: BEncode -> Bool isDict (BList _) = True isDict _         = False@@ -367,15 +625,21 @@   Encoding --------------------------------------------------------------------} +-- | Convert bencoded value to raw bytestring according to the+-- specification. encode :: BEncode -> Lazy.ByteString encode = B.toLazyByteString . builder +-- | Try to convert raw bytestring to bencoded value according to+-- specification. decode :: ByteString -> Result BEncode decode = P.parseOnly parser +-- | The same as 'decode' but returns any bencodable value. decoded :: BEncodable a => ByteString -> Result a decoded = decode >=> fromBEncode +-- | The same as 'encode' but takes any bencodable value. encoded :: BEncodable a => a -> Lazy.ByteString encoded = encode . toBEncode @@ -383,11 +647,12 @@   Internals --------------------------------------------------------------------} +-- | BEncode format encoder according to specification. builder :: BEncode -> B.Builder builder = go     where       go (BInteger i) = B.word8 (c2w 'i') <>-                        BP.primBounded BP.int64Dec i <> -- TODO FIXME+                        B.int64Dec i <>                         B.word8 (c2w 'e')       go (BString  s) = buildString s       go (BList    l) = B.word8 (c2w 'l') <>@@ -404,7 +669,8 @@                       B.byteString s       {-# INLINE buildString #-} --- | TODO try to replace peekChar with something else+-- TODO try to replace peekChar with something else+-- | BEncode format parser according to specification. parser :: Parser BEncode parser = valueP   where@@ -420,8 +686,9 @@               'l' -> P.anyChar *> ((BList    <$> listBody) <* P.anyChar)               'd' -> do                      P.anyChar-                     (BDict . M.fromDistinctAscList <$> many ((,) <$> stringP <*> valueP))-                        <* P.anyChar+                     (BDict . M.fromDistinctAscList <$>+                          many ((,) <$> stringP <*> valueP))+                       <* P.anyChar               t   -> fail ("bencode unknown tag: " ++ [t])      listBody = do@@ -451,17 +718,17 @@   Pretty Printing --------------------------------------------------------------------} -printPretty :: BEncode -> IO ()-printPretty = print . ppBEncode- ppBS :: ByteString -> Doc ppBS = text . map w2c . B.unpack +-- | Convert to easily readable JSON-like document. Typically used for+-- debugging purposes. ppBEncode :: BEncode -> Doc-ppBEncode (BInteger i) = int (fromIntegral i)+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)))+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 

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveGeneric #-}+{-# OPTIONS  -fno-warn-unused-binds #-} module Main (main) where  import Control.Applicative@@ -6,9 +8,11 @@ import Test.Framework (defaultMain) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck+import GHC.Generics  import Data.BEncode + instance Arbitrary B.ByteString where     arbitrary = fmap B.pack arbitrary @@ -19,12 +23,47 @@                 , (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' +data List a = Cons a (List a) | Nil+              deriving (Show, Eq, Generic)++instance BEncodable a => BEncodable (List a)++instance Arbitrary a => Arbitrary (List a) where+  arbitrary = frequency+    [ (90, pure Nil)+    , (10, Cons <$> arbitrary <*> arbitrary)+    ]++data FileInfo = FileInfo+  { fiLength :: !Integer+  , fiPath   :: [B.ByteString]+  , fiMD5Sum :: B.ByteString+  } deriving (Show, Eq, Generic)++instance BEncodable FileInfo++instance Arbitrary FileInfo where+  arbitrary = FileInfo <$> arbitrary <*> arbitrary <*> arbitrary++data T a = T++prop_bencodable :: Eq a => BEncodable a => T a -> a -> Bool+prop_bencodable _ x = decoded (L.toStrict (encoded x)) == Right x++-- All tests are (encode >>> decode = id) main :: IO () main = defaultMain-       [ testProperty "encode <-> decode" prop_EncDec+       [ testProperty "BEncode" prop_EncDec++       , testProperty "generic recordless" $+            prop_bencodable (T :: T (List Int))++       , testProperty "generic records" $+            prop_bencodable (T :: T FileInfo)        ]