diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. +### Maintainer -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 diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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 ] diff --git a/bencoding.cabal b/bencoding.cabal --- a/bencoding.cabal +++ b/bencoding.cabal @@ -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 diff --git a/pp/pp.hs b/pp/pp.hs --- a/pp/pp.hs +++ b/pp/pp.hs @@ -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 diff --git a/src/Data/BEncode.hs b/src/Data/BEncode.hs --- a/src/Data/BEncode.hs +++ b/src/Data/BEncode.hs @@ -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 diff --git a/tests/properties.hs b/tests/properties.hs --- a/tests/properties.hs +++ b/tests/properties.hs @@ -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) ]