diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,26 @@ +# bencode + +[![travis][badge-travis]][travis] +[![hackage][badge-hackage]][hackage] +[![license][badge-license]][license] + +Haskell Parser and printer for bencoded data. + +Bencode (pronounced like B encode) is the encoding used by the +peer-to-peer file sharing system BitTorrent for storing and +transmitting loosely structured data. + + +# Support + +- [Issue tracker][issues] + + + +[badge-travis]: https://travis-ci.org/creichert/bencode.svg?branch=master +[travis]: https://travis-ci.org/creichert/bencode +[badge-hackage]: https://img.shields.io/hackage/v/bencode.svg?dummy +[hackage]: https://hackage.haskell.org/package/bencode +[badge-license]: https://img.shields.io/badge/license-BSD3-green.svg?dummy +[license]: https://github.com/creichert/bencode/blob/master/LICENSE +[issues]: https://github.com/creichert/bencode/issues diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,5 +1,8 @@ #!/usr/bin/env runhaskell -> module Main where + +> module Main (main) where +> > import Distribution.Simple +> > main :: IO () -> main = defaultMainWithHooks defaultUserHooks +> main = defaultMain diff --git a/bencode.cabal b/bencode.cabal --- a/bencode.cabal +++ b/bencode.cabal @@ -1,21 +1,48 @@ -Name: bencode -Version: 0.5.0.1 -Maintainer: Lemmih (lemmih@gmail.com) -Author: Lemmih (lemmih@gmail.com), Jesper Louis Andersen -Copyright: (c) 2005-2009, David Himmelstrup - 2006 Lemmih - 2005 Jesper Louis Andersen -License-File: LICENSE -License: BSD3 -Build-Depends: base<5, parsec, bytestring, containers, binary -Build-Type: Simple -Category: Text -Synopsis: Parser and printer for bencoded data. -Tested-with: GHC ==6.8.1, GHC ==6.10.2 -Extensions: PatternGuards -Exposed-Modules: - Data.BEncode - Data.BEncode.Lexer - Data.BEncode.Parser -GHC-Options: -Wall -Hs-Source-Dirs: src +name: bencode +version: 0.6.1.1 +synopsis: Parsers and printers for bencoded data. +description: Parsers and printers for bencoded data. Bencode (pronounced like B + encode) is the encoding used by the peer-to-peer file sharing system + BitTorrent for storing and transmitting loosely structured data. +license: BSD3 +license-file: LICENSE +copyright: (c) 2005-2009, David Himmelstrup, + (c) 2006 Lemmih , + (c) 2005 Jesper Louis Andersen +author: Lemmih , + Jesper Louis Andersen , + Christopher Reichert +maintainer: Peter Simons +tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, + GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.2 +category: Text +build-type: Simple +extra-source-files: README.md +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/creichert/bencode + +library + exposed-modules: Data.BEncode + Data.BEncode.Lexer + Data.BEncode.Parser + Data.BEncode.Reader + hs-source-dirs: src + build-depends: base == 4.* + , binary + , bytestring + , containers + , parsec + , transformers + , transformers-compat >= 0.4 + default-language: Haskell2010 + default-extensions: PatternGuards + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: tests + build-depends: base, QuickCheck, bencode, bytestring, containers, hspec + default-language: Haskell2010 diff --git a/src/Data/BEncode.hs b/src/Data/BEncode.hs --- a/src/Data/BEncode.hs +++ b/src/Data/BEncode.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- | --- Module : BEncode +-- Module : Data.BEncode -- Copyright : (c) 2005 Jesper Louis Andersen -- 2006 Lemmih -- License : BSD3 @@ -41,10 +41,10 @@ data type here -} data BEncode = BInt Integer - | BString L.ByteString - | BList [BEncode] + | BString L.ByteString + | BList [BEncode] | BDict (Map String BEncode) - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show) instance Binary BEncode where put e = put (BS.concat $ L.toChunks $ bPack e) @@ -53,7 +53,7 @@ Just e -> return e Nothing -> fail "Failed to parse BEncoded data" --- Source possition is pretty useless in BEncoded data. FIXME +-- Source position is pretty useless in BEncoded data. FIXME updatePos :: (SourcePos -> Token -> [Token] -> SourcePos) updatePos pos _ _ = pos @@ -92,10 +92,11 @@ bList = withToken TList $ fmap BList (many bParse) bDict :: BParser BEncode -bDict = withToken TDict $ fmap (BDict . Map.fromAscList) (checkList =<< many1 bAssocList) - where checkList lst = if (lst /= sort lst) - then fail "dictionary not sorted" - else return lst +bDict = withToken TDict $ + fmap (BDict . Map.fromAscList) (checkList =<< many bAssocList) + where checkList lst = if lst /= sort lst + then fail "dictionary not sorted" + else return lst bAssocList = do str <- tstring value <- bParse @@ -109,18 +110,18 @@ -} bRead :: L.ByteString -> Maybe BEncode bRead str = case parse bParse "" (lexer str) of - Left _err -> Nothing - Right b -> Just b + Left _err -> Nothing + Right b -> Just b -- | Render a BEncode structure to a B-coded string bShow :: BEncode -> ShowS -bShow be = bShow' be +bShow = bShow' where sc = showChar ss = showString sKV (k,v) = sString k (length k) . bShow' v - sDict dict = foldr (.) id (map sKV (Map.toAscList dict)) - sList list = foldr (.) id (map bShow' list) + sDict dict = foldr ((.) . sKV) id (Map.toAscList dict) + sList = foldr ((.) . bShow') id sString str len = shows len . sc ':' . ss str bShow' b = case b of diff --git a/src/Data/BEncode/Lexer.hs b/src/Data/BEncode/Lexer.hs --- a/src/Data/BEncode/Lexer.hs +++ b/src/Data/BEncode/Lexer.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- | --- Module : BEncode.Lexer +-- Module : Data.BEncode.Lexer -- Copyright : (c) 2005 Jesper Louis Andersen -- 2006 Lemmih -- License : BSD3 diff --git a/src/Data/BEncode/Parser.hs b/src/Data/BEncode/Parser.hs --- a/src/Data/BEncode/Parser.hs +++ b/src/Data/BEncode/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : BParser @@ -9,7 +10,8 @@ -- -- A parsec style parser for BEncoded data ----------------------------------------------------------------------------- -module Data.BEncode.Parser +module Data.BEncode.Parser {-# + DEPRECATED "Use \"Data.BEncode.Reader\" instead" #-} ( BParser , runParser , token @@ -24,14 +26,23 @@ ) where -import Data.BEncode -import qualified Data.Map as Map +import Control.Applicative hiding (optional) +import Control.Monad +import Data.BEncode import qualified Data.ByteString.Lazy.Char8 as L -import Control.Monad +import qualified Data.Map as Map +#if MIN_VERSION_base(4,13,0) +import qualified Control.Monad.Fail as Fail +#endif + data BParser a = BParser (BEncode -> Reply a) +instance Alternative BParser where + (<|>) = mplus + empty = mzero + instance MonadPlus BParser where mzero = BParser $ \_ -> Error "mzero" mplus (BParser a) (BParser b) = BParser $ \st -> case a st of @@ -46,19 +57,23 @@ = Ok a BEncode | Error String +instance Applicative BParser where + pure = return + (<*>) = ap + instance Monad BParser where (BParser p) >>= f = BParser $ \b -> case p b of Ok a b' -> runB (f a) b' Error str -> Error str return val = BParser $ Ok val +#if MIN_VERSION_base(4,13,0) +instance Fail.MonadFail BParser where +#endif fail str = BParser $ \_ -> Error str instance Functor BParser where - fmap fn p = do a <- p - return (fn a) + fmap = liftM -(<|>) :: BParser a -> BParser a -> BParser a -a <|> b = a `mplus` b runParser :: BParser a -> BEncode -> Either String a runParser parser b = case runB parser b of @@ -79,7 +94,7 @@ list name p = dict name >>= \lst -> BParser $ \b -> case lst of - BList bs -> foldr cat (Ok [] b) (map (runB p) bs) + BList bs -> foldr (cat . runB p) (Ok [] b) bs _ -> Error $ "Not a list: " ++ name where cat (Ok v _) (Ok vs b) = Ok (v:vs) b cat (Ok _ _) (Error str) = Error str diff --git a/src/Data/BEncode/Reader.hs b/src/Data/BEncode/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Data/BEncode/Reader.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_HADDOCK show-extensions #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.BEncode.Reader +-- Copyright : (c) 2015 Matthew Leon +-- License : BSD3 +-- Maintainer : creichert07@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Reader monad and combinators for BEncoded data. +-- +-- This is intended to replace the older "Data.BEncode.Parser" module. +-- +-- Usage example: +-- +-- >>> :set -XOverloadedStrings +-- >>> let bd = (BDict $ Map.fromList [("baz", BInt 1), ("foo", BString "bar")]) +-- >>> :{ +-- let bReader = do +-- baz <- dict "baz" bint +-- foo <- dict "foo" bstring +-- shouldBeNothing <- optional $ dict "optionalKey" bint +-- return (foo, baz, shouldBeNothing) +-- in runBReader bReader bd +-- :} +-- Right ("bar",1,Nothing) +----------------------------------------------------------------------------- + +module Data.BEncode.Reader ( + -- * Reader Monad + BReader, runBReader, + -- * Combinators + bint, bbytestring, bstring, optional, list, dict + ) where + +import Control.Applicative +import Control.Monad (MonadPlus) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Except +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.Map as Map + +import Data.BEncode + +----------------------------------------------------------------------------- +----------------------------------------------------------------------------- + +newtype BReader a = BReader (ExceptT String (Reader BEncode) a) + deriving (Functor, Applicative, Alternative, Monad, MonadPlus) +-- ^Reader monad for extracting data from a BEncoded structure. + +breader :: (BEncode -> (Either String a)) -> BReader a +breader = BReader . ExceptT . reader +-- ^BReader constructor. Private. + +runBReader :: BReader a -> BEncode -> Either String a +runBReader (BReader br) = runReader $ runExceptT br +-- ^Run a BReader. See usage examples elsewhere in this file. + +----------------------------------------------------------------------------- +----------------------------------------------------------------------------- + +bbytestring :: BReader L.ByteString +bbytestring = breader $ \b -> case b of + BString str -> return str + _ -> Left $ "Expected BString, found: " ++ show b +-- ^ Usage same as bstring, below. +-- (sadly, doctests for this cause errors on GHC 7.4) + +bstring :: BReader String +bstring = fmap L.unpack bbytestring +-- ^ +-- >>> runBReader bstring (BString "foo") +-- Right "foo" +-- + +bint :: BReader Integer +bint = breader $ \b -> case b of + BInt int -> return int + _ -> Left $ "Expected BInt, found: " ++ show b +-- ^ +-- >>> runBReader bint (BInt 42) +-- Right 42 +-- + +list :: BReader a -> BReader [a] +list br = breader $ \b -> case b of + BList bs -> mapM (runBReader br) bs + _ -> Left $ "Not a list: " ++ show b +-- ^ Read a list of BEncoded data +-- +-- >>> runBReader (list bint) (BList [BInt 1, BInt 2]) +-- Right [1,2] +-- +-- >>> runBReader (list bint) (BList []) +-- Right [] +-- +-- >>> let bs = (BList [BList [BString "foo", BString "bar"], BList []]) +-- >>> runBReader (list $ list bstring) bs +-- Right [["foo","bar"],[]] + +dict :: String -> BReader a -> BReader a +dict name br = breader $ \b -> case b of + BDict bmap | (Just code) <- Map.lookup name bmap -> runBReader br code + BDict _ -> Left $ "Name not found in dictionary: " ++ name + _ -> Left $ "Not a dictionary: " ++ show b +-- ^ Read the values of a BDict corresponding to a string key +-- +-- >>> let bd = (BDict $ Map.fromList [("bar", BInt 2), ("foo", BInt 1)]) +-- >>> runBReader (dict "foo" bint) bd +-- Right 1 +-- +-- +-- >>> :{ +-- let bs = (BList [BDict $ Map.fromList [("baz", BInt 2), +-- ("foo", BString "bar")], +-- BDict $ Map.singleton "foo" (BString "bam")]) +-- in runBReader (list $ dict "foo" bstring) bs +-- :} +-- Right ["bar","bam"] +-- +-- >>> :{ +-- let bd = (BDict $ Map.singleton "foo" (BList [ +-- BString "foo", BString "bar" +-- ])) +-- in runBReader (dict "foo" $ list $ bstring) bd +-- :} +-- Right ["foo","bar"] diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- orphan Arbitrary instance is fine + +import qualified Data.Map as Map + +import Test.Hspec +import Test.QuickCheck + +import Data.BEncode +import Data.ByteString.Lazy (pack) + +instance Arbitrary BEncode where arbitrary = sized bencode' + +bencode' :: Int -> Gen BEncode +bencode' 0 = oneof [BInt `fmap` arbitrary, (BString . pack) `fmap` arbitrary] +bencode' n = oneof [ + BInt `fmap` arbitrary, + (BString . pack) `fmap` arbitrary :: Gen BEncode, + BList `fmap` (resize (n `div` 2) arbitrary), + (BDict . Map.fromList) `fmap` (resize (n `div` 2) arbitrary) + ] + +main :: IO () +main = hspec $ do + + let bll = BList [BInt (-1), BInt 0, BInt 1, BInt 2, BInt 3, BString "four"] + + describe "Data.BEncode encoding" $ do + it "encodes integers" $ + bRead "i42e" `shouldBe` Just (BInt 42) + it "encodes strings" $ + bRead "3:foo" `shouldBe` Just (BString "foo") + it "encodes strings with special characters in Haskell source" $ + bRead "5:café" `shouldBe` Just (BString "café") + it "encodes lists" $ + bRead "l5:helloi42eli-1ei0ei1ei2ei3e4:fouree" + `shouldBe` Just (BList [ BString "hello", BInt 42, bll ]) + it "encodes nested lists" $ + bRead "ll5:helloi62eel3:fooee" + `shouldBe` Just (BList + [ BList [ BString "hello", BInt 62 ], + BList [ BString "foo" ] ]) + it "encodes dictionaries" $ + bRead "d3:baz3:moo3:foo3:bare" + `shouldBe` Just + (BDict (Map.fromList + [("baz",BString "moo"),("foo",BString "bar")])) + it "encodes empty dictionaries" $ + bRead "de" `shouldBe` Just (BDict Map.empty) + + describe "Data.BEncode decoding" $ do + -- TODO failing + -- it "is the inverse of encoding" $ property $ \bencode -> + -- (bRead . bPack) bencode == Just bencode + it "decodes int" $ + bPack (BInt 42) `shouldBe` "i42e" + it "decodes null int" $ + bPack (BInt 0) `shouldBe` "i0e" + it "decodes negative int" $ + bPack (BInt (-42)) `shouldBe` "i-42e" + it "decodes string" $ do + bPack (BString "foo") `shouldBe` "3:foo" + bPack (BString "") `shouldBe` "0:" + it "decodes lists" $ + bPack (BList [BInt 1, BInt 2, BInt 3]) `shouldBe` "li1ei2ei3ee" + it "decodes lists of lists" $ + bPack (BList [ BList [BInt 1], BInt 1, BInt 2, BInt 3]) + `shouldBe` "lli1eei1ei2ei3ee" + it "decodes hash" $ do + let d = Map.fromList [("foo", BString "bar"), ("baz",BString "qux")] + bPack (BDict d) `shouldBe` "d3:baz3:qux3:foo3:bare" + -- FIX + -- it "decodes unicode" $ do + -- bPack (BString "café") `shouldBe` "5:café" + -- bPack (BList [BString "你好", BString "中文"]) `shouldBe` "l6:你好6:中文e" + it "decodes lists of lists" $ + bRead "l5:helloi42eli-1ei0ei1ei2ei3e4:fouree" + `shouldBe` Just (BList [ BString "hello", BInt 42, bll])