benc (empty) → 0.1.0.0
raw patch · 11 files changed
+1844/−0 lines, 11 filesdep +AttoBencodedep +basedep +benc
Dependencies added: AttoBencode, base, benc, bencode, bencoding, bytestring, containers, deepseq, primitive, tasty, tasty-bench, tasty-hunit, tasty-quickcheck, text, transformers, vector
Files
- CHANGELOG.md +3/−0
- LICENSE +20/−0
- README.md +100/−0
- benc.cabal +86/−0
- compare/Bench.hs +413/−0
- src/Data/Bencode/AST.hs +227/−0
- src/Data/Bencode/Decode.hs +403/−0
- src/Data/Bencode/Encode.hs +247/−0
- src/Data/Bencode/Type.hs +22/−0
- src/Data/Bencode/Util.hs +58/−0
- test/Test.hs +265/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+### 0.1.0.0 -- 2023-11-09++* First version.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2023 Soumik Sarkar++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,100 @@+# benc++Bencode encoding and decoding library++## Bencode++Bencode is a simple encoding format for loosely structured data, comparable to+JSON. It is used primarily in the BitTorrent protocol. For a description of the+format see++* [The BitTorrent Protocol Specification (BEP-3)](https://www.bittorrent.org/beps/bep_0003.html)+* [Bencode on Wikipedia](https://en.wikipedia.org/wiki/Bencode)++## Features++This library offers++* A nice API+* Correctness+* Speed++This library does not attempt to support++* Lazy or incremental parsing+* Failing with detailed error messages++## Getting started++Please see the Haddocks for [`Data.Bencode.Decode`](https://hackage.haskell.org/package/benc/docs/Data-Bencode-Decode.html)+and [`Data.Bencode.Encode`](https://hackage.haskell.org/package/benc/docs/Data-Bencode-Encode.html).++## Alternatives++There are currently three other Bencode libraries on Hackage:++* [bencode](https://hackage.haskell.org/package/bencode)+* [AttoBencode](https://hackage.haskell.org/package/AttoBencode)+* [bencoding](https://hackage.haskell.org/package/bencoding)++All of these are in some combination of buggy, slow, and unmaintained.++<details>+<summary>Click for details</summary>++* `bencode`:+ * Bugs (e.g. crashes on input `"i-e"`)+ * Very slow parsing+ * No high-level encoding API+ * [Minor] Lax parsing (e.g. admits the invalid `"i-0e"`)+* `AttoBencode`+ * Slow parsing+ * [Minor] Lax parsing (e.g. admits the invalid `"i-0e"`)+* `bencoding`+ * Bugs (e.g. crashes on parsing non-UTF-8 into Text)+ * Questionable design of dict encoding/decoding API, where human error can+ lead to mis-parsing Bencode or writing invalid Bencode.+ * [Minor] Lax parsing (e.g. admits the invalid `"i-0e"`)++</details>++### API comparison++See the [benchmark file](https://github.com/meooow25/benc/blob/master/compare/Bench.hs)+as a comparison point of the library APIs.++### Benchmarks++Below is a comparison of decoding and encoding of two torrent files, performed+with GHC 9.6.3. See the [benchmark file](https://github.com/meooow25/benc/blob/master/compare/Bench.hs)+for details.++#### Decoding++| Library | `crossref` | `ubuntu` |+| ----------- | ---------------- | ---------------- |+| benc | 27.6 ms ± 2.1 ms | 1.46 μs ± 93 ns |+| bencode | 218 ms ± 11 ms | 28.4 μs ± 1.5 μs |+| AttoBencode | 44.8 ms ± 3.8 ms | 2.97 μs ± 171 ns |+| bencoding | 39.7 ms ± 3.7 ms | 2.38 μs ± 181 ns |++<sup>Note: `bencode` parses from a lazy `ByteString` unlike the rest which parse+from strict `ByteString`s, and so is expected to be a little slower.</sup>++#### Encoding++| Library | `crossref` | `ubuntu` |+| ----------- | ---------------- | ---------------- |+| benc | 11.8 ms ± 1.0 ms | 1.91 μs ± 179 ns |+| bencode | 42.4 ms ± 3.1 ms | 3.19 μs ± 173 ns |+| AttoBencode | 20.2 ms ± 1.1 ms | 10.2 μs ± 387 ns |+| bencoding | 11.6 ms ± 1.1 ms | 1.79 μs ± 100 ns |++<sup>Note: `AttoBencode` encodes to a strict `ByteString` via a lazy+`ByteString`, unlike the rest, which only prepare the lazy `ByteString`. As+such, it is expected to be slower.</sup>++## Contributing++Contributions, bug reports, suggestions welcome! Please+[open an issue](https://github.com/meooow25/benc/issues).
+ benc.cabal view
@@ -0,0 +1,86 @@+cabal-version: 2.4+name: benc+version: 0.1.0.0+synopsis: Bencode encoding and decoding library+description: Bencode encoding and decoding library.+homepage: https://github.com/meooow25/benc+bug-reports: https://github.com/meooow25/benc/issues+license: MIT+license-file: LICENSE+author: Soumik Sarkar+maintainer: soumiksarkar.3120@gmail.com+category: Codec+extra-doc-files:+ README.md+ CHANGELOG.md++common warnings+ ghc-options: -Wall++library+ import: warnings++ exposed-modules:+ Data.Bencode.Decode+ Data.Bencode.Encode+ Data.Bencode.Type++ other-modules:+ Data.Bencode.AST+ Data.Bencode.Util++ build-depends:+ base >= 4.14 && < 5.0+ , bytestring >= 0.10.12 && < 0.13+ , containers >= 0.6.5 && < 0.8+ , primitive >= 0.9.0 && < 0.10+ , text >= 1.2.4 && < 2.2+ , transformers >= 0.5.6 && < 0.7+ , vector >= 0.13.1 && < 0.14++ hs-source-dirs: src+ default-language: Haskell2010++test-suite benc-test+ import: warnings++ build-depends:+ base+ , benc+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , bytestring+ , containers+ , text+ , vector++ hs-source-dirs: test+ main-is: Test.hs+ default-language: Haskell2010+ type: exitcode-stdio-1.0++benchmark benc-compare+ import: warnings++ build-depends:+ base+ , benc+ , bencode == 0.6.1.1+ , AttoBencode == 0.3.1.0+ , bencoding == 0.4.5.4+ , tasty+ , tasty-bench+ , tasty-hunit+ , bytestring+ , containers+ , deepseq+ , text+ , transformers == 0.5.6.2+ , vector+ -- bencoding depends on an orphan in the removed Control.Monad.Trans.Error++ hs-source-dirs: compare+ main-is: Bench.hs+ default-language: Haskell2010+ type: exitcode-stdio-1.0
+ compare/Bench.hs view
@@ -0,0 +1,413 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE PackageImports #-}+module Main (main) where++import Test.Tasty.Bench+import Test.Tasty.HUnit++import Control.Applicative+import Control.DeepSeq+import Control.Exception+import Data.Maybe+import System.IO+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V+import GHC.Generics++import qualified Data.AttoBencode as Atto+import qualified "bencode" Data.BEncode as Ben+import qualified Data.BEncode.Reader as Ben+import qualified "bencoding" Data.BEncode as Ing+import qualified Data.Bencode.Decode as D+import qualified Data.Bencode.Encode as E++main :: IO ()+main = do+ defaultMain $+ [ env (withFile testFile ReadMode B.hGetContents) $ \testData ->+ bgroup testName+ [ bgroup "Decode"+ [ bench "benc" $ nf decodeBenc testData+ , bench "bencode" $ nf decodeBencode testData+ , bench "AttoBencode" $ nf decodeAttoBencode testData+ , bench "bencoding" $ nf decodeBencoding testData+ , testCase "bencode match" $ decodeBencode testData @?= decodeBenc testData+ , testCase "AttoBencode match" $ decodeAttoBencode testData @?= decodeBenc testData+ , testCase "bencoding match" $ decodeBencoding testData @?= decodeBenc testData+ ]+ , env (evaluate (force (decodeBenc testData))) $ \decoded ->+ bgroup "Encode"+ [ bench "benc" $ nf encodeBenc decoded+ , bench "bencode" $ nf encodeBencode decoded+ , bench "AttoBencode" $ nf encodeAttoBencode decoded+ , bench "bencoding" $ nf encodeBencoding decoded+ , testCase "bencode match" $ encodeBencode decoded @?= encodeBenc decoded+ , testCase "AttoBencode match" $ BL.fromStrict (encodeAttoBencode decoded) @?= encodeBenc decoded+ , testCase "bencoding match" $ encodeBencoding decoded @?= encodeBenc decoded+ ]+ ]+ | (testName, testFile) <- testFiles ]++testFiles :: [(String, FilePath)]+testFiles =+ [ ("crossref", "data/April2023PublicDataFilefromCrossref.torrent")+ , ("ubuntu", "data/ubuntu-22.04-desktop-amd64.iso.torrent")+ ]++-- | This represents a metainfo (.torrent) file.+data MetaInfo = MetaInfo+ { _announce :: !T.Text+ , _announceList :: !(Maybe (V.Vector (V.Vector T.Text)))+ , _comment :: !(Maybe T.Text)+ , _createdBy :: !(Maybe T.Text)+ , _creationDate :: !(Maybe Int)+ , _info :: !Info+ } deriving (Eq, Show, Generic, NFData)++data Info = Info+ { _singleOrMultiple :: !SingleOrMultiple+ , _name :: !T.Text+ , _pieceLength :: !Int+ , _pieces :: !B.ByteString+ } deriving (Eq, Show, Generic, NFData)++data SingleOrMultiple+ = Single { _length :: !Int }+ | Multiple { _files :: !(V.Vector OneFileInfo) }+ deriving (Eq, Show, Generic, NFData)++data OneFileInfo = OneFileInfo+ { __length :: !Int+ , _path :: !(V.Vector T.Text)+ } deriving (Eq, Show, Generic, NFData)++------------------------------+-- benc+------------------------------++decodeBenc :: B.ByteString -> MetaInfo+decodeBenc = either error id . D.decode metaInfoP++metaInfoP :: D.Parser MetaInfo+metaInfoP =+ MetaInfo+ <$> D.field "announce" D.text+ <*> optional (D.field "announce-list" (D.list (D.list D.text)))+ <*> optional (D.field "comment" D.text)+ <*> optional (D.field "created by" D.text)+ <*> optional (D.field "creation date" D.int)+ <*> D.field "info" infoP++infoP :: D.Parser Info+infoP =+ Info+ <$> ( Single <$> D.field "length" D.int+ <|> Multiple <$> D.field "files" (D.list oneFileP))+ <*> D.field "name" D.text+ <*> D.field "piece length" D.int+ <*> D.field "pieces" D.string++oneFileP :: D.Parser OneFileInfo+oneFileP =+ OneFileInfo+ <$> D.field "length" D.int+ <*> D.field "path" (D.list D.text)++encodeBenc :: MetaInfo -> BL.ByteString+encodeBenc = BB.toLazyByteString . E.toBuilder . metaInfoE++metaInfoE :: MetaInfo -> E.Encoding+metaInfoE m = E.dict' $+ E.field "announce" E.text (_announce m)+ <> foldMap (E.field "announce-list" (E.list (E.list E.text)))+ (_announceList m)+ <> foldMap (E.field "comment" E.text) (_comment m)+ <> foldMap (E.field "created by" E.text) (_createdBy m)+ <> foldMap (E.field "creation date" E.int) (_creationDate m)+ <> E.field "info" infoE (_info m)++infoE :: Info -> E.Encoding+infoE i = E.dict' $+ (case _singleOrMultiple i of+ Single l -> E.field "length" E.int l+ Multiple fs -> E.field "files" (E.list oneFileE) fs)+ <> E.field "name" E.text (_name i)+ <> E.field "piece length" E.int (_pieceLength i)+ <> E.field "pieces" E.string (_pieces i)++oneFileE :: OneFileInfo -> E.Encoding+oneFileE o = E.dict' $+ E.field "length" E.int (__length o)+ <> E.field "path" (E.list E.text) (_path o)++------------------------------+-- bencode+------------------------------++decodeBencode :: B.ByteString -> MetaInfo+decodeBencode =+ either error id .+ Ben.runBReader metaInfoR .+ maybe (error "fail") id .+ Ben.bRead .+ BL.fromStrict++metaInfoR :: Ben.BReader MetaInfo+metaInfoR =+ MetaInfo+ <$> Ben.dict "announce" btext+ <*> optional (+ Ben.dict "announce-list" (+ V.fromList <$> Ben.list (V.fromList <$> Ben.list btext)))+ <*> optional (Ben.dict "comment" btext)+ <*> optional (Ben.dict "created by" btext)+ <*> optional (Ben.dict "creation date" bint)+ <*> Ben.dict "info" infoR++infoR :: Ben.BReader Info+infoR =+ Info+ <$> ( Single <$> Ben.dict "length" bint+ <|> Multiple <$> Ben.dict "files" (V.fromList <$> Ben.list oneFileR))+ <*> Ben.dict "name" btext+ <*> Ben.dict "piece length" bint+ <*> Ben.dict "pieces" (BL.toStrict <$> Ben.bbytestring)++oneFileR :: Ben.BReader OneFileInfo+oneFileR =+ OneFileInfo+ <$> Ben.dict "length" bint+ <*> Ben.dict "path" (V.fromList <$> Ben.list btext)++bint :: Ben.BReader Int+bint = fromIntegral <$> Ben.bint++btext :: Ben.BReader T.Text+btext = T.decodeUtf8 . BL.toStrict <$> Ben.bbytestring++encodeBencode :: MetaInfo -> BL.ByteString+encodeBencode = Ben.bPack . metaInfoW++metaInfoW :: MetaInfo -> Ben.BEncode+metaInfoW m = Ben.BDict $ M.fromList $+ [ ("announce", Ben.BString $ unbtext (_announce m)) ]+ ++ optW "announce-list"+ (Ben.BList . map (Ben.BList . map (Ben.BString . unbtext) . V.toList) . V.toList+ <$> _announceList m)+ ++ optW "comment" (Ben.BString . unbtext <$> _comment m)+ ++ optW "created by" (Ben.BString . unbtext <$> _createdBy m)+ ++ optW "creation date" (Ben.BInt . fromIntegral <$> _creationDate m)+ ++ [ ("info", infoW (_info m)) ]++optW :: String -> Maybe Ben.BEncode -> [(String, Ben.BEncode)]+optW k = maybe [] (\x -> [(k,x)])++infoW :: Info -> Ben.BEncode+infoW i = Ben.BDict $ M.fromList $+ (case _singleOrMultiple i of+ Single l -> [("length", Ben.BInt $ fromIntegral l)]+ Multiple fs -> [("files", Ben.BList $ map oneFileW (V.toList fs))])+ ++ [ ("name" , Ben.BString $ unbtext (_name i))+ , ("piece length", Ben.BInt $ fromIntegral (_pieceLength i))+ , ("pieces" , Ben.BString $ BL.fromStrict (_pieces i))+ ]++oneFileW :: OneFileInfo -> Ben.BEncode+oneFileW o = Ben.BDict $ M.fromList+ [ ("length", Ben.BInt $ fromIntegral (__length o))+ , ("path" , Ben.BList $ map (Ben.BString . unbtext) $ V.toList (_path o))+ ]++unbtext :: T.Text -> BL.ByteString+unbtext = BL.fromStrict . T.encodeUtf8++------------------------------+-- AttoBencode+------------------------------++decodeAttoBencode :: B.ByteString -> MetaInfo+decodeAttoBencode = fromJust . Atto.decode++instance Atto.FromBencode MetaInfo where+ fromBencode (Atto.BDict d) =+ MetaInfo <$> (T.decodeUtf8 <$> d Atto..: "announce")+ <*> Just (+ V.fromList . map (V.fromList . map T.decodeUtf8)+ <$> d Atto..: "announce-list")+ <*> Just (T.decodeUtf8 <$> d Atto..: "comment")+ <*> Just (T.decodeUtf8 <$> d Atto..: "created by")+ <*> Just (d Atto..: "creation date")+ <*> d Atto..: "info"+ fromBencode _ = Nothing++instance Atto.FromBencode Info where+ fromBencode (Atto.BDict d) =+ Info <$> ( Single <$> d Atto..: "length"+ <|> Multiple . V.fromList <$> d Atto..: "files")+ <*> (T.decodeUtf8 <$> d Atto..: "name")+ <*> d Atto..: "piece length"+ <*> d Atto..: "pieces"+ fromBencode _ = Nothing++instance Atto.FromBencode OneFileInfo where+ fromBencode (Atto.BDict d) =+ OneFileInfo+ <$> d Atto..: "length"+ <*> (V.fromList . map T.decodeUtf8 <$> d Atto..: "path")+ fromBencode _ = Nothing++encodeAttoBencode :: MetaInfo -> B.ByteString+encodeAttoBencode = Atto.encode++instance Atto.ToBencode MetaInfo where+ toBencode m = Atto.dict $+ [ "announce" Atto..= T.encodeUtf8 (_announce m) ]+ ++ opt "announce-list"+ (map (map T.encodeUtf8 . V.toList) . V.toList <$> _announceList m)+ ++ opt "comment" (T.encodeUtf8 <$> _comment m)+ ++ opt "created by" (T.encodeUtf8 <$> _createdBy m)+ ++ opt "creation date" (_creationDate m)+ ++ [ "info" Atto..= _info m ]++-- Why is this not already in the library+opt :: Atto.ToBencode a => B.ByteString -> Maybe a -> [(B.ByteString, Atto.BValue)]+opt k = maybe [] (\x -> [k Atto..= x])++instance Atto.ToBencode Info where+ toBencode i = Atto.dict $+ (case _singleOrMultiple i of+ Single l -> ["length" Atto..= l]+ Multiple fs -> ["files" Atto..= V.toList fs])+ ++ [ "name" Atto..= T.encodeUtf8 (_name i)+ , "piece length" Atto..= _pieceLength i+ , "pieces" Atto..= _pieces i+ ]++instance Atto.ToBencode OneFileInfo where+ toBencode o = Atto.dict+ [ "length" Atto..= __length o+ , "path" Atto..= map T.encodeUtf8 (V.toList (_path o))+ ]++------------------------------+-- bencoding+------------------------------++decodeBencoding :: B.ByteString -> MetaInfo+decodeBencoding = either error id . Ing.decode++encodeBencoding :: MetaInfo -> BL.ByteString+encodeBencoding = Ing.encode++-- You may have noticed that the keys in the records are sorted.+-- This is not because I find it neat, but because bencoding forces you to+-- hand-sort the order of keys when encoding and decoding! Yikes!++instance Ing.BEncode MetaInfo where+ toBEncode m = Ing.toDict $+ "announce" Ing..=! _announce m+ Ing..: "announce-list" Ing..=? (map V.toList . V.toList <$> _announceList m)+ Ing..: "comment" Ing..=? _comment m+ Ing..: "created by" Ing..=? _createdBy m+ Ing..: "creation date" Ing..=? _creationDate m+ Ing..: "info" Ing..=! _info m+ Ing..: Ing.endDict+ fromBEncode = Ing.fromDict $+ MetaInfo Ing.<$>! "announce"+ <*> optional+ (V.fromList . map V.fromList+ <$> Ing.field (Ing.req "announce-list"))+ Ing.<*>? "comment"+ Ing.<*>? "created by"+ Ing.<*>? "creation date"+ Ing.<*>! "info"++instance Ing.BEncode Info where+ toBEncode i = Ing.toDict $+ (case _singleOrMultiple i of+ Single l -> "length" Ing..=! l+ Multiple fs -> "files" Ing..=! V.toList fs)+ Ing..: "name" Ing..=! _name i+ Ing..: "piece length" Ing..=! _pieceLength i+ Ing..: "pieces" Ing..=! _pieces i+ Ing..: Ing.endDict+ fromBEncode = Ing.fromDict $+ Info <$> ( Single Ing.<$>! "length"+ <|> Multiple . V.fromList Ing.<$>! "files")+ Ing.<*>! "name"+ Ing.<*>! "piece length"+ Ing.<*>! "pieces"++instance Ing.BEncode OneFileInfo where+ toBEncode o = Ing.toDict $+ "length" Ing..=! __length o+ Ing..: "path" Ing..=! V.toList (_path o)+ Ing..: Ing.endDict+ fromBEncode = Ing.fromDict $+ OneFileInfo Ing.<$>! "length"+ <*> (V.fromList <$> Ing.field (Ing.req "path"))++------------------------------+-- Results+------------------------------+{-+$ cabal run benc-compare -- +RTS -T+All+ crossref+ Decode+ benc: OK+ 27.6 ms ± 2.1 ms, 45 MB allocated, 34 MB copied, 38 MB peak memory+ bencode: OK+ 218 ms ± 11 ms, 737 MB allocated, 66 MB copied, 47 MB peak memory+ AttoBencode: OK+ 44.8 ms ± 3.8 ms, 129 MB allocated, 41 MB copied, 47 MB peak memory+ bencoding: OK+ 39.7 ms ± 3.7 ms, 103 MB allocated, 40 MB copied, 47 MB peak memory+ bencode match: OK+ AttoBencode match: OK+ bencoding match: OK+ Encode+ benc: OK+ 11.8 ms ± 1.0 ms, 53 MB allocated, 477 KB copied, 62 MB peak memory+ bencode: OK+ 42.4 ms ± 3.1 ms, 113 MB allocated, 41 MB copied, 91 MB peak memory+ AttoBencode: OK+ 20.2 ms ± 1.1 ms, 109 MB allocated, 1.6 MB copied, 91 MB peak memory+ bencoding: OK+ 11.6 ms ± 1.1 ms, 67 MB allocated, 484 KB copied, 91 MB peak memory+ bencode match: OK+ AttoBencode match: OK+ bencoding match: OK+ ubuntu+ Decode+ benc: OK+ 1.46 μs ± 93 ns, 6.7 KB allocated, 3 B copied, 91 MB peak memory+ bencode: OK+ 28.4 μs ± 1.5 μs, 121 KB allocated, 77 B copied, 91 MB peak memory+ AttoBencode: OK+ 2.97 μs ± 171 ns, 17 KB allocated, 4 B copied, 91 MB peak memory+ bencoding: OK+ 2.38 μs ± 181 ns, 15 KB allocated, 4 B copied, 91 MB peak memory+ bencode match: OK+ AttoBencode match: OK+ bencoding match: OK+ Encode+ benc: OK+ 1.91 μs ± 179 ns, 12 KB allocated, 2 B copied, 91 MB peak memory+ bencode: OK+ 3.19 μs ± 173 ns, 19 KB allocated, 13 B copied, 91 MB peak memory+ AttoBencode: OK+ 10.2 μs ± 387 ns, 295 KB allocated, 26 B copied, 91 MB peak memory+ bencoding: OK+ 1.79 μs ± 100 ns, 15 KB allocated, 2 B copied, 91 MB peak memory+ bencode match: OK+ AttoBencode match: OK+ bencoding match: OK+-}
+ src/Data/Bencode/AST.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Data.Bencode.AST+ ( Value(..)+ , KeyValue(..)+ , parseOnly+ ) where++import Data.Char (isDigit)+import Data.List (intercalate)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.Primitive.Array as A++import Data.Bencode.Util (readKnownNaturalAsInt)++-- | The Bencode AST.+data Value+ = String {-# UNPACK #-} !B.ByteString+ -- ^ Slice of the input @ByteString@.+ | Integer {-# UNPACK #-} !B.ByteString+ -- ^ Slice of the input @ByteString@, containing a valid integer. Parsing+ -- into an integral type is done later if required.+ | List {-# UNPACK #-} !(A.Array Value)+ | Dict {-# UNPACK #-} !(A.Array KeyValue)+ deriving (Eq, Show)++-- | A Bencode dict's key-value pair.+data KeyValue = KeyValue+ {-# UNPACK #-} !B.ByteString-- ^ Slice of the input @ByteString@.+ !Value+ deriving (Eq, Show)++newtype Pos = Pos { unPos :: Int } deriving (Show, Num)++-- | Either an error or the parsed value together with the unparsed+-- section of the input and number of bytes parsed.+type ParseOneResult = Either String (Value, B.ByteString, Int)++data Stack+ = SNil+ | SList {-# UNPACK #-} !Int ![Value] !Stack+ | SDict {-# UNPACK #-} !B.ByteString {-# UNPACK #-} !Int ![KeyValue] !Stack++-- | Parse one Bencode value from the given bytestring. Fails if the string is+-- not fully consumed.+parseOnly :: B.ByteString -> Either String Value+parseOnly s = case parseOne s of+ Left e -> Left e+ Right (v, s', n) ->+ if B.null s'+ then Right v+ else errorAtPos "ExpectedEOF" (Pos n)++-- | Parse one Bencode value from the given bytestring.+parseOne :: B.ByteString -> ParseOneResult+parseOne s = case BC.uncons s of+ Nothing -> errItem Nothing pos+ Just (c,s1) -> case c of+ _ | isDigit c -> do+ (str, s2, pos2) <- parseString s pos+ Right (String str, s2, unPos pos2)+ 'i' -> do+ (i, s2, pos2) <- parseInteger s1 (pos+1)+ Right (Integer i, s2, unPos pos2)+ 'l' -> parseList SNil 0 [] s1 (pos+1)+ 'd' -> parseDict SNil s1 (pos+1)+ _ -> errItem (Just c) pos+ where+ pos = Pos 0++-- | Parse a Bencode list. After the \'l\' marker.+parseList :: Stack -> Int -> [Value] -> B.ByteString -> Pos -> ParseOneResult+parseList stk !n !acc s !pos = case BC.uncons s of+ Nothing -> errItemOrEnd Nothing pos+ Just (c,s1) -> case c of+ _ | isDigit c -> do+ (str, s2, pos2) <- parseString s pos+ parseList stk (n+1) (String str : acc) s2 pos2+ 'i' -> do+ (i, s2, pos2) <- parseInteger s1 (pos+1)+ parseList stk (n+1) (Integer i : acc) s2 pos2+ 'l' -> parseList (SList n acc stk) 0 [] s1 (pos+1)+ 'd' -> parseDict (SList n acc stk) s1 (pos+1)+ 'e' -> resumeParse stk (List (arrayFromRevListN n acc)) s1 (pos+1)+ _ -> errItemOrEnd (Just c) pos++-- | Parse a Bencode dict. After the \'d\' marker.+parseDict :: Stack -> B.ByteString -> Pos -> ParseOneResult+parseDict stk s !pos = case BC.uncons s of+ Nothing -> errStringOrEnd Nothing pos+ Just (c1,s1) -> case c1 of+ _ | isDigit c1 -> do+ (key, s2, pos2) <- parseString s pos+ case BC.uncons s2 of+ Nothing -> errItem Nothing pos2+ Just (c3,s3) -> case c3 of+ _ | isDigit c3 -> do+ (str, s4, pos4) <- parseString s2 pos2+ parseDict1 key stk 1 [KeyValue key (String str)] s4 pos4+ 'i' -> do+ (i, s4, pos4) <- parseInteger s3 (pos2+1)+ parseDict1 key stk 1 [KeyValue key (Integer i)] s4 pos4+ 'l' -> parseList (SDict key 0 [] stk) 0 [] s3 (pos2+1)+ 'd' -> parseDict (SDict key 0 [] stk) s3 (pos2+1)+ _ -> errItem (Just c3) pos2+ 'e' -> resumeParse stk (Dict (arrayFromRevListN 0 [])) s1 (pos+1)+ _ -> errStringOrEnd (Just c1) pos++-- | Parse a Bencode dict. After the first key-value pair.+parseDict1 :: B.ByteString -> Stack -> Int -> [KeyValue] -> B.ByteString -> Pos+ -> ParseOneResult+parseDict1 !pkey stk !n !acc s !pos = case BC.uncons s of+ Nothing -> errStringOrEnd Nothing pos+ Just (c1,s1) -> case c1 of+ _ | isDigit c1 -> do+ (key, s2, pos2) <- parseString s pos+ if pkey >= key+ then errUnsortedKeys pkey key pos+ else case BC.uncons s2 of+ Nothing -> errItem Nothing pos2+ Just (c3,s3) -> case c3 of+ _ | isDigit c3 -> do+ (str, s4, pos4) <- parseString s2 pos2+ parseDict1 key stk (n+1) (KeyValue key (String str) : acc) s4 pos4+ 'i' -> do+ (i, s4, pos4) <- parseInteger s3 (pos2+1)+ parseDict1 key stk (n+1) (KeyValue key (Integer i) : acc) s4 pos4+ 'l' -> parseList (SDict key n acc stk) 0 [] s3 (pos2+1)+ 'd' -> parseDict (SDict key n acc stk) s3 (pos2+1)+ _ -> errItem (Just c3) pos2+ 'e' -> resumeParse stk (Dict (arrayFromRevListN n acc)) s1 (pos+1)+ _ -> errStringOrEnd (Just c1) pos++-- | Add the value to the previously incomplete value on the stack, and resume+-- parsing it.+resumeParse :: Stack -> Value -> B.ByteString -> Pos -> ParseOneResult+resumeParse stk !x s !pos = case stk of+ SNil -> Right (x, s, unPos pos)+ SList n xs stk1 -> parseList stk1 (n+1) (x:xs) s pos+ SDict k n acc stk1 -> parseDict1 k stk1 (n+1) (KeyValue k x : acc) s pos+{-# INLINE resumeParse #-}++-- | Parse a Bencode integer. After the \'i\' to the \'e\'.+parseInteger :: B.ByteString -> Pos+ -> Either String (B.ByteString, B.ByteString, Pos)+parseInteger s !pos = case BC.uncons s of+ Nothing -> errDigit Nothing pos+ Just (c1,s1) -> case c1 of+ '0' -> end (B.take 1 s) s1 (pos+1)+ '-' -> case BC.span isDigit s1 of+ (x,s2) -> case BC.uncons x of+ Just (c3,_) | c3 /= '0' ->+ let n = B.length x + 1 in end (B.take n s) s2 (pos + Pos n)+ _ -> errNZDigit (fmap fst (BC.uncons s2)) (pos+1)+ _ -> case BC.span isDigit s of+ (x,s2) -> if B.null x+ then errDigitOrNeg (Just c1) pos+ else let n = B.length x in end x s2 (pos + Pos n)+ where+ end x s' !pos' = case BC.uncons s' of+ Nothing -> errEnd Nothing pos'+ Just (c,s'') -> case c of+ 'e' -> Right (x, s'', pos'+1)+ _ -> errEnd (Just c) pos'+{-# INLINE parseInteger #-}++-- | Parse a Bencode string. From the length count to the end of the string.+parseString :: B.ByteString -> Pos+ -> Either String (B.ByteString, B.ByteString, Pos)+parseString s !pos = case BC.span isDigit s of+ (digs,s1) -> case readKnownNaturalAsInt False (BC.dropWhile (=='0') digs) of+ Nothing -> errTooLargeStringLength pos+ Just n ->+ let pos2 = pos + Pos (B.length digs)+ in case BC.uncons s1 of+ Nothing -> errColon Nothing pos2+ Just (c3,s3) -> case c3 of+ ':' -> case B.splitAt n s3 of+ (str,s4) | B.length str == n -> Right (str, s4, pos2 + 1 + Pos n)+ _ -> errTooLargeStringLength pos+ _ -> errColon (Just c3) pos2+{-# INLINE parseString #-}++------------------------------+-- Error stuff++errorAtPos :: String -> Pos -> Either String a+errorAtPos e (Pos n) = Left $ "ParseErrorAt " ++ show n ++ ": " ++ e++mismatch :: [String] -> Maybe Char -> Pos -> Either String a+mismatch cs c = errorAtPos $+ "ExpectedOneOfButGot [" ++ intercalate "," cs ++ "] " ++ maybe "EOF" show c++errItem, errItemOrEnd, errStringOrEnd, errEnd, errDigit, errNZDigit,+ errColon, errDigitOrNeg :: Maybe Char -> Pos -> Either String a+errItem = mismatch ["Digit", show 'i', show 'l', show 'd']+errItemOrEnd = mismatch ["Digit", show 'i', show 'l', show 'd', show 'e']+errStringOrEnd = mismatch ["Digit", show 'e']+errEnd = mismatch [show 'e']+errDigit = mismatch ["Digit"]+errNZDigit = mismatch ["NonZeroDigit"]+errDigitOrNeg = mismatch ["Digit", show '-']+errColon = mismatch [show ':']++errUnsortedKeys :: B.ByteString -> B.ByteString -> Pos -> Either String a+errUnsortedKeys pkey key = errorAtPos $+ "UnsortedKeys " ++ show pkey ++ " " ++ show key++errTooLargeStringLength :: Pos -> Either String a+errTooLargeStringLength = errorAtPos "TooLargeStringLength"++------------------------------+-- Array++-- | Create an array from a list in reverse order.+arrayFromRevListN :: Int -> [a] -> A.Array a+arrayFromRevListN n xs = A.createArray n errorElement $ \a ->+ let f x k = \i ->+ if i == -1+ then pure ()+ else A.writeArray a i x *> k (i-1)+ in foldr f (\ !_ -> pure ()) xs (n-1)+{-# INLINE arrayFromRevListN #-}++errorElement :: a+errorElement = error "errorElement"
+ src/Data/Bencode/Decode.hs view
@@ -0,0 +1,403 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- Conversions from Bencoded @ByteString@s to Haskell values.+--+-- == Introduction+--+-- Decoding is done using parsers. There are parsers for the four Bencode types:+--+-- * 'string' decodes Bencode strings as 'B.ByteString's+-- * 'integer' decodes Bencode integers as 'Prelude.Integer's+-- * 'list' decodes Bencode lists as 'V.Vector's+-- * 'dict' decodes Bencode dictionaries as 'M.Map's with 'B.ByteString' keys.+--+-- These can be used to build more complex parsers for arbitrary types.+--+-- @+-- data File = File+-- { hash :: ByteString+-- , size :: Integer+-- , tags :: Vector Text+-- } deriving Show+-- @+--+-- Assuming a @File@ is encoded as a Bencode dictionary with the field names as+-- keys and appropriate value types, a parser for @File@ can be defined as+--+-- @+-- {-# LANGUAGE OverloadedStrings #-}+-- import qualified Data.Bencode.Decode as D+--+-- fileParser :: D.'Parser' File+-- fileParser =+-- File \<\$> D.'field' "hash" D.'string'+-- \<*> D.'field' "size" D.'integer'+-- \<*> D.'field' "tags" (D.'list' D.'text')+-- @+--+-- The parser can then be run on a @ByteString@ with 'decode'.+--+-- >>> D.decode fileParser "d4:hash4:xxxx4:sizei1024e4:tagsl4:work6:backupee"+-- Right (File {hash = "xxxx", size = 1024, tags = ["work","backup"]})+--+-- Of course, invalid Bencode or Bencode that does not satisfy our @File@ parser+-- will fail to decode.+--+-- >>> D.decode fileParser "d4:hash4:xxxx4:tagsl4:work6:backupee"+-- Left "KeyNotFound \"size\""+--+-- For more examples, see the \"Recipes\" section at the end of this page.+--+module Data.Bencode.Decode+ ( -- * Parser+ Parser+ , decode+ , decodeMaybe++ -- * Primary parsers+ , string+ , integer+ , list+ , dict++ -- * More parsers+ , stringEq+ , text+ , textEq+ , int+ , intEq+ , word+ , field+ , value+ , fail++ -- * Recipes+ --+ -- $recipes+ ) where++import Prelude hiding (fail)+import Control.Applicative+import Control.Monad hiding (fail)+import Control.Monad.ST+import Control.Monad.Trans.Reader+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.Foldable as F+import qualified Data.Map as M+import qualified Data.Primitive.Array as A+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as VM++import Data.Bencode.Type (Value(..))+import Data.Bencode.Util (readKnownNaturalAsInt, readKnownNaturalAsWord)+import qualified Data.Bencode.AST as AST++newtype ParseResult a = ParseResult { unParseResult :: Either String a }+ deriving (Functor, Applicative, Monad)++failResult :: String -> ParseResult a+failResult = ParseResult . Left+{-# INLINE failResult #-}++instance Alternative ParseResult where+ empty = failResult "Alternative.empty"+ l <|> r = ParseResult $ unParseResult l <> unParseResult r+ -- Discards left error, not ideal++-- | A parser from a Bencode value to a Haskell value.+newtype Parser a = Parser { runParser :: AST.Value -> ParseResult a }+ deriving (Functor, Applicative, Alternative, Monad)+ via ReaderT AST.Value ParseResult++lift :: ParseResult a -> Parser a+lift = Parser . const+{-# INLINE lift #-}++failParser :: String -> Parser a+failParser = lift . failResult+{-# INLINE failParser #-}++-- | Decode a value from the given @ByteString@. If decoding fails, returns+-- @Left@ with a failure message.+decode :: Parser a -> B.ByteString -> Either String a+decode p s = AST.parseOnly s >>= unParseResult . runParser p++-- | Decode a value from the given @ByteString@. If decoding fails, returns+-- @Nothing@.+decodeMaybe :: Parser a -> B.ByteString -> Maybe a+decodeMaybe p = either (const Nothing) Just . decode p++errTypeMismatch :: String -> AST.Value -> ParseResult a+errTypeMismatch a b = failResult $ "TypeMismatch " ++ a ++ " " ++ b'+ where+ b' = case b of+ AST.String _ -> "String"+ AST.Integer _ -> "Integer"+ AST.List _ -> "List"+ AST.Dict _ -> "Dict"++-- Parsers below are all marked INLINE because they match on the AST+-- constructor and return Eithers. When inlined, GHC is able to optimize the+-- nested case matches using "case merging" and get rid of the intemeditate+-- Eithers using "case-of-case".++stringDirect :: Parser B.ByteString+stringDirect = Parser $ \v -> case v of+ AST.String s -> pure s+ _ -> errTypeMismatch "String" v+{-# INLINE stringDirect #-}++integerDirect :: Parser B.ByteString+integerDirect = Parser $ \v -> case v of+ AST.Integer s -> pure s+ _ -> errTypeMismatch "Integer" v+{-# INLINE integerDirect #-}++listDirect :: Parser (A.Array AST.Value)+listDirect = Parser $ \v -> case v of+ AST.List a -> pure a+ _ -> errTypeMismatch "List" v+{-# INLINE listDirect #-}++dictDirect :: Parser (A.Array AST.KeyValue)+dictDirect = Parser $ \v -> case v of+ AST.Dict a -> pure a+ _ -> errTypeMismatch "Dict" v+{-# INLINE dictDirect #-}++-- | Decode a Bencode string as a ByteString. Fails on a non-string.+string :: Parser B.ByteString+string = stringDirect+{-# INLINE string #-}++-- | Decode a Bencode integer as an Integer. Fails on a non-integer.+integer :: Parser Integer+integer = toI <$!> integerDirect+ where+ -- BC.readInteger will be making redundant digit checks since we already+ -- know it to be a valid integer.+ -- But it has an efficient divide-and-conquer algorithm compared to the+ -- simple but O(n^2) foldl' (\acc x -> acc * 10 + x) 0.+ -- We can reimplement the algorithm without the redundant checks if we+ -- really want.+ toI s = case BC.readInteger s of+ Nothing -> error "Data.Bencode.Decode.integer: should not happen"+ Just (i,_) -> i+{-# INLINE integer #-}++-- | Decode a Bencode list with the given parser for elements. Fails on a+-- non-list or if any element in the list fails to parse.+list :: Parser a -> Parser (V.Vector a)+list p = listDirect >>= lift . traverseAToV (runParser p)+{-# INLINE list #-}++traverseAToV :: (a -> ParseResult b) -> A.Array a -> ParseResult (V.Vector b)+traverseAToV f a = runST $ do+ let n = A.sizeofArray a+ v <- VM.new n+ let loop i | i == n = pure Nothing+ loop i = case f (A.indexArray a i) of+ ParseResult (Left e) -> pure (Just e)+ ParseResult (Right x) -> VM.write v i x *> loop (i+1)+ res <- loop 0+ maybe (pure <$> V.unsafeFreeze v) (pure . failResult) res+{-# INLINABLE traverseAToV #-}++-- | Decode a Bencode dict with the given parser for values. Fails on a+-- non-dict or if any value in the dict fails to parse.+dict :: Parser a -> Parser (M.Map B.ByteString a)+dict p =+ dictDirect >>= lift . fmap M.fromDistinctAscList . traverse f . F.toList+ where+ f (AST.KeyValue k v) = (,) k <$> runParser p v+{-# INLINE dict #-}++-- | Succeeds only on a Bencode string that equals the given string.+stringEq :: B.ByteString -> Parser ()+stringEq s = stringDirect >>= \s' ->+ if s == s'+ then pure ()+ else failParser $ "StringNotEq " ++ show s ++ " " ++ show s'+{-# INLINE stringEq #-}++-- | Decode a bencode string as UTF-8 text. Fails on a non-string or if the+-- string is not valid UTF-8.+text :: Parser T.Text+text =+ stringDirect >>=+ either (const (failParser "UTF8DecodeFailure")) pure . T.decodeUtf8'+{-# INLINE text #-}++-- | Succeeds only on a Bencode string that equals the given text.+textEq :: T.Text -> Parser ()+textEq t = text >>= \t' ->+ if t == t'+ then pure ()+ else failParser $ "TextNotEq " ++ show t ++ " " ++ show t'+{-# INLINE textEq #-}++-- | Decode a Bencode integer as an @Int@. Fails on a non-integer or if the+-- integer is out of bounds for an @Int@.+int :: Parser Int+int = integerDirect >>= maybe (failParser "IntOutOfBounds") pure . go+ where+ go s = case BC.uncons s of+ Just ('-', s') -> readKnownNaturalAsInt True s'+ _ -> readKnownNaturalAsInt False s+{-# INLINE int #-}++-- | Succeeds only on a Bencode integer that equals the given value.+intEq :: Int -> Parser ()+intEq i = int >>= \i' ->+ if i == i'+ then pure ()+ else failParser $ "IntNotEq " ++ show i ++ " " ++ show i'+{-# INLINE intEq #-}++-- | Decode a Bencode integer as a @Word@. Fails on a non-integer or if the+-- integer is out of bounds for a @Word@.+word :: Parser Word+word = integerDirect >>= maybe (failParser "WordOutOfBounds") pure . go+ where+ go s = case BC.uncons s of+ Just ('-',_) -> Nothing+ _ -> readKnownNaturalAsWord s+{-# INLINE word #-}++-- | Decode a @Value@. Always succeeds for valid Bencode.+value :: Parser Value+value = String <$> string+ <|> Integer <$> integer+ <|> List <$> list value+ <|> Dict <$> dict value++-- | Always fails with the given message.+fail :: String -> Parser a+fail = failParser . ("Fail: " ++ )+{-# INLINE fail #-}++-- | Decode a value with the given parser for the given key. Fails on a+-- non-dict, if the key is absent, or if the value parser fails.+field :: B.ByteString -> Parser a -> Parser a+field k p =+ dictDirect >>=+ maybe (failParser $ "KeyNotFound " ++ show k) pure . binarySearch k >>=+ lift . runParser p+{-# INLINE field #-}++----------+-- Utils++-- | Binary search. The array must be sorted by key.+binarySearch :: B.ByteString -> A.Array AST.KeyValue -> Maybe AST.Value+binarySearch k a = go 0 (A.sizeofArray a)+ where+ go l r | l == r = Nothing+ go l r = case compare k k' of+ LT -> go l m+ EQ -> Just v+ GT -> go (m+1) r+ where+ -- Overflow, careful!+ m = fromIntegral ((fromIntegral (l+r) :: Word) `div` 2) :: Int+ AST.KeyValue k' v = A.indexArray a m+{-# INLINABLE binarySearch #-}++-- $recipes+-- Recipes for some common and uncommon usages.+--+-- The following preface is assumed.+--+-- @+-- {-# LANGUAGE OverloadedStrings #-}+-- import Data.ByteString (ByteString)+-- import Data.Text (Text)+-- import qualified Data.Bencode.Decode as D+-- @+--+-- === Decode an optional field+--+-- @+-- import Control.Applicative ('optional')+--+-- data File = File { name :: Text, size :: Maybe Int } deriving Show+--+-- fileParser :: D.'Parser' File+-- fileParser =+-- File+-- \<$> D.'field' "name" D.'text'+-- \<*> optional (D.'field' "size" D.'int')+-- @+--+-- >>> D.decode fileParser "d4:name9:hello.txt4:sizei16ee"+-- Right (File {name = "hello.txt", size = Just 16})+-- >>> D.decode fileParser "d4:name9:hello.txte"+-- Right (File {name = "hello.txt", size = Nothing})+--+-- === Decode an enum+--+-- @+-- import Control.Applicative ('(<|>)')+--+-- data Color = Red | Green | Blue deriving Show+--+-- colorParser :: D.'Parser' Color+-- colorParser =+-- Red \<$ D.'stringEq' "red"+-- \<|> Green \<$ D.'stringEq' "green"+-- \<|> Blue \<$ D.'stringEq' "blue"+-- \<|> D.'fail' "unknown color"+-- @+--+-- >>> D.decode colorParser "5:green"+-- Right Green+-- >>> D.decode colorParser "5:black"+-- Left "Fail: unknown color"+--+-- === Decode differently based on dict contents+--+-- @+-- import Control.Applicative ('(<|>)')+--+-- data Response = Response+-- { id_ :: Int+-- , result :: Either Text ByteString+-- } deriving Show+--+-- responseParser :: D.'Parser' Response+-- responseParser = do+-- id_ <- D.'field' "id" D.'int'+-- success <- D.'field' "status" $+-- False \<$ D.'stringEq' "failure"+-- \<|> True \<$ D.'stringEq' "success"+-- \<|> D.'fail' "unknown status"+-- Response id_+-- \<$> if success+-- then Right \<$> D.'field' "data" D.'string'+-- else Left \<$> D.'field' "reason" D.'text'+-- @+--+-- >>> D.decode responseParser "d2:idi42e6:reason12:unauthorized6:status7:failuree"+-- Right (Response {id_ = 42, result = Left "unauthorized"})+-- >>> D.decode responseParser "d4:data4:00002:idi42e6:status7:successe"+-- Right (Response {id_ = 42, result = Right "0000"})+--+-- === Decode nested dicts+--+-- @+-- data File = File { name :: Text, size :: Int } deriving Show+--+-- fileParser :: D.'Parser' File+-- fileParser =+-- File+-- \<$> D.'field' "name" D.'text'+-- \<*> D.'field' "metadata" (D.'field' "info" (D.'field' "size" D.'int'))+-- @+--+-- >>> D.decode fileParser "d8:metadatad4:infod4:sizei32eee4:name9:hello.txte"+-- Right (File {name = "hello.txt", size = 32})+--
+ src/Data/Bencode/Encode.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- Conversions from Haskell values to Bencoded @ByteString@s.+--+-- == Introduction+--+-- Encoding is done using encoders. An encoder is simply a function from a+-- Haskell type to 'Encoding'. There are encoders for the four Bencode types:+--+-- * 'string' encodes 'B.ByteString's as Bencode strings+-- * 'integer' encodes 'Prelude.Integer's as Bencode integers+-- * 'list' encodes 'V.Vector's as Bencode lists+-- * 'dict' encodes 'M.Map's with 'B.ByteString' keys as Bencode dictionaries+--+-- These can used to build more complex encoders for arbitrary types.+--+-- @+-- data File = File+-- { hash :: ByteString+-- , size :: Integer+-- , tags :: Vector Text+-- } deriving Show+-- @+--+-- It is reasonable to encode a @File@ as a Bencode dictionary with the field+-- names as keys, and appropriate types for the values.+--+-- @+-- {-# LANGUAGE OverloadedStrings #-}+-- import qualified Data.Bencode.Encode as E+--+-- encodeFile :: File -> E.'Encoding'+-- encodeFile (File hash size tags) = E.'dict'' $+-- E.'field' "hash" E.'string' hash+-- <> E.'field' "size" E.'integer' size+-- <> E.'field' "tags" (E.'list' E.'text') tags+-- @+--+-- Applying 'toBuilder' to an 'Encoding' gives a @ByteString@+-- 'Data.ByteString.Builder', which can then be converted to a lazy+-- @ByteString@, written to a file, or used otherwise.+--+-- @+-- import qualified Data.ByteString.Builder (toLazyByteString)+-- import qualified Data.Vector as V+-- @+--+-- >>> toLazyByteString $ encodeFile $ File "xxxx" 1024 (V.fromList ["work", "backup"])+-- "d4:hash4:xxxx4:sizei1024e4:tagsl4:work6:backupee"+--+-- In this module, encodings are total conversions from Haskell values to+-- @ByteString@s. If some data should fail to encode, it should be handled+-- separately.+--+-- For more examples, see the \"Recipes\" section at the end of this page.++module Data.Bencode.Encode+ (+ -- * Encoding+ Encoding+ , toBuilder++ -- * Primary encoders+ , string+ , integer+ , list+ , dict++ -- * More encoders+ , text+ , int+ , word+ , field+ , dict'+ , FieldEncodings+ , value++ -- * Recipes+ --+ -- $recipes+ ) where++import Data.Monoid (Endo(..))+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V++import Data.Bencode.Type (Value(..))++-- | An encoded Bencode value.+newtype Encoding = Encoding { unEncoding :: BB.Builder }++-- | Get a ByteString 'BB.Builder' representation for an encoded Bencode value.+toBuilder :: Encoding -> BB.Builder+toBuilder = unEncoding++-- | Encode a bytestring as a Bencode string.+string :: B.ByteString -> Encoding+string s = Encoding $ BB.intDec (B.length s) <> BB.char7 ':' <> BB.byteString s++-- | Encode an integer as a Bencode integer.+integer :: Integer -> Encoding+integer i = Encoding $ BB.char7 'i' <> BB.integerDec i <> BB.char7 'e'++-- | Encode a @Vector@ as a Bencode list, using the given encoder for elements.+list :: (a -> Encoding) -> V.Vector a -> Encoding+list enc vs =+ Encoding $ BB.char7 'l' <> foldMap (unEncoding . enc) vs <> BB.char7 'e'++-- | Encode a @Map@ as a Bencode dictionary, using the given encoder for values.+dict :: (a -> Encoding) -> M.Map B.ByteString a -> Encoding+dict enc kvs = Encoding $ BB.char7 'd' <> f kvs <> BB.char7 'e'+ where+ f = M.foldMapWithKey (\k v -> unEncoding (string k) <> unEncoding (enc v))++-- | Encode @Text@ as a Bencode string. As per the Bencode specification, all+-- text must be encoded as UTF-8 strings.+text :: T.Text -> Encoding+text = string . T.encodeUtf8+-- TODO: Check if Text's encodeUtf8Builder is more efficient. But we would+-- also need to know the UTF-8 len, which is only viable for text >= 2.0.++-- | Encode an @Int@ as a Bencode integer.+int :: Int -> Encoding+int i = Encoding $ BB.char7 'i' <> BB.intDec i <> BB.char7 'e'++-- | Encode a @Word@ as a Bencode integer.+word :: Word -> Encoding+word w = Encoding $ BB.char7 'i' <> BB.wordDec w <> BB.char7 'e'++-- Option 1++-- | A key-value encoding for a Bencode dictionary.+field :: B.ByteString -> (a -> Encoding) -> a -> FieldEncodings+field k enc v = FE (Endo ((k, enc v):))+{-# INLINE field #-}++-- | Encode Bencode key-value pairs as a Bencode dictionary.+--+-- __WARNING__: If there are duplicate keys in the @FieldEncodings@, an+-- arbitrary key-value pair among them will be encoded and the rest discarded.+dict' :: FieldEncodings -> Encoding+dict' = dict id . M.fromList . ($ []) . appEndo . unFE++-- | Key-value encodings for a Bencode dictionary.+newtype FieldEncodings = FE { unFE :: Endo [(B.ByteString, Encoding)] }+ deriving (Semigroup, Monoid)+-- FieldEncodings is not just a type alias because there are multiple ways to+-- do this, and in case the implementation changes it will not be a breaking+-- change.++-- | Encode a @Value@.+value :: Value -> Encoding+value v = case v of+ String s -> string s+ Integer i -> integer i+ List vs -> list value vs+ Dict vs -> dict value vs++-- $recipes+-- Recipies for some common and uncommon usages.+--+-- The following preface is assumed.+--+-- @+-- {-# LANGUAGE OverloadedStrings #-}+-- import Data.ByteString.Builder (toLazyByteString)+-- import Data.Text (Text)+-- import qualified Data.Bencode.Encode as E+--+-- toLBS = toLazyByteString . E.toBuilder+-- @+--+-- === Encode an optional field+--+-- @+-- data File = File { name :: Text, size :: Maybe Int }+--+-- encodeFile :: File -> E.'Encoding'+-- encodeFile (File name size) = E.'dict'' $+-- E.'field' "name" E.'text' name+-- <> 'foldMap' (E.'field' "size" E.'int') size+-- @+--+-- >>> toLBS $ encodeFile $ File "hello.txt" (Just 16)+-- "d4:name9:hello.txt4:sizei16ee"+-- >>> toLBS $ encodeFile $ File "hello.txt" Nothing+-- "d4:name9:hello.txte"+--+-- === Encode an enum+--+-- @+-- data Color = Red | Green | Blue+--+-- encodeColor :: Color -> E.'Encoding'+-- encodeColor = E.'text' . toText+-- where+-- toText Red = "red"+-- toText Green = "green"+-- toText Blue = "blue"+-- @+--+-- >>> toLBS $ encodeColor Green+-- "5:green"+--+-- === Encode fields differently based on the value+--+-- @+-- data Response = Response { id_ :: Int, result :: Either Text ByteString }+--+-- encodeResponse :: Response -> E.'Encoding'+-- encodeResponse (Response id_ result) = E.'dict'' $+-- E.'field' "id" E.'int' id_+-- <> either err ok result+-- where+-- err reason =+-- E.'field' "status" E.'text' "failure"+-- <> E.'field' "reason" E.'text' reason+-- ok data_ =+-- E.'field' "status" E.'text' "success"+-- <> E.'field' "data" E.'string' data_+-- @+--+-- >>> toLBS $ encodeResponse $ Response 42 (Left "unauthorized")+-- "d2:idi42e6:reason12:unauthorized6:status7:failuree"+-- >>> toLBS $ encodeResponse $ Response 42 (Right "0000")+-- "d4:data4:00002:idi42e6:status7:successe"+--+-- === Encode as nested dicts+--+-- @+-- data File = File { name :: Text, size :: Int }+--+-- encodeFile :: File -> E.'Encoding'+-- encodeFile (File name size) = E.'dict'' $+-- E.'field' "name" E.'text' name+-- <> E.'field' "metadata" id (E.'dict'' $+-- E.'field' "info" id (E.'dict'' $+-- E.'field' "size" E.'int' size))+-- @+--+-- >>> toLBS $ encodeFile $ File "hello.txt" 32+-- "d8:metadatad4:infod4:sizei32eee4:name9:hello.txte"+--
+ src/Data/Bencode/Type.hs view
@@ -0,0 +1,22 @@+-- |+-- This module defines the 'Value' type to represent any valid Bencode value.+--+-- Generally you will want to write decoders and encoders to work with your+-- own types. See "Data.Bencode.Decode" and "Data.Bencode.Encode" to get+-- started.+--+module Data.Bencode.Type+ ( Value(..)+ ) where++import qualified Data.ByteString as B+import qualified Data.Map as M+import qualified Data.Vector as V++-- | A type that can represent any Bencode value.+data Value+ = String !B.ByteString+ | Integer !Integer+ | List !(V.Vector Value)+ | Dict !(M.Map B.ByteString Value)+ deriving (Eq, Ord, Show)
+ src/Data/Bencode/Util.hs view
@@ -0,0 +1,58 @@+module Data.Bencode.Util+ ( readKnownNaturalAsInt+ , readKnownNaturalAsWord+ ) where++import Data.Bits+import qualified Data.ByteString as B++-- | The input string must be an unsigned decimal integer with no extraneous+-- leading zeros. Returns Nothing if the value is outside the bounds of an+-- @Int@.+readKnownNaturalAsInt :: Bool -> B.ByteString -> Maybe Int+readKnownNaturalAsInt neg s = case B.uncons sr of+ Nothing -> Just $! if neg then -n else n+ Just (d,sr')+ | B.null sr'+ , let d' = fromIntegral d - 48+ , n < iMaxDiv10 || n == iMaxDiv10 && d' <= (7 + fromEnum neg)+ -- last digit of maxBound = 7, minBound = 8+ -> Just $! if neg then -n * 10 - d' else n * 10 + d'+ | otherwise -> Nothing+ where+ (sl,sr) = B.splitAt (maxIntLen - 1) s+ n = B.foldl' (\acc d -> acc * 10 + fromIntegral d - 48) 0 sl++iMaxDiv10 :: Int+iMaxDiv10 = maxBound `div` 10++maxIntLen :: Int+maxIntLen = case finiteBitSize (0 :: Int) of+ 32 -> 10+ 64 -> 19+ _ -> error "unsupported word size"++-- | The input string must be an unsigned decimal integer with no extraneous+-- leading zeros. Returns Nothing if the value is outside the bounds of a+-- @Word@.+readKnownNaturalAsWord :: B.ByteString -> Maybe Word+readKnownNaturalAsWord s = case B.uncons sr of+ Nothing -> Just $! n+ Just (d,sr')+ | B.null sr'+ , let d' = fromIntegral d - 48+ , n < wMaxDiv10 || n == wMaxDiv10 && d' <= 5 -- last digit of maxBound is 5+ -> Just $! n * 10 + d'+ | otherwise -> Nothing+ where+ (sl,sr) = B.splitAt (maxWordLen - 1) s+ n = B.foldl' (\acc d -> acc * 10 + fromIntegral d - 48) 0 sl++wMaxDiv10 :: Word+wMaxDiv10 = maxBound `div` 10++maxWordLen :: Int+maxWordLen = case finiteBitSize (0 :: Word) of+ 32 -> 10+ 64 -> 20+ _ -> error "unsupported word size"
+ test/Test.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- Arbitrary instances+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.Map as M+import qualified Data.Vector as V++import qualified Data.Bencode.Decode as D+import qualified Data.Bencode.Encode as E+import qualified Data.Bencode.Type as Ben++main :: IO ()+main = defaultMain $ testGroup "Tests"+ [ astTests+ , decodeTests+ , encodeTests+ , encodeDecodeTests+ ]++-- Would like to test Data.Bencode.AST.parseOnly but since it's not exposed+-- test via D.decode D.value.+astTests :: TestTree+astTests = testGroup "AST"+ [ testGroup "valid Bencode"+ [ testGroup "string"+ [ testCase "0:" $ D.decode D.value "0:" @?= Right (Ben.String "")+ , testCase "3:foo" $ D.decode D.value "3:foo" @?= Right (Ben.String "foo")+ , testCase "<binary>" $ D.decode D.value "2:\x00\xff" @?= Right (Ben.String "\x00\xff")+ ]+ , testGroup "integer"+ [ testCase "i0e" $ D.decode D.value "i0e" @?= Right (Ben.Integer 0)+ , testCase "i1e" $ D.decode D.value "i1e" @?= Right (Ben.Integer 1)+ , testCase "i-1e" $ D.decode D.value "i-1e" @?= Right (Ben.Integer (-1))+ , testCase "i98765432109876543210e" $ D.decode D.value "i98765432109876543210e" @?= Right (Ben.Integer 98765432109876543210)+ ]+ , testGroup "list"+ [ testCase "le" $ D.decode D.value "le" @?= Right (Ben.List [])+ , testCase "li1e3:fooe" $ D.decode D.value "li1e3:fooe" @?= Right (Ben.List [Ben.Integer 1, Ben.String "foo"])+ , testCase "lllll3:fooeeeee" $ D.decode D.value "lllll3:fooeeeee" @?= Right (Ben.List [Ben.List [Ben.List [Ben.List [Ben.List [Ben.String "foo"]]]]])+ ]+ , testGroup "dict"+ [ testCase "de" $ D.decode D.value "de" @?= Right (Ben.Dict [])+ , testCase "d3:fooi0ee" $ D.decode D.value "d3:fooi1ee" @?= Right (Ben.Dict [("foo", Ben.Integer 1)])+ , testCase "d3:bari0e3:fooi1ee" $ D.decode D.value "d3:bari0e3:fooi1ee" @?= Right (Ben.Dict [("bar", Ben.Integer 0), ("foo", Ben.Integer 1)])+ , testCase "d3:food3:foodeee" $ D.decode D.value "d3:food3:foodeee" @?= Right (Ben.Dict [("foo", Ben.Dict [("foo", Ben.Dict [])])])+ ]+ ]+ , testGroup "invalid Bencode fails"+ [ testGroup "no items"+ [ testCase "<empty>" $ D.decode D.value "" @?= Left "ParseErrorAt 0: ExpectedOneOfButGot [Digit,'i','l','d'] EOF"+ , testCase "a" $ D.decode D.value "a" @?= Left "ParseErrorAt 0: ExpectedOneOfButGot [Digit,'i','l','d'] 'a'"+ , testCase ":" $ D.decode D.value ":" @?= Left "ParseErrorAt 0: ExpectedOneOfButGot [Digit,'i','l','d'] ':'"+ ]+ , testGroup "string"+ [ let x = show (2^(64 :: Int) :: Integer) {- overflows to 0 -} in+ testCase (x <> ":") $ D.decode D.value (BC.pack x <> ":") @?= Left "ParseErrorAt 0: TooLargeStringLength"+ , let x = show (fromIntegral (maxBound :: Int) + 1 :: Integer) {- overflows to -1 -} in+ testCase (x <> ":") $ D.decode D.value (BC.pack x <> ":") @?= Left "ParseErrorAt 0: TooLargeStringLength"+ , testCase "3" $ D.decode D.value "3" @?= Left "ParseErrorAt 1: ExpectedOneOfButGot [':'] EOF"+ , testCase "3foo" $ D.decode D.value "3foo" @?= Left "ParseErrorAt 1: ExpectedOneOfButGot [':'] 'f'"+ , testCase "4:foo" $ D.decode D.value "4:foo" @?= Left "ParseErrorAt 0: TooLargeStringLength"+ ]+ ]+ , testGroup "integer"+ [ testCase "i" $ D.decode D.value "i" @?= Left "ParseErrorAt 1: ExpectedOneOfButGot [Digit] EOF"+ , testCase "i01e" $ D.decode D.value "i01" @?= Left "ParseErrorAt 2: ExpectedOneOfButGot ['e'] '1'"+ , testCase "i-" $ D.decode D.value "i-" @?= Left "ParseErrorAt 2: ExpectedOneOfButGot [NonZeroDigit] EOF"+ , testCase "i-0e" $ D.decode D.value "i-0e" @?= Left "ParseErrorAt 2: ExpectedOneOfButGot [NonZeroDigit] 'e'"+ , testCase "ifooe" $ D.decode D.value "ifooe" @?= Left "ParseErrorAt 1: ExpectedOneOfButGot [Digit,'-'] 'f'"+ , testCase "i12" $ D.decode D.value "i12" @?= Left "ParseErrorAt 3: ExpectedOneOfButGot ['e'] EOF"+ , testCase "i12d" $ D.decode D.value "i12d" @?= Left "ParseErrorAt 3: ExpectedOneOfButGot ['e'] 'd'"+ ]+ , testGroup "list"+ [ testCase "l" $ D.decode D.value "l" @?= Left "ParseErrorAt 1: ExpectedOneOfButGot [Digit,'i','l','d','e'] EOF"+ , testCase "lfoo" $ D.decode D.value "lfoo" @?= Left "ParseErrorAt 1: ExpectedOneOfButGot [Digit,'i','l','d','e'] 'f'"+ , testCase "l3:foo" $ D.decode D.value "l3:foo" @?= Left "ParseErrorAt 6: ExpectedOneOfButGot [Digit,'i','l','d','e'] EOF"+ , testCase "l3:foobar" $ D.decode D.value "l3:foobar" @?= Left "ParseErrorAt 6: ExpectedOneOfButGot [Digit,'i','l','d','e'] 'b'"+ ]+ , testGroup "dict"+ [ testCase "d" $ D.decode D.value "d" @?= Left "ParseErrorAt 1: ExpectedOneOfButGot [Digit,'e'] EOF"+ , testCase "dfoo" $ D.decode D.value "dfoo" @?= Left "ParseErrorAt 1: ExpectedOneOfButGot [Digit,'e'] 'f'"+ , testCase "d3:foo" $ D.decode D.value "d3:foo" @?= Left "ParseErrorAt 6: ExpectedOneOfButGot [Digit,'i','l','d'] EOF"+ , testCase "d3:foobar" $ D.decode D.value "d3:foobar" @?= Left "ParseErrorAt 6: ExpectedOneOfButGot [Digit,'i','l','d'] 'b'"+ , testCase "di1e3:foo" $ D.decode D.value "di1e3:foo" @?= Left "ParseErrorAt 1: ExpectedOneOfButGot [Digit,'e'] 'i'"+ , testCase "d3:fooi0e3:bari1ee" $ D.decode D.value "d3:fooi0e3:bari1ee" @?= Left "ParseErrorAt 9: UnsortedKeys \"foo\" \"bar\""+ ]+ , testGroup "leftover"+ [ testCase "3:foo3:bar" $ D.decode D.value "3:foo3:bar" @?= Left "ParseErrorAt 5: ExpectedEOF"+ ]+ ]++decodeTests :: TestTree+decodeTests = testGroup "Decode"+ [ testGroup "string"+ [ testCase "0:" $ D.decode D.string "0:" @?= Right ""+ , testCase "3:foo" $ D.decode D.string "3:foo" @?= Right "foo"+ , testCase "i0e" $ D.decode D.string "i0e" @?= Left "TypeMismatch String Integer"+ , testCase "le" $ D.decode D.string "le" @?= Left "TypeMismatch String List"+ , testCase "de" $ D.decode D.string "de" @?= Left "TypeMismatch String Dict"+ ]+ , testGroup "integer"+ [ testCase "i0e" $ D.decode D.integer "i0e" @?= Right 0+ , testCase "i-32e" $ D.decode D.integer "i-32e" @?= Right (-32)+ , testCase "i98765432109876543210e" $ D.decode D.integer "i98765432109876543210e" @?= Right 98765432109876543210+ , testCase "0:" $ D.decode D.integer "0:" @?= Left "TypeMismatch Integer String"+ , testCase "le" $ D.decode D.integer "le" @?= Left "TypeMismatch Integer List"+ , testCase "de" $ D.decode D.integer "de" @?= Left "TypeMismatch Integer Dict"+ ]+ , testGroup "list"+ [ testCase "le" $ D.decode (D.list D.value) "le" @?= Right []+ , testCase "l3:foo3:bare" $ D.decode (D.list D.string) "l3:foo3:bare" @?= Right ["foo", "bar"]+ , testCase "l3:fooi1ee" $ D.decode (D.list D.string) "l3:fooi1ee" @?= Left "TypeMismatch String Integer"+ , testCase "0:" $ D.decode (D.list D.value) "0:" @?= Left "TypeMismatch List String"+ , testCase "i0e" $ D.decode (D.list D.value) "i0e" @?= Left "TypeMismatch List Integer"+ , testCase "de" $ D.decode (D.list D.value) "de" @?= Left "TypeMismatch List Dict"+ ]+ , testGroup "dict"+ [ testCase "de" $ D.decode (D.dict D.value) "de" @?= Right []+ , testCase "d3:foo3:bare" $ D.decode (D.dict D.string) "d3:foo3:bare" @?= Right [("foo", "bar")]+ , testCase "d3:foo3:bar3:quxi1ee" $ D.decode (D.dict D.string) "d3:foo3:bar3:quxi1ee" @?= Left "TypeMismatch String Integer"+ , testCase "0:" $ D.decode (D.dict D.value) "0:" @?= Left "TypeMismatch Dict String"+ , testCase "i0e" $ D.decode (D.dict D.value) "i0e" @?= Left "TypeMismatch Dict Integer"+ , testCase "le" $ D.decode (D.dict D.value)"le" @?= Left "TypeMismatch Dict List"+ ]+ , testGroup "text"+ [ testCase "0:" $ D.decode D.text "0:" @?= Right ""+ , testCase "3:foo" $ D.decode D.text "3:foo" @?= Right "foo"+ , testCase "こんにちは" $ D.decode D.text "15:\227\129\147\227\130\147\227\129\171\227\129\161\227\129\175" @?= Right "こんにちは"+ , testCase "<invalid UTF-8>" $ D.decode D.text "2:\xd8\x00" @?= Left "UTF8DecodeFailure"+ , testCase "i0e" $ D.decode D.text"i0e" @?= Left "TypeMismatch String Integer"+ , testCase "le" $ D.decode D.text"le" @?= Left "TypeMismatch String List"+ , testCase "de" $ D.decode D.text"de" @?= Left "TypeMismatch String Dict"+ ]+ , testGroup "int"+ [ testCase "i0e" $ D.decode D.int "i0e" @?= Right 0+ , testCase "i-32e" $ D.decode D.int "i-32e" @?= Right (-32)+ , let x = show (fromIntegral (minBound :: Int) - 1 :: Integer) in+ testCase "minBound-1" $ D.decode D.int ("i" <> BC.pack x <> "e") @?= Left "IntOutOfBounds"+ , testCase "minBound" $ D.decode D.int ("i" <> BC.pack (show (minBound :: Int)) <> "e") @?= Right minBound+ , testCase "maxBound" $ D.decode D.int ("i" <> BC.pack (show (maxBound :: Int)) <> "e") @?= Right maxBound+ , let x = show (fromIntegral (maxBound :: Int) + 1 :: Integer) in+ testCase "maxBound+1" $ D.decode D.int ("i" <> BC.pack x <> "e") @?= Left "IntOutOfBounds"+ , testCase "i98765432109876543210e" $ D.decode D.int "i98765432109876543210e" @?= Left "IntOutOfBounds"+ , testCase "0:" $ D.decode D.int "0:" @?= Left "TypeMismatch Integer String"+ , testCase "le" $ D.decode D.int "le" @?= Left "TypeMismatch Integer List"+ , testCase "de" $ D.decode D.int "de" @?= Left "TypeMismatch Integer Dict"+ ]+ , testGroup "word"+ [ testCase "i0e" $ D.decode D.word "i0e" @?= Right 0+ , testCase "i-1e" $ D.decode D.word "i-1e" @?= Left "WordOutOfBounds"+ , testCase "maxBound" $ D.decode D.word ("i" <> BC.pack (show (maxBound :: Word)) <> "e") @?= Right maxBound+ , let x = show (fromIntegral (maxBound :: Word) + 1 :: Integer) in+ testCase "maxBound+1" $ D.decode D.word ("i" <> BC.pack x <> "e") @?= Left "WordOutOfBounds"+ , testCase "i98765432109876543210e" $ D.decode D.word "i98765432109876543210e" @?= Left "WordOutOfBounds"+ , testCase "0:" $ D.decode D.word "0:" @?= Left "TypeMismatch Integer String"+ , testCase "le" $ D.decode D.word "le" @?= Left "TypeMismatch Integer List"+ , testCase "de" $ D.decode D.word "de" @?= Left "TypeMismatch Integer Dict"+ ]+ , testGroup "field"+ [ testCase "d3:foo3:bare" $ D.decode (D.field "foo" D.string) "d3:foo3:bare" @?= Right "bar"+ , testCase "d3:fooi2ee" $ D.decode (D.field "foo" D.string) "d3:fooi2ee" @?= Left "TypeMismatch String Integer"+ , let p = (,,) <$> D.field "one" D.integer+ <*> D.field "two" D.string+ <*> D.field "three" (D.list D.integer) in+ testCase "d3:onei1e5:threeli0ei0ei0ee3:two3:twoe" $+ D.decode p "d3:onei1e5:threeli0ei0ei0ee3:two3:twoe" @?= Right (1, "two", [0,0,0])+ ]+ , testGroup "fail"+ [ testCase "3:foo" $ D.decode (D.fail "error!" :: D.Parser B.ByteString) "3:foo" @?= Left "Fail: error!"+ ]+ ]++encodeTests :: TestTree+encodeTests = testGroup "Encode"+ [ testGroup "string"+ [ testCase "<empty>" $ enc E.string "" @?= "0:"+ , testCase "Hello, World!" $ enc E.string "Hello, World!" @?= "13:Hello, World!"+ ]+ , testGroup "integer"+ [ testCase "0" $ enc E.integer 0 @?= "i0e"+ , testCase "1" $ enc E.integer 1 @?= "i1e"+ , testCase "-1" $ enc E.integer (-1) @?= "i-1e"+ , testCase "98765432109876543210" $ enc E.integer 98765432109876543210 @?= "i98765432109876543210e"+ ]+ , testGroup "list"+ [ testCase "[]" $ enc (E.list E.integer) [] @?= "le"+ , testCase "[2,3,1]" $ enc (E.list E.integer) [2,3,1] @?= "li2ei3ei1ee"+ ]+ , testGroup "dict"+ [ testCase "{}" $ enc (E.dict E.integer) [] @?= "de"+ , testCase "{one:1,two:2,three:3}" $ enc (E.dict E.integer) [("one",1),("two",2),("three",3)] @?= "d3:onei1e5:threei3e3:twoi2ee"+ ]+ , testGroup "text"+ [ testCase "Hello, World!" $ enc E.text "Hello, World!" @?= "13:Hello, World!"+ , testCase "こんにちは" $ enc E.text "こんにちは" @?= "15:\227\129\147\227\130\147\227\129\171\227\129\161\227\129\175"+ ]+ , testGroup "int"+ [ testCase "0" $ enc E.int 0 @?= "i0e"+ , testCase "1" $ enc E.int 1 @?= "i1e"+ , testCase "-1" $ enc E.int (-1) @?= "i-1e"+ , testCase "minBound" $ enc E.int minBound @?= "i" <> BLC.pack (show (minBound :: Int)) <> "e"+ , testCase "maxBound" $ enc E.int maxBound @?= "i" <> BLC.pack (show (maxBound :: Int)) <> "e"+ ]+ , testGroup "word"+ [ testCase "0" $ enc E.word 0 @?= "i0e"+ , testCase "1" $ enc E.word 1 @?= "i1e"+ , testCase "minBound" $ enc E.word minBound @?= "i0e"+ , testCase "maxBound" $ enc E.word maxBound @?= "i" <> BLC.pack (show (maxBound :: Word)) <> "e"+ ]+ , testGroup "field"+ [ testCase "{}" $ enc id (E.dict' mempty) @?= "de"+ , let e = E.dict' $+ E.field "one" E.integer 1+ <> E.field "two" E.string "two"+ <> E.field "three" (E.list E.integer) [0,0,0] in+ testCase "{one:1,two:two,three:[0,0,0]}" $ enc id e @?= "d3:onei1e5:threeli0ei0ei0ee3:two3:twoe"+ ]+ ]++enc :: (a -> E.Encoding) -> a -> BL.ByteString +enc f = BB.toLazyByteString . E.toBuilder . f++encodeDecodeTests :: TestTree+encodeDecodeTests = testGroup "EncodeDecode"+ [ testProperty "decode . encode == Right" $ withMaxSuccess 1000 $+ \v -> ( D.decode D.value .+ BL.toStrict .+ BB.toLazyByteString .+ E.toBuilder .+ E.value ) v+ === Right v+ ]++instance Arbitrary Ben.Value where+ arbitrary = sized $ \n -> do+ n' <- choose (0,n)+ go (n'+1)+ where+ go 1 = do+ sOrI <- arbitrary+ if sOrI+ then Ben.String <$> arbitrary+ else Ben.Integer <$> arbitrary+ go n = do+ ns <- partition n >>= shuffle+ lOrD <- arbitrary+ if lOrD+ then Ben.List . V.fromList <$> traverse go ns+ else Ben.Dict . M.fromList+ <$> traverse (\n' -> (,) <$> arbitrary <*> go n') ns+ partition 0 = pure []+ partition n = do+ x <- choose (1,n)+ (x:) <$> partition (n-x)++instance Arbitrary B.ByteString where+ arbitrary = B.pack <$> arbitrary