bencoding 0.3.0.0 → 0.4.0.0
raw patch · 8 files changed
+642/−302 lines, 8 filesdep +mtl
Dependencies added: mtl
Files
- NEWS.md +1/−0
- bench/Main.hs +96/−19
- bencoding.cabal +10/−6
- src/Data/BEncode.hs +161/−276
- src/Data/BEncode/BDict.hs +151/−0
- src/Data/BEncode/Internal.hs +136/−0
- src/Data/BEncode/Types.hs +86/−0
- tests/properties.hs +1/−1
NEWS.md view
@@ -2,3 +2,4 @@ * 0.2.0.0: Added default decoders/encoders using GHC Generics. * 0.2.2.0: Arbitrary length integers. (by specification) * 0.3.0.0: Rename BEncode to BValue and BEncodable to BEncode.+* 0.4.0.0: Faster dictionary conversion.
bench/Main.hs view
@@ -1,22 +1,29 @@-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-} 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.ByteString as BS+import qualified Data.ByteString.Lazy as BL import Data.List as L-import Criterion.Main+import Data.Maybe+import Data.Typeable import System.Environment +import Criterion.Main 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+import "bencoding" Data.BEncode.Internal as C+import "bencoding" Data.BEncode.Types as C instance NFData A.BEncode where@@ -51,11 +58,63 @@ go 0 = Nil go n = Cons x $ go (pred n) +{-----------------------------------------------------------------------+-- Big dicts+-----------------------------------------------------------------------}++data Torrent = Torrent {+ tAnnounce :: !ByteString+ , tAnnounceList :: !(Maybe ByteString)+ , tComment :: !(Maybe ByteString)+ , tCreatedBy :: !(Maybe ByteString)+ , tCreationDate :: !(Maybe ByteString)+ , tEncoding :: !(Maybe ByteString)+ , tInfo :: !BDict+ , tPublisher :: !(Maybe ByteString)+ , tPublisherURL :: !(Maybe ByteString)+ , tSignature :: !(Maybe ByteString)+ } deriving (Show, Eq, Typeable)++instance NFData Torrent where+ rnf Torrent {..} = ()++instance C.BEncode Torrent where+ toBEncode Torrent {..} = toDict $+ "announce" .=! tAnnounce+ C..: "announce-list" .=? tAnnounceList+ C..: "comment" .=? tComment+ C..: "created by" .=? tCreatedBy+ C..: "creation date" .=? tCreationDate+ C..: "encoding" .=? tEncoding+ C..: "info" .=! tInfo+ C..: "publisher" .=? tPublisher+ C..: "publisher-url" .=? tPublisherURL+ C..: "signature" .=? tSignature+ C..: endDict++++ fromBEncode = fromDict $ do+ Torrent <$>! "announce"+ <*>? "announce-list"+ <*>? "comment"+ <*>? "created by"+ <*>? "creation date"+ <*>? "encoding"+ <*>! "info"+ <*>? "publisher"+ <*>? "publisher-url"+ <*>? "signature"++{-----------------------------------------------------------------------+-- Main+-----------------------------------------------------------------------}+ main :: IO () main = do (path : args) <- getArgs- torrentFile <- B.readFile path- let lazyTorrentFile = fromChunks [torrentFile]+ torrentFile <- BS.readFile path+ let lazyTorrentFile = BL.fromChunks [torrentFile] case rnf (torrentFile, lazyTorrentFile) of () -> return ()@@ -67,21 +126,21 @@ , bench "decode/AttoBencode" $ nf (getRight . Atto.parseOnly bValue) torrentFile , bench "decode/bencoding" $- nf (getRight . C.decode) torrentFile+ nf (getRight . C.parse) 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+ , let Right v = C.parse torrentFile in+ bench "encode/bencoding" $ nf C.build 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+ nf (C.build . getRight . C.parse) torrentFile , bench "list10000int/bencode/encode" $ nf (A.bPack . A.BList . L.map (A.BInt . fromIntegral))@@ -90,7 +149,7 @@ , bench "list10000int/attobencode/encode" $ nf B.encode [1..20000 :: Int] , bench "list10000int/bencoding/encode" $- nf C.encoded [1..20000 :: Int]+ nf C.encode [1..20000 :: Int] , let d = A.bPack $ A.BList $@@ -98,23 +157,41 @@ 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 ()))+ , let d = BL.toStrict (C.encode (L.replicate 10000 ())) in d `seq` (bench "list10000unit/bencoding/decode" $ nf- (C.decoded :: B.ByteString -> Either String [()]) d)+ (C.decode :: BS.ByteString -> Either String [()]) d) - , let d = BL.toStrict $ C.encoded $ L.replicate 10000 (0 :: Int)+ , let d = BL.toStrict $ C.encode $ L.replicate 10000 (0 :: Int) in d `seq` (bench "list10000int/bencoding/decode" $ nf- (C.decoded :: B.ByteString -> Either String [Int]) d)+ (C.decode :: BS.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+ nf (getRight . C.decode . BL.toStrict . C.encode :: [Int] -> [Int] ) d , let d = replicate' 10000 0 in bench "list10000int/bencoding/encode>>decode/generic" $- nf (getRight . C.decoded . BL.toStrict . C.encoded+ nf (getRight . C.decode . BL.toStrict . C.encode :: List Int -> List Int) d++ , let Right !be = C.parse torrentFile+ id' x = let t = either error id (fromBEncode x)+ in toBEncode (t :: Torrent)+ !_ = let Right t = C.decode torrentFile+ in if C.decode (BL.toStrict (C.encode t))+ /= Right (t :: Torrent)+ then error "invalid instance: BEncode Torrent"+ else True++ replFn m f = go m+ where go 0 = id+ go n = f . go (pred n)++ in bench "bigdict" $ nf (replFn (1000 :: Int) id') be++ , let fn x = let Right t = C.decode x in t :: Torrent+ in bench "torrent/decode" $ nf fn torrentFile ]
bencoding.cabal view
@@ -1,5 +1,5 @@ name: bencoding-version: 0.3.0.0+version: 0.4.0.0 license: BSD3 license-file: LICENSE author: Sam Truzjan@@ -32,22 +32,26 @@ type: git location: git://github.com/cobit/bencoding.git branch: master- tag: v0.3.0.0+ tag: v0.4.0.0 library default-language: Haskell2010 default-extensions: PatternGuards hs-source-dirs: src exposed-modules: Data.BEncode+ , Data.BEncode.BDict+ , Data.BEncode.Internal+ , Data.BEncode.Types build-depends: base == 4.* , ghc-prim , deepseq == 1.3.*- , containers >= 0.4- , bytestring >= 0.10.0.2+ , mtl+ , attoparsec >= 0.10+ , bytestring >= 0.10.0.2 , text >= 0.11 , pretty- ghc-options: -Wall -fno-warn-unused-do-bind+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind test-suite properties@@ -76,12 +80,12 @@ main-is: Main.hs build-depends: base == 4.* , ghc-prim+ , deepseq , attoparsec >= 0.10 , bytestring >= 0.10.0.2 , criterion- , deepseq , bencoding , bencode >= 0.5
src/Data/BEncode.hs view
@@ -45,6 +45,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE TypeOperators #-}@@ -55,137 +57,90 @@ #endif module Data.BEncode- ( -- * Datatype- BInteger- , BString- , BList- , BDict- , BKey-- , BValue (..)- , ppBEncode-- -- * Conversion+ ( BValue (..) , BEncode (..)- , Result-- -- * Serialization , encode , decode- , encoded- , decoded - -- ** Dictionaries- -- *** Building+ -- * Helpers+ -- ** Building , Assoc- , (-->)- , (-->?)- , fromAssocs- , fromAscAssocs+ , (.=!)+ , (.=?)+ , (.:)+ , endDict+ , toDict - -- *** Extraction+ -- ** Extraction+ , Get+ , Result , decodingError- , reqKey- , optKey- , (>--)- , (>--?)+ , fromDict - -- * Predicates- , isInteger- , isString- , isList- , isDict+ , next+ , req+ , opt+ , field - -- * Extra- , builder- , parser+ , (<$>!)+ , (<$>?)+ , (<*>!)+ , (<*>?) ) where import Control.Applicative-import Control.DeepSeq import Control.Monad+import Control.Monad.State+import Control.Monad.Error import Data.Int-import Data.Maybe (mapMaybe)+import Data.List as L 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 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 Data.Text (Text) import qualified Data.Text.Encoding as T import Data.Typeable import Data.Version-import Text.PrettyPrint hiding ((<>)) import qualified Text.ParserCombinators.ReadP as ReadP #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics #endif +import Data.BEncode.BDict as BD+import Data.BEncode.Internal+import Data.BEncode.Types -type BInteger = Integer-type BString = ByteString-type BList = [BValue]-type BDict = Map BKey BValue-type BKey = ByteString --- | '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 BValue- = BInteger !BInteger -- ^ bencode integers;- | BString !BString -- ^ bencode strings;- | BList BList -- ^ list of bencode values;- | BDict BDict -- ^ bencode key-value dictionary.- deriving (Show, Read, Eq, Ord)--instance NFData BValue 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+-- By default 'BEncode' have a generic implementation; suppose -- the following datatype: ----- > data List a = Cons { _head :: a--- > , __tail :: (List a) }--- > | Nil+-- > data List a = C { _head :: a+-- > , __tail :: List a }+-- > | N -- > 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)+-- > instance BEncode a => BEncode (List a) -- -- Example of derived 'toBEncode' result: ----- > > toBEncode (Cons 123 $ Cons 1 Nil)+-- > > toBEncode (C 123 $ C 1 N) -- > BDict (fromList [("head",BInteger 123),("tail",BList [])]) ----- Note that '_' prefixes are omitted.+-- Note that '_' prefixes are omitted since they are used for lens. -- class BEncode a where -- | See an example of implementation here 'Assoc'@@ -200,7 +155,7 @@ toBEncode = gto . from #endif - -- | See an example of implementation here 'reqKey'.+ -- | See an example of implementation here 'Get'. fromBEncode :: BValue -> Result a #if __GLASGOW_HASKELL__ >= 702@@ -295,7 +250,7 @@ => GBEncodable f BValue => BDict -> Result (M1 i c f p) gfromM1S dict- | Just va <- M.lookup (BC.pack (selRename name)) dict = M1 <$> gfrom va+ | Just va <- BD.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)@@ -303,7 +258,7 @@ instance (Selector s, GBEncodable f BValue) => GBEncodable (M1 S s f) BDict where {-# INLINE gto #-}- gto s @ (M1 x) = BC.pack (selRename (selName s)) `M.singleton` gto x+ gto s @ (M1 x) = BC.pack (selRename (selName s)) `BD.singleton` gto x {-# INLINE gfrom #-} gfrom = gfromM1S@@ -377,14 +332,15 @@ fromBEncode _ = decodingError "BList" {-# INLINE fromBEncode #-} -instance BEncodable BDict where- toBEncode = BDict+-}++instance BEncode BDict where+ toBEncode = BDict {-# INLINE toBEncode #-} fromBEncode (BDict d) = pure d fromBEncode _ = decodingError "BDict" {-# INLINE fromBEncode #-}--} {-------------------------------------------------------------------- -- Integral instances@@ -401,7 +357,7 @@ fromBEncodeIntegral :: forall a. Typeable a => Integral a => BValue -> Result a fromBEncodeIntegral (BInteger i) = pure (fromIntegral i) fromBEncodeIntegral _- = decodingError $ show $ typeOf (undefined :: a)+ = decodingError $ show $ typeOf (error "fromBEncodeIntegral: imposible" :: a) {-# INLINE fromBEncodeIntegral #-} @@ -500,16 +456,17 @@ instance BEncode a => BEncode [a] where {-# SPECIALIZE instance BEncode BList #-}- toBEncode = BList . map toBEncode+ toBEncode = BList . L.map toBEncode {-# INLINE toBEncode #-} fromBEncode (BList xs) = mapM fromBEncode xs fromBEncode _ = decodingError "list" {-# INLINE fromBEncode #-} +{- instance BEncode a => BEncode (Map BKey a) where- {-# SPECIALIZE instance BEncode BDict #-}- toBEncode = BDict . M.map toBEncode+ {-# SPECIALIZE instance BEncode (Map BKey BValue) #-}+ toBEncode = BDict . -- BD.map toBEncode {-# INLINE toBEncode #-} fromBEncode (BDict d) = traverse fromBEncode d@@ -524,7 +481,7 @@ fromBEncode (BList xs) = S.fromAscList <$> traverse fromBEncode xs fromBEncode _ = decodingError "Data.Set" {-# INLINE fromBEncode #-}-+-} instance BEncode Version where toBEncode = toBEncode . BC.pack . showVersion {-# INLINE toBEncode #-}@@ -609,225 +566,153 @@ -- > , 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+-- We need to make /instance BEncode 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--- > ]--- > ...+-- > instance BEncode FileInfo where+-- > toBEncode FileInfo {..} = toDict $+-- > "length" .=! fileLength+-- > .: "md5sum" .=? fileMD5sum+-- > .: "path" .=! filePath+-- > .: "tags" .=? fileTags+-- > .: endDict ---newtype Assoc = Assoc { unAssoc :: Maybe (ByteString, BValue) }+-- NOTE: the list of pairs SHOULD be sorted lexicographically by+-- keys, so: "length" < "md5sum" < "path" < "tags".+--+data Assoc = Some !BKey BValue+ | None -- | Make required key value pair.-(-->) :: BEncode a => BKey -> a -> Assoc-key --> val = Assoc $ Just $ (key, toBEncode val)-{-# INLINE (-->) #-}+(.=!) :: BEncode a => BKey -> a -> Assoc+(!k) .=! v = Some k (toBEncode v)+{-# INLINE (.=!) #-} --- | Like (-->) but if the value is not present then the key do not--- appear in resulting bencoded dictionary.+infix 6 .=!++-- | Like (.=!) but if the value is not present then the key do not+-- appear in resulting bencode dictionary. ---(-->?) :: BEncode a => BKey -> Maybe a -> Assoc-key -->? mval = Assoc $ ((,) key . toBEncode) <$> mval-{-# INLINE (-->?) #-}+(.=?) :: BEncode a => BKey -> Maybe a -> Assoc+_ .=? Nothing = None+k .=? Just v = Some k (toBEncode v)+{-# INLINE (.=?) #-} --- | Build BEncode dictionary using key -> value description.-fromAssocs :: [Assoc] -> BValue-fromAssocs = BDict . M.fromList . mapMaybe unAssoc-{-# INLINE fromAssocs #-}+infix 6 .=? --- | A faster version of 'fromAssocs'. Should be used only when keys--- in builder list are sorted by ascending.-fromAscAssocs :: [Assoc] -> BValue-fromAscAssocs = BDict . M.fromAscList . mapMaybe unAssoc-{-# INLINE fromAscAssocs #-}+-- | Cons a key\/value pair.+(.:) :: Assoc -> BDict -> BDict+None .: d = d+Some k v .: d = Cons k v d+{-# INLINE (.:) #-} +infixr 5 .:++-- | Make a bencode value from dictionary description.+toDict :: BDict -> BValue+toDict = BDict+{-# INLINE toDict #-}++-- | Used to specify end of dictionary. See 'Assoc'.+endDict :: BDict+endDict = Nil+{-# INLINE endDict #-}+ {--------------------------------------------------------------------- Dictionary extraction+-- Dictionary extraction --------------------------------------------------------------------} -- | 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:+-- declarative style. Using the same /FileInfo/ datatype the+-- 'fromBEncode' function instance looks like: -- -- > instance BEncodable FileInfo where--- > ...--- > fromBEncode (BDict d) =--- > FileInfo <$> d >-- "length"--- > <*> d >--? "md5sum"--- > <*> d >-- "path"--- > <*> d >--? "tags"--- > fromBEncode _ = decodingError "FileInfo"+-- > fromBEncode = fromDict $ do+-- > FileInfo <$>! "length"+-- > <*>? "md5sum"+-- > <*>! "path"+-- > <*>? "tags" -- -- The /reqKey/ is used to extract required key — if lookup is failed -- then whole destructuring fail.-reqKey :: BEncode a => BDict -> BKey -> Result a-reqKey d key- | Just b <- M.lookup key d = fromBEncode b- | otherwise = Left msg- where- msg = "required field `" ++ BC.unpack key ++ "' not found"---- | Used to extract optional key — if lookup is failed returns--- 'Nothing'.-optKey :: BEncode a => BDict -> BKey -> Result (Maybe a)-optKey d key- | Just b <- M.lookup key d- , Right r <- fromBEncode b = return (Just r)- | otherwise = return Nothing---- | Infix version of the 'reqKey'.-(>--) :: BEncode a => BDict -> BKey -> Result a-(>--) = reqKey-{-# INLINE (>--) #-}---- | Infix version of the 'optKey'.-(>--?) :: BEncode a => BDict -> BKey -> Result (Maybe a)-(>--?) = optKey-{-# INLINE (>--?) #-}--{--------------------------------------------------------------------- Predicates---------------------------------------------------------------------}---- | Test if bencoded value is an integer.-isInteger :: BValue -> Bool-isInteger (BInteger _) = True-isInteger _ = False-{-# INLINE isInteger #-}---- | Test if bencoded value is a string, both raw and utf8 encoded.-isString :: BValue -> Bool-isString (BString _) = True-isString _ = False-{-# INLINE isString #-}---- | Test if bencoded value is a list.-isList :: BValue -> Bool-isList (BList _) = True-isList _ = False-{-# INLINE isList #-}+--+-- NOTE: the actions SHOULD be sorted lexicographically by keys, so:+-- "length" < "md5sum" < "path" < "tags".+--+newtype Get a = Get { runGet :: StateT BDict Result a }+ deriving (Functor, Applicative, Alternative, Monad) --- | Test if bencoded value is a dictionary.-isDict :: BValue -> Bool-isDict (BList _) = True-isDict _ = False-{-# INLINE isDict #-}+-- | Get lexicographical successor of the current key\/value pair.+next :: Get BValue+next = Get (StateT go)+ where+ go Nil = throwError "no next"+ go (Cons _ v xs) = pure (v, xs) -{--------------------------------------------------------------------- Encoding---------------------------------------------------------------------}+-- | Extract /required/ value from the given key.+req :: BKey -> Get BValue+req !key = Get (StateT search)+ where+ search Nil = Left msg+ search (Cons k v xs) =+ case compare k key of+ EQ -> pure (v, xs)+ LT -> search xs+ GT -> Left msg --- | Convert bencoded value to raw bytestring according to the--- specification.-encode :: BValue -> Lazy.ByteString-encode = B.toLazyByteString . builder+ msg = "required field `" ++ BC.unpack key ++ "' not found"+{-# INLINE req #-} --- | Try to convert raw bytestring to bencoded value according to--- specification.-decode :: ByteString -> Result BValue-decode = P.parseOnly parser+-- | Extract optional value from the given key.+opt :: BKey -> Get (Maybe BValue)+opt = optional . req+{-# INLINE opt #-} --- | The same as 'decode' but returns any bencodable value.-decoded :: BEncode a => ByteString -> Result a-decoded = decode >=> fromBEncode+-- | Reconstruct a bencodable value from bencode value.+field :: BEncode a => Get BValue -> Get a+{-# SPECIALIZE field :: Get BValue -> Get BValue #-}+field m = Get $ do+ v <- runGet m+ either throwError pure $ fromBEncode v --- | The same as 'encode' but takes any bencodable value.-encoded :: BEncode a => a -> Lazy.ByteString-encoded = encode . toBEncode+-- | Shorthand for /f <$> field (req k)/.+(<$>!) :: BEncode a => (a -> b) -> BKey -> Get b+f <$>! k = f <$> field (req k)+{-# INLINE (<$>!) #-} -{--------------------------------------------------------------------- Internals---------------------------------------------------------------------}+-- | Shorthand for /f <$> optional (field (req k))/.+(<$>?) :: BEncode a => (Maybe a -> b) -> BKey -> Get b+f <$>? k = f <$> optional (field (req k))+{-# INLINE (<$>?) #-} --- | BEncode format encoder according to specification.-builder :: BValue -> B.Builder-builder = go- where- go (BInteger i) = B.word8 (c2w 'i') <>- B.integerDec i <>- 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+-- | Shorthand for /f <*> field (req k)/.+(<*>!) :: BEncode a => Get (a -> b) -> BKey -> Get b+f <*>! k = f <*> field (req k)+{-# INLINE (<*>!) #-} - buildString s = B.intDec (B.length s) <>- B.word8 (c2w ':') <>- B.byteString s- {-# INLINE buildString #-}+-- | Shorthand for /f <*> optional (field (req k))/.+(<*>?) :: BEncode a => Get (Maybe a -> b) -> BKey -> Get b+f <*>? k = f <*> optional (field (req k))+{-# INLINE (<*>?) #-} --- TODO try to replace peekChar with something else--- | BEncode format parser according to specification.-parser :: Parser BValue-parser = valueP+-- | Run a 'Get' monad.+fromDict :: forall a. Typeable a => Get a -> BValue -> Result a+fromDict m (BDict d) = evalStateT (runGet m) d+fromDict _ _ = decodingError (show (typeOf inst)) 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 Integer- integerP = do- c <- P.peekChar- case c of- Just '-' -> do- P.anyChar- negate <$> P.decimal- _ -> P.decimal- {-# INLINE integerP #-}+ inst = error "fromDict: impossible" :: a {--------------------------------------------------------------------- Pretty Printing+ Encoding --------------------------------------------------------------------} -ppBS :: ByteString -> Doc-ppBS = text . map w2c . B.unpack+-- | Decode a value from a strict 'ByteString' using bencode format.+decode :: BEncode a => ByteString -> Result a+decode = parse >=> fromBEncode --- | Convert to easily readable JSON-like document. Typically used for--- debugging purposes.-ppBEncode :: BValue -> 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+-- | Encode a value using bencode format to a lazy 'ByteString'.+encode :: BEncode a => a -> Lazy.ByteString+encode = build . toBEncode
+ src/Data/BEncode/BDict.hs view
@@ -0,0 +1,151 @@+-- |+-- Copyright : (c) Sam Truzjan 2013+-- License : BSD3+-- Maintainer : pxqr.sta@gmail.com+-- Stability : stable+-- Portability : portable+--+-- This module defines a simple key\/value list which both faster+-- and more suitable for bencode dictionaries then just [(k,v)].+--+module Data.BEncode.BDict+ ( BKey+ , BDictMap (..)++ -- * Construction+ , Data.BEncode.BDict.empty+ , Data.BEncode.BDict.singleton++ -- * Query+ , Data.BEncode.BDict.null+ , Data.BEncode.BDict.member+ , Data.BEncode.BDict.lookup++ -- * Combine+ , Data.BEncode.BDict.union++ -- * Traversal+ , Data.BEncode.BDict.map+ , Data.BEncode.BDict.bifoldMap++ -- * Conversion+ , Data.BEncode.BDict.fromAscList+ , Data.BEncode.BDict.toAscList+ ) where++import Control.DeepSeq+import Data.ByteString as BS+import Data.Foldable+import Data.Monoid+++type BKey = ByteString++-- STRICTNESS NOTE: the BKey is always evaluated since we either use a+-- literal or compare before insert to the dict+--+-- LAYOUT NOTE: we don't use [StrictPair BKey a] since it introduce+-- one more constructor per cell+--++-- | BDictMap is an ascending list of key\/value pairs sorted by keys.+data BDictMap a+ = Cons !BKey a !(BDictMap a)+ | Nil+ deriving (Show, Read, Eq, Ord)++instance NFData a => NFData (BDictMap a) where+ rnf Nil = ()+ rnf (Cons _ v xs)= rnf v `seq` rnf xs++instance Functor BDictMap where+ fmap = Data.BEncode.BDict.map+ {-# INLINE fmap #-}++instance Foldable BDictMap where+ foldMap f = go+ where+ go Nil = mempty+ go (Cons _ v xs) = f v `mappend` go xs+ {-# INLINE foldMap #-}++instance Monoid (BDictMap a) where+ mempty = Data.BEncode.BDict.empty+ mappend = Data.BEncode.BDict.union++-- | /O(1)/. The empty dicionary.+empty :: BDictMap a+empty = Nil+{-# INLINE empty #-}++-- | /O(1)/. Dictionary of one key-value pair.+singleton :: BKey -> a -> BDictMap a+singleton k v = Cons k v Nil+{-# INLINE singleton #-}++-- | /O(1)/. Is the dictionary empty?+null :: BDictMap a -> Bool+null Nil = True+null _ = False+{-# INLINE null #-}++-- | /O(n)/. Is the key a member of the dictionary?+member :: BKey -> BDictMap a -> Bool+member key = go+ where+ go Nil = False+ go (Cons k _ xs)+ | k == key = True+ | otherwise = go xs++-- | /O(n)/. Lookup the value at a key in the dictionary.+lookup :: BKey -> BDictMap a -> Maybe a+lookup x = go+ where+ go Nil = Nothing+ go (Cons k v xs)+ | k == x = Just v+ | otherwise = go xs+{-# INLINE lookup #-}++-- | /O(n + m)/. Merge two dictionaries by taking pair from both given+-- dictionaries. Dublicated keys are /not/ filtered.+--+union :: BDictMap a -> BDictMap a -> BDictMap a+union Nil xs = xs+union xs Nil = xs+union bd @ (Cons k v xs) bd' @ (Cons k' v' xs')+ | k < k' = Cons k v (union xs bd')+ | otherwise = Cons k' v' (union bd xs')++-- | /O(n)./ Map a function over all values in the dictionary.+map :: (a -> b) -> BDictMap a -> BDictMap b+map f = go+ where+ go Nil = Nil+ go (Cons k v xs) = Cons k (f v) (go xs)+{-# INLINE map #-}++-- | /O(n)/. Map each key\/value pair to a monoid and fold resulting+-- sequnce using 'mappend'.+--+bifoldMap :: Monoid m => (BKey -> a -> m) -> BDictMap a -> m+bifoldMap f = go+ where+ go Nil = mempty+ go (Cons k v xs) = f k v `mappend` go xs+{-# INLINE bifoldMap #-}++-- | /O(n)/. Build a dictionary from a list of key\/value pairs where+-- the keys are in ascending order.+--+fromAscList :: [(BKey, a)] -> BDictMap a+fromAscList [] = Nil+fromAscList ((k, v) : xs) = Cons k v (fromAscList xs)++-- | /O(n)/. Convert the dictionary to a list of key\/value pairs+-- where the keys are in ascending order.+--+toAscList :: BDictMap a -> [(BKey, a)]+toAscList Nil = []+toAscList (Cons k v xs) = (k, v) : toAscList xs
+ src/Data/BEncode/Internal.hs view
@@ -0,0 +1,136 @@+-- |+-- Copyright : (c) Sam Truzjan 2013+-- License : BSD3+-- Maintainer : pxqr.sta@gmail.com+-- Stability : stable+-- Portability : portable+--+-- This module provides bencode values serialization. Normally, you+-- don't need to import this module.+--+module Data.BEncode.Internal+ ( parse+ , build+ , ppBEncode+ ) where++import Control.Applicative+import Data.Attoparsec.ByteString.Char8 (Parser)+import qualified Data.Attoparsec.ByteString.Char8 as P+import Data.ByteString as B+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 Data.Foldable+import Data.List as L+import Data.Monoid+import Text.PrettyPrint hiding ((<>))++import Data.BEncode.Types+import Data.BEncode.BDict as BD+++{--------------------------------------------------------------------+-- Serialization+--------------------------------------------------------------------}++-- | BEncode format encoder according to specification.+builder :: BValue -> B.Builder+builder = go+ where+ go (BInteger i) = B.word8 (c2w 'i') <>+ B.integerDec i <>+ 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') <>+ bifoldMap mkKV 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 #-}++-- | Convert bencoded value to raw bytestring according to the+-- specification.+build :: BValue -> Lazy.ByteString+build = B.toLazyByteString . builder++{--------------------------------------------------------------------+-- Deserialization+--------------------------------------------------------------------}++-- TODO try to replace peekChar with something else+-- | BEncode format parser according to specification.+parser :: Parser BValue+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 <$> listBodyP) <* P.anyChar)+ 'd' -> P.anyChar *> (BDict <$> dictBodyP) <* P.anyChar+ t -> fail ("bencode unknown tag: " ++ [t])++ dictBodyP :: Parser BDict+ dictBodyP = Cons <$> stringP <*> valueP <*> dictBodyP+ <|> pure Nil++ listBodyP = do+ c <- P.peekChar+ case c of+ Just 'e' -> return []+ _ -> (:) <$> valueP <*> listBodyP++ stringP :: Parser ByteString+ stringP = do+ n <- P.decimal :: Parser Int+ P.char ':'+ P.take n+ {-# INLINE stringP #-}++ integerP :: Parser Integer+ integerP = do+ c <- P.peekChar+ case c of+ Just '-' -> do+ P.anyChar+ negate <$> P.decimal+ _ -> P.decimal+ {-# INLINE integerP #-}++-- | Try to convert raw bytestring to bencoded value according to+-- specification.+parse :: ByteString -> Either String BValue+parse = P.parseOnly parser++{--------------------------------------------------------------------+ Pretty Printing+--------------------------------------------------------------------}++ppBS :: ByteString -> Doc+ppBS = text . L.map w2c . B.unpack++-- | Convert to easily readable JSON-like document. Typically used for+-- debugging purposes.+ppBEncode :: BValue -> Doc+ppBEncode (BInteger i) = int $ fromIntegral i+ppBEncode (BString s) = ppBS s+ppBEncode (BList l)+ = brackets $ hsep $ punctuate comma $ L.map ppBEncode l+ppBEncode (BDict d)+ = braces $ vcat $ punctuate comma $ L.map ppKV $ BD.toAscList d+ where+ ppKV (k, v) = ppBS k <+> colon <+> ppBEncode v
+ src/Data/BEncode/Types.hs view
@@ -0,0 +1,86 @@+-- |+-- Copyright : (c) Sam Truzjan 2013+-- License : BSD3+-- Maintainer : pxqr.sta@gmail.com+-- Stability : stable+-- Portability : portable+--+-- Types for working with bencode data.+--+module Data.BEncode.Types+ ( -- * Types+ BInteger+ , BString+ , BList+ , BDict+ , BValue (..)++ -- * Predicates+ , isInteger+ , isString+ , isList+ , isDict+ ) where++import Control.DeepSeq+import Data.ByteString++import Data.BEncode.BDict++-- | A bencode "integer".+type BInteger = Integer++-- | A raw bencode string.+type BString = ByteString++-- | A plain bencode list.+type BList = [BValue]++-- | A bencode dictionary.+type BDict = BDictMap BValue++-- | 'BValue' 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 BValue+ = BInteger !BInteger -- ^ bencode integers;+ | BString !BString -- ^ bencode strings;+ | BList BList -- ^ list of bencode values;+ | BDict BDict -- ^ bencode key-value dictionary.+ deriving (Show, Read, Eq, Ord)++instance NFData BValue where+ rnf (BInteger i) = rnf i+ rnf (BString s) = rnf s+ rnf (BList l) = rnf l+ rnf (BDict d) = rnf d++{--------------------------------------------------------------------+ Predicates+--------------------------------------------------------------------}++-- | Test if bencoded value is an integer.+isInteger :: BValue -> Bool+isInteger (BInteger _) = True+isInteger _ = False+{-# INLINE isInteger #-}++-- | Test if bencoded value is a string, both raw and utf8 encoded.+isString :: BValue -> Bool+isString (BString _) = True+isString _ = False+{-# INLINE isString #-}++-- | Test if bencoded value is a list.+isList :: BValue -> Bool+isList (BList _) = True+isList _ = False+{-# INLINE isList #-}++-- | Test if bencoded value is a dictionary.+isDict :: BValue -> Bool+isDict (BList _) = True+isDict _ = False+{-# INLINE isDict #-}
tests/properties.hs view
@@ -54,7 +54,7 @@ data T a = T prop_bencodable :: Eq a => BEncode a => T a -> a -> Bool-prop_bencodable _ x = decoded (L.toStrict (encoded x)) == Right x+prop_bencodable _ x = decode (L.toStrict (encode x)) == Right x -- All tests are (encode >>> decode = id) main :: IO ()