diff --git a/NEWS.md b/NEWS.md --- a/NEWS.md +++ b/NEWS.md @@ -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. diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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 ] diff --git a/bencoding.cabal b/bencoding.cabal --- a/bencoding.cabal +++ b/bencoding.cabal @@ -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 diff --git a/src/Data/BEncode.hs b/src/Data/BEncode.hs --- a/src/Data/BEncode.hs +++ b/src/Data/BEncode.hs @@ -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 diff --git a/src/Data/BEncode/BDict.hs b/src/Data/BEncode/BDict.hs new file mode 100644 --- /dev/null +++ b/src/Data/BEncode/BDict.hs @@ -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 diff --git a/src/Data/BEncode/Internal.hs b/src/Data/BEncode/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/BEncode/Internal.hs @@ -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 diff --git a/src/Data/BEncode/Types.hs b/src/Data/BEncode/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/BEncode/Types.hs @@ -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 #-} diff --git a/tests/properties.hs b/tests/properties.hs --- a/tests/properties.hs +++ b/tests/properties.hs @@ -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 ()