diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +### 0.1.1.0 -- 2023-12-05 + +* New + * Integer parsing/encoding: `int64`, `int32`, `int16`, `int8`, `word64`, + `word32`, `word16`, `word8`. + * List parsing: `index`, `elem`, `list'`. + * Dictionary parsing: `field'`, `dict'`. + * `mapMaybe` and `mapOrFail` for `Parser`. +* Performance improvements + ### 0.1.0.0 -- 2023-11-09 * First version. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,8 @@ # benc +[![Hackage](https://img.shields.io/hackage/v/benc?logo=haskell&color=blue)](https://hackage.haskell.org/package/benc) +[![Haskell-CI](https://github.com/meooow25/benc/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/meooow25/benc/actions/workflows/haskell-ci.yml) + Bencode encoding and decoding library ## Bencode @@ -71,24 +74,24 @@ #### 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 | +| Library | `crossref` time | alloc | `ubuntu` time | alloc | +| ----------- | ---------------- | ------ | ---------------- | ------ | +| benc | 21.3 ms ± 902 μs | 24 MB | 1.30 μs ± 90 ns | 3.6 KB | +| bencode | 218 ms ± 7.7 ms | 737 MB | 29.0 μs ± 2.6 μs | 121 KB | +| AttoBencode | 44.6 ms ± 4.0 ms | 129 MB | 3.01 μs ± 102 ns | 17 KB | +| bencoding | 39.1 ms ± 2.3 ms | 104 MB | 2.44 μs ± 175 ns | 15 KB | 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. #### 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 | +| Library | `crossref` time | alloc | `ubuntu` time | alloc | +| ----------- | ---------------- | ------ | ---------------- | ------ | +| benc | 9.17 ms ± 487 μs | 42 MB | 1.58 μs ± 101 ns | 11 KB | +| bencode | 37.8 ms ± 860 μs | 113 MB | 3.17 μs ± 174 ns | 19 KB | +| AttoBencode | 19.7 ms ± 1.8 ms | 109 MB | 10.1 μs ± 993 ns | 295 KB | +| bencoding | 11.9 ms ± 916 μs | 67 MB | 1.81 μs ± 129 ns | 15 KB | Note: `AttoBencode` encodes to a strict `ByteString` via a lazy `ByteString`, unlike the rest, which only prepare the lazy `ByteString`. As @@ -96,5 +99,6 @@ ## Contributing -Contributions, bug reports, suggestions welcome! Please -[open an issue](https://github.com/meooow25/benc/issues). +Questions, bug reports, documentation improvements, code contributions welcome! +Please [open an issue](https://github.com/meooow25/benc/issues) as the first +step. diff --git a/benc.cabal b/benc.cabal --- a/benc.cabal +++ b/benc.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: benc -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Bencode encoding and decoding library description: Bencode encoding and decoding library. homepage: https://github.com/meooow25/benc @@ -14,6 +14,15 @@ README.md CHANGELOG.md +tested-with: + GHC == 8.10.1 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.3 + , GHC == 9.8.1 + common warnings ghc-options: -Wall @@ -31,11 +40,11 @@ build-depends: base >= 4.14 && < 5.0 - , bytestring >= 0.10.12 && < 0.13 - , containers >= 0.6.5 && < 0.8 + , bytestring >= 0.10.10 && < 0.13 + , containers >= 0.6.2.1 && < 0.8 , primitive >= 0.9.0 && < 0.10 - , text >= 1.2.4 && < 2.2 - , transformers >= 0.5.6 && < 0.7 + , text >= 1.2.3.2 && < 2.2 + , transformers >= 0.5.6.2 && < 0.7 , vector >= 0.13.1 && < 0.14 hs-source-dirs: src @@ -60,27 +69,22 @@ default-language: Haskell2010 type: exitcode-stdio-1.0 -benchmark benc-compare +benchmark benc-bench import: warnings build-depends: base , benc - , bencode == 0.6.1.1 - , AttoBencode == 0.3.1.0 - , bencoding == 0.4.5.4 + , deepseq , 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 + hs-source-dirs: bench main-is: Bench.hs default-language: Haskell2010 type: exitcode-stdio-1.0 diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Test.Tasty.Bench + +import Data.Bits +import Data.Int +import Data.Semigroup +import Data.Word +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +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.Vector as V + +import qualified Data.Bencode.Decode as D +import qualified Data.Bencode.Encode as E + +main :: IO () +main = defaultMain + [ bgroup "Decode" + [ envPure sData $ bench "string" . whnf decString + , envPure iData $ bench "integer" . whnf decInteger + , envPure lData $ bench "list" . whnf decList + , envPure dData $ bench "dict" . whnf decDict + , envPure sData $ bench "text" . whnf decText + , envPure lsData $ bench "list string" . whnf decListString + , envPure liData $ bench "list int" . whnf decListInt + , envPure llData $ bench "list list" . whnf decListList + , envPure ldData $ bench "list dict" . whnf decListDict + , envPure ldData2 $ bench "list fields" . whnf decListFields + , envPure liData $ bench "list word16" . whnf decListWord16 + , envPure ldData2 $ bench "list dict'" . whnf decListDict' + , envPure llData2 $ bench "list index" . whnf decListIndex + , envPure llData2 $ bench "list list'" . whnf decListList' + ] + , bgroup "Encode" + [ bench "string" $ whnf encManyString n + , bench "integer" $ whnf encManyInteger n + , bench "list" $ whnf encManyList n100 + , bench "list fusion" $ whnf encManyListFusion n + , bench "dict" $ whnf encManyDict n100 + , bench "text" $ whnf encManyText n + , bench "int" $ whnf encManyInt n + , bench "field" $ whnf encManyField n10 + , bench "word16" $ whnf encManyWord16 n + ] + ] + where + -- How was the test data and size selected? + -- Pretty much arbitrarily. Sizes are chosen such that a benchmark + -- takes <= ~200ms. + n, n10, n100 :: Int + !n = 1000000 + !n10 = n `div` 10 + !n100 = n `div` 100 + + envPure = env . pure + toBS = BL.toStrict . BB.toLazyByteString + + sData = BC.pack (show n) <> ":" <> stimes n "x" + iData = "i1" <> stimes n "1" <> "e" + lData = "l" <> stimes n "le" <> "e" + dData = toBS $ "d" <> go n10 <> "e" + where + go i | i == 2*n10 = mempty + go i = "6:" <> BB.intDec i <> "de" <> go (i+1) + lsData = toBS $ "l" <> stimes n10 s <> "e" + where + s = "5:hello5:world13:one two three" + liData = toBS $ "l" <> go n <> "e" + where + go 0 = mempty + go i = "i" <> BB.intDec (i .&. 0xffff) <> "e" <> go (i-1) + llData = toBS $ "l" <> stimes n "le" <> "e" + ldData = toBS $ "l" <> stimes n "de" <> "e" + ldData2 = toBS $ "l" <> stimes n10 d <> "e" + where + d = "d1:0de1:1de1:2de1:3de1:4de1:5de1:6de1:7de1:8de1:9dee" + silverForMonsters = "lelelelelelelelelele" + llData2 = toBS $ "l" <> stimes n10 ("l" <> silverForMonsters <> "e") <> "e" + + +-- All bench functions below are marked NOINLINE to make it easy to find +-- them by name in the GHC core output. + +------------------------------ +-- Decode +------------------------------ + +decString :: B.ByteString -> B.ByteString +decString = runP D.string +{-# NOINLINE decString #-} + +decInteger :: B.ByteString -> Integer +decInteger = runP D.integer +{-# NOINLINE decInteger #-} + +decList :: B.ByteString -> V.Vector (V.Vector ()) +decList = runP (D.list (D.list (pure ()))) +{-# NOINLINE decList #-} + +decDict :: B.ByteString -> M.Map B.ByteString (M.Map B.ByteString ()) +decDict = runP (D.dict (D.dict (pure ()))) +{-# NOINLINE decDict #-} + +decText :: B.ByteString -> T.Text +decText = runP D.text +{-# NOINLINE decText #-} + +decListString :: B.ByteString -> V.Vector B.ByteString +decListString = runP (D.list D.string) +{-# NOINLINE decListString #-} + +decListInt :: B.ByteString -> V.Vector Int +decListInt = runP (D.list D.int) +{-# NOINLINE decListInt #-} + +decListList :: B.ByteString -> V.Vector (V.Vector ()) +decListList = runP (D.list (D.list (pure ()))) +{-# NOINLINE decListList #-} + +decListDict :: B.ByteString -> V.Vector (M.Map B.ByteString ()) +decListDict = runP (D.list (D.dict (pure ()))) +{-# NOINLINE decListDict #-} + +decListFields :: B.ByteString -> V.Vector () +decListFields = runP (D.list foo) + where + foo = do + D.field "0" (pure ()) + D.field "1" (pure ()) + D.field "2" (pure ()) + D.field "3" (pure ()) + D.field "4" (pure ()) + D.field "5" (pure ()) + D.field "6" (pure ()) + D.field "7" (pure ()) + D.field "8" (pure ()) + D.field "9" (pure ()) +{-# NOINLINE decListFields #-} + +decListWord16 :: B.ByteString -> V.Vector Word16 +decListWord16 = runP (D.list D.word16) +{-# NOINLINE decListWord16 #-} + +decListDict' :: B.ByteString -> V.Vector () +decListDict' = runP (D.list foo) + where + foo = D.dict' $ do + D.field' "0" (pure ()) + D.field' "1" (pure ()) + D.field' "2" (pure ()) + D.field' "3" (pure ()) + D.field' "4" (pure ()) + D.field' "5" (pure ()) + D.field' "6" (pure ()) + D.field' "7" (pure ()) + D.field' "8" (pure ()) + D.field' "9" (pure ()) +{-# NOINLINE decListDict' #-} + +decListIndex :: B.ByteString -> V.Vector () +decListIndex = runP (D.list foo) + where + foo = do + D.index 0 (pure ()) + D.index 1 (pure ()) + D.index 2 (pure ()) + D.index 3 (pure ()) + D.index 4 (pure ()) + D.index 5 (pure ()) + D.index 6 (pure ()) + D.index 7 (pure ()) + D.index 8 (pure ()) + D.index 9 (pure ()) +{-# NOINLINE decListIndex #-} + +decListList' :: B.ByteString -> V.Vector () +decListList' = runP (D.list foo) + where + foo = D.list' $ do + D.elem (pure ()) + D.elem (pure ()) + D.elem (pure ()) + D.elem (pure ()) + D.elem (pure ()) + D.elem (pure ()) + D.elem (pure ()) + D.elem (pure ()) + D.elem (pure ()) + D.elem (pure ()) +{-# NOINLINE decListList' #-} + +runP :: D.Parser a -> B.ByteString -> a +runP p = either error id . D.decode p +{-# INLINE runP #-} + +------------------------------ +-- Encode +------------------------------ + +encManyString :: Int -> Int64 +encManyString = encMany E.string ("hello","world","one two three") +{-# NOINLINE encManyString #-} + +encManyInteger :: Int -> Int64 +encManyInteger = encMany E.integer (0,-100000,fromIntegral (maxBound :: Int)) +{-# NOINLINE encManyInteger #-} + +encManyList :: Int -> Int64 +encManyList = + encMany (E.list (E.list E.value)) + (V.empty, V.replicate 10 V.empty, V.replicate 90 V.empty) +{-# NOINLINE encManyList #-} + +encManyListFusion :: Int -> Int64 +encManyListFusion = getL . E.toBuilder . E.list E.int . flip V.generate id +{-# NOINLINE encManyListFusion #-} + +encManyDict :: Int -> Int64 +encManyDict = + encMany (E.dict (E.dict E.value)) + (M.empty, M.singleton "a" M.empty, m99) +{-# NOINLINE encManyDict #-} + +m99 :: M.Map B.ByteString (M.Map B.ByteString a) +m99 = M.fromList [(BC.pack (show i), M.empty) | i <- [1..99 :: Int]] + +encManyText :: Int -> Int64 +encManyText = encMany E.text ("hello","world","one two three") +{-# NOINLINE encManyText #-} + +encManyInt :: Int -> Int64 +encManyInt = encMany E.int (0,-100000,maxBound) +{-# NOINLINE encManyInt #-} + +data ABC = A | B | C + +encManyField :: Int -> Int64 +encManyField = encMany foo (A,B,C) + where + foo A = e + foo B = E.dict' $ E.field "foo" id e + foo C = E.dict' $ + E.field "0" id e + <> E.field "1" id e + <> E.field "2" id e + <> E.field "3" id e + <> E.field "4" id e + <> E.field "5" id e + <> E.field "6" id e + <> E.field "7" id e + <> E.field "8" id e + <> E.field "9" id e + e = E.dict id M.empty +{-# NOINLINE encManyField #-} + +encManyWord16 :: Int -> Int64 +encManyWord16 = encMany E.word16 (0,1000,maxBound) +{-# NOINLINE encManyWord16 #-} + +encMany :: (a -> E.Encoding) -> (a,a,a) -> Int -> Int64 +encMany enc (x0',x1',x2') = getL . go x0' x1' x2' + where + go _ _ _ 0 = mempty + go x0 x1 x2 i = E.toBuilder (enc x0) <> go x1 x2 x0 (i-1) +{-# INLINE encMany #-} + +getL :: BB.Builder -> Int64 +getL = BL.length . BB.toLazyByteString +{-# INLINE getL #-} diff --git a/compare/Bench.hs b/compare/Bench.hs deleted file mode 100644 --- a/compare/Bench.hs +++ /dev/null @@ -1,413 +0,0 @@ -{-# 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 --} diff --git a/src/Data/Bencode/AST.hs b/src/Data/Bencode/AST.hs --- a/src/Data/Bencode/AST.hs +++ b/src/Data/Bencode/AST.hs @@ -1,34 +1,46 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Strict #-} +{-# OPTIONS_GHC -fspec-constr #-} module Data.Bencode.AST ( Value(..) , KeyValue(..) , parseOnly ) where +-- ATTENTION: This module is Strict! +-- +-- Prefer to add definitions where laziness is desirable in another module +-- instead of here with a ~. +-- +-- The core of this module has been inspected (with GHC 9.6.3 -O) to make sure +-- things are optimized and there is no unnecessary boxing to keep time and +-- allocations to a minimum. When modifying this file make sure to check the +-- core. + 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) +import qualified Data.Bencode.Util as Util -- | The Bencode AST. data Value - = String {-# UNPACK #-} !B.ByteString + = String {-# UNPACK #-} B.ByteString -- ^ Slice of the input @ByteString@. - | Integer {-# UNPACK #-} !B.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) + | 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 + {-# UNPACK #-} B.ByteString-- ^ Slice of the input @ByteString@. + Value deriving (Eq, Show) newtype Pos = Pos { unPos :: Int } deriving (Show, Num) @@ -39,8 +51,8 @@ data Stack = SNil - | SList {-# UNPACK #-} !Int ![Value] !Stack - | SDict {-# UNPACK #-} !B.ByteString {-# UNPACK #-} !Int ![KeyValue] !Stack + | 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. @@ -57,12 +69,10 @@ 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) + _ | isDigit c -> + parseString s pos $ \str s2 pos2 -> Right (String str, s2, unPos pos2) 'i' -> do - (i, s2, pos2) <- parseInteger s1 (pos+1) - Right (Integer i, s2, unPos pos2) + parseInteger s1 (pos+1) $ \i s2 pos2 -> Right (Integer i, s2, unPos pos2) 'l' -> parseList SNil 0 [] s1 (pos+1) 'd' -> parseDict SNil s1 (pos+1) _ -> errItem (Just c) pos @@ -71,71 +81,69 @@ -- | 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 +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 + parseString s pos $ \str -> parseList stk (n+1) (String str : acc) 'i' -> do - (i, s2, pos2) <- parseInteger s1 (pos+1) - parseList stk (n+1) (Integer i : acc) s2 pos2 + parseInteger s1 (pos+1) $ \i -> parseList stk (n+1) (Integer i : acc) '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) + 'e' -> resumeParse stk (List (Util.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 +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) + parseString s pos $ \key s2 pos2 -> + case BC.uncons s2 of + Nothing -> errItem Nothing pos2 + Just (c3,s3) -> case c3 of + _ | isDigit c3 -> do + parseString s2 pos2 $ \str -> + parseDict1 key stk 1 [KeyValue key (String str)] + 'i' -> do + parseInteger s3 (pos2+1) $ \i -> + parseDict1 key stk 1 [KeyValue key (Integer i)] + '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 (Util.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 +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) + parseString s pos $ \key s2 pos2 -> + 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 + parseString s2 pos2 $ \str -> + parseDict1 key stk (n+1) (KeyValue key (String str) : acc) + 'i' -> do + parseInteger s3 (pos2+1) $ \i -> + parseDict1 key stk (n+1) (KeyValue key (Integer i) : acc) + '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 (Util.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 +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 @@ -143,8 +151,9 @@ -- | 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 + -> (B.ByteString -> B.ByteString -> Pos -> ParseOneResult) + -> ParseOneResult +parseInteger s pos k = case BC.uncons s of Nothing -> errDigit Nothing pos Just (c1,s1) -> case c1 of '0' -> end (B.take 1 s) s1 (pos+1) @@ -158,32 +167,38 @@ 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 + 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) + 'e' -> k x s'' (pos'+1) _ -> errEnd (Just c) pos' + {-# INLINE end #-} {-# 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 + -> (B.ByteString -> B.ByteString -> Pos -> ParseOneResult) + -> ParseOneResult +parseString s pos k = case BC.span isDigit s of + (digs,s1) -> + case Util.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 -> k str s4 (pos2 + 1 + Pos n) + -- For some reason GHC does not realize without the bang that + -- s4 does not need to be boxed. + _ -> 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 @@ -209,19 +224,3 @@ 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" diff --git a/src/Data/Bencode/Decode.hs b/src/Data/Bencode/Decode.hs --- a/src/Data/Bencode/Decode.hs +++ b/src/Data/Bencode/Decode.hs @@ -1,99 +1,87 @@ -{-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} -- | -- 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 + ( + -- * Quick start + -- $quick + + -- * Parser Parser , decode , decodeMaybe - -- * Primary parsers + -- * String parsers , string - , integer - , list - , dict - - -- * More parsers , stringEq , text , textEq + + -- * Integer parsers + , integer , int , intEq + , int64 + , int32 + , int16 + , int8 , word + , word64 + , word32 + , word16 + , word8 + + -- * List parsers + , list + , index + , elem + , list' + , Elems + + -- * Dictionary parsers + , dict , field + , field' + , dict' + , Fields + + -- * Miscellaneous , value , fail + , mapMaybe + , mapOrFail - -- * Recipes - -- + -- * Recipes #recipes# -- $recipes ) where -import Prelude hiding (fail) +import Prelude hiding (elem, fail) import Control.Applicative import Control.Monad hiding (fail) import Control.Monad.ST +import Control.Monad.Trans.Class import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict +import Data.Int +import Data.Word import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.Foldable as F +import qualified Data.IntSet as IS 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 qualified GHC.Exts as X import Data.Bencode.Type (Value(..)) -import Data.Bencode.Util (readKnownNaturalAsInt, readKnownNaturalAsWord) +import qualified Data.Bencode.Util as Util import qualified Data.Bencode.AST as AST newtype ParseResult a = ParseResult { unParseResult :: Either String a } @@ -108,21 +96,29 @@ l <|> r = ParseResult $ unParseResult l <> unParseResult r -- Discards left error, not ideal +instance MonadPlus ParseResult +-- Does not satisfy MonadPlus laws because of the failure String +-- But required for Alternative (StateT _ ParseResult) + -- | A parser from a Bencode value to a Haskell value. -newtype Parser a = Parser { runParser :: AST.Value -> ParseResult a } +newtype Parser a = Parser { runParser_ :: ReaderT AST.Value ParseResult a } deriving (Functor, Applicative, Alternative, Monad) - via ReaderT AST.Value ParseResult -lift :: ParseResult a -> Parser a -lift = Parser . const -{-# INLINE lift #-} +runParser :: Parser a -> AST.Value -> ParseResult a +runParser = runReaderT . runParser_ +{-# INLINE runParser #-} +liftP :: ParseResult a -> Parser a +liftP = Parser . lift +{-# INLINE liftP #-} + failParser :: String -> Parser a -failParser = lift . failResult +failParser = liftP . failResult {-# INLINE failParser #-} -- | Decode a value from the given @ByteString@. If decoding fails, returns --- @Left@ with a failure message. +-- @Left@ with a failure message. The message is a short human-readable error +-- description and should not be relied on programmatically. decode :: Parser a -> B.ByteString -> Either String a decode p s = AST.parseOnly s >>= unParseResult . runParser p @@ -146,27 +142,27 @@ -- Eithers using "case-of-case". stringDirect :: Parser B.ByteString -stringDirect = Parser $ \v -> case v of +stringDirect = Parser $ ReaderT $ \v -> case v of AST.String s -> pure s - _ -> errTypeMismatch "String" v + _ -> errTypeMismatch "String" v {-# INLINE stringDirect #-} integerDirect :: Parser B.ByteString -integerDirect = Parser $ \v -> case v of +integerDirect = Parser $ ReaderT $ \v -> case v of AST.Integer s -> pure s - _ -> errTypeMismatch "Integer" v + _ -> errTypeMismatch "Integer" v {-# INLINE integerDirect #-} listDirect :: Parser (A.Array AST.Value) -listDirect = Parser $ \v -> case v of +listDirect = Parser $ ReaderT $ \v -> case v of AST.List a -> pure a - _ -> errTypeMismatch "List" v + _ -> errTypeMismatch "List" v {-# INLINE listDirect #-} dictDirect :: Parser (A.Array AST.KeyValue) -dictDirect = Parser $ \v -> case v of +dictDirect = Parser $ ReaderT $ \v -> case v of AST.Dict a -> pure a - _ -> errTypeMismatch "Dict" v + _ -> errTypeMismatch "Dict" v {-# INLINE dictDirect #-} -- | Decode a Bencode string as a ByteString. Fails on a non-string. @@ -192,7 +188,7 @@ -- | 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) +list p = listDirect >>= liftP . traverseAToV (runParser p) {-# INLINE list #-} traverseAToV :: (a -> ParseResult b) -> A.Array a -> ParseResult (V.Vector b) @@ -211,7 +207,7 @@ -- 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 + dictDirect >>= liftP . fmap M.fromDistinctAscList . traverse f . F.toList where f (AST.KeyValue k v) = (,) k <$> runParser p v {-# INLINE dict #-} @@ -246,8 +242,8 @@ int = integerDirect >>= maybe (failParser "IntOutOfBounds") pure . go where go s = case BC.uncons s of - Just ('-', s') -> readKnownNaturalAsInt True s' - _ -> readKnownNaturalAsInt False s + Just ('-', s') -> Util.readKnownNaturalAsInt True s' + _ -> Util.readKnownNaturalAsInt False s {-# INLINE int #-} -- | Succeeds only on a Bencode integer that equals the given value. @@ -265,7 +261,7 @@ where go s = case BC.uncons s of Just ('-',_) -> Nothing - _ -> readKnownNaturalAsWord s + _ -> Util.readKnownNaturalAsWord s {-# INLINE word #-} -- | Decode a @Value@. Always succeeds for valid Bencode. @@ -282,31 +278,313 @@ -- | 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. +-- +-- If keys should not be left over in the dict, use 'field'' and 'dict'' +-- instead. +-- +-- ==== __Examples__ +-- @ +-- data File = File { name :: Text, size :: Int } +-- +-- fileParser :: D.'Parser' File +-- fileParser = +-- File \<$> D.field "name" D.'text' +-- \<*> D.field "size" D.'int' +-- @ field :: B.ByteString -> Parser a -> Parser a -field k p = - dictDirect >>= - maybe (failParser $ "KeyNotFound " ++ show k) pure . binarySearch k >>= - lift . runParser p +field k p = do + a <- dictDirect + case binarySearch k a of + (# _ | #) -> failParser $ "KeyNotFound " ++ show k + (# | (# _, x #) #) -> liftP $ runParser p x {-# INLINE field #-} ----------- --- Utils +-- | Decode a value with the given parser for the given key. Convert to a +-- @Parser@ with 'dict''. +-- +-- @since 0.1.1.0 +field' :: B.ByteString -> Parser a -> Fields a +field' k p = Fields $ ReaderT $ \a -> case binarySearch k a of + (# _ | #) -> lift . failResult $ "KeyNotFound " ++ show k + (# | (# i#, v #) #) -> lift (runParser p v) <* modify' (IS.insert (X.I# i#)) +{-# INLINE field' #-} +-- | Create a @Parser@ from a 'Fields'. Fails on a non-dict, if a key is +-- absent, or if any value fails to parse. Also fails if there are leftover +-- unparsed keys in the dict. +-- +-- If leftover keys should be ignored, use 'field' instead. +-- +-- ==== __Examples__ +-- @ +-- data File = File { name :: Text, size :: Int } +-- +-- fileParser :: D.'Parser' File +-- fileParser = D.dict' $ +-- File \<$> D.'field'' "name" D.'text' +-- \<*> D.'field'' "size" D.'int' +-- @ +-- +-- @since 0.1.1.0 +dict' :: Fields a -> Parser a +dict' fs = do + a <- dictDirect + liftP $ do + (v, is) <- runStateT (runReaderT (runFields fs) a) IS.empty + if IS.size is == A.sizeofArray a + then pure v + else let i = head $ filter (`IS.notMember` is) [0..] + AST.KeyValue k _ = A.indexArray a i + in failResult $ "UnrecognizedKey " ++ show k +{-# INLINE dict' #-} + +-- | Key-value parsers. See 'dict'' and 'field''. +newtype Fields a = Fields + { runFields :: + ReaderT (A.Array AST.KeyValue) (StateT IS.IntSet ParseResult) a + } deriving (Functor, Applicative, Alternative, Monad) +-- We could use WriterT (CPS) but StateT is a teeny bit more efficient because +-- we can do IS.insert x instead of IS.union (IS.singleton x). + +-- | Decode a list element with the given parser at the given (0-based) index. +-- Fails on a non-list, if the index is out of bounds, or if the element parser +-- fails. +-- +-- Also see 'elem' and 'list''. +-- +-- ==== __Examples__ +-- @ +-- data File = File { name :: Text, size :: Int } +-- +-- fileParser :: D.'Parser' File +-- fileParser = +-- File \<$> D.index 0 D.'text' +-- \<*> D.index 1 D.'int' +-- @ +-- +-- @since 0.1.1.0 +index :: Int -> Parser a -> Parser a +index i _ | i < 0 = failParser "IndexOutOfBounds" +index i p = do + a <- listDirect + if i < A.sizeofArray a + then liftP $ runParser p (A.indexArray a i) + else failParser "IndexOutOfBounds" +{-# INLINE index #-} + +-- | Decode the next list element with the given parser. Convert to a @Parser@ +-- with 'list''. +-- +-- @since 0.1.1.0 +elem :: Parser a -> Elems a +elem p = Elems $ ReaderT $ \a -> do + i <- get + if i < A.sizeofArray a + then lift (runParser p (A.indexArray a i)) <* (put $! i+1) + else lift $ failResult "ListElemsExhausted" +{-# INLINE elem #-} + +-- | Create a @Parser@ from an @Elems@. Fails on a non-list, if the number of +-- elements does not match the @Elems@ exactly, or if any element parser fails. +-- +-- ==== __Examples__ +-- @ +-- data File = File { name :: Text, size :: Int } +-- +-- fileParser :: D.'Parser' File +-- fileParser = D.list' $ +-- File \<$> D.'elem' D.'text' +-- \<*> D.'elem' D.'int' +-- @ +-- +-- @since 0.1.1.0 +list' :: Elems a -> Parser a +list' es = do + a <- listDirect + liftP $ do + (x, i) <- runStateT (runReaderT (runElems es) a) 0 + if i == A.sizeofArray a + then pure x + else failResult $ "ListElemsLeft" +{-# INLINE list' #-} + +-- | List elements parser. See 'elem' and 'list''. +newtype Elems a = Elems + { runElems :: ReaderT (A.Array AST.Value) (StateT Int ParseResult) a + } deriving (Functor, Applicative, Alternative, Monad) + +-- | Decode a Bencode integer as an @Int64@. Fails on a non-integer or if the +-- integer is out of bounds for an @Int64@. +-- +-- @since 0.1.1.0 +int64 :: Parser Int64 +int64 = integerDirect >>= maybe (failParser "IntOutOfBounds") pure . go + where + go s = case BC.uncons s of + Just ('-', s') -> Util.readKnownNaturalAsInt64 True s' + _ -> Util.readKnownNaturalAsInt64 False s +{-# INLINE int64 #-} + +-- | Decode a Bencode integer as an @Int32@. Fails on a non-integer or if the +-- integer is out of bounds for an @Int32@. +-- +-- @since 0.1.1.0 +int32 :: Parser Int32 +int32 = intL32 +{-# INLINE int32 #-} + +-- | Decode a Bencode integer as an @Int16@. Fails on a non-integer or if the +-- integer is out of bounds for an @Int16@. +-- +-- @since 0.1.1.0 +int16 :: Parser Int16 +int16 = intL32 +{-# INLINE int16 #-} + +-- | Decode a Bencode integer as an @Int8@. Fails on a non-integer or if the +-- integer is out of bounds for an @Int8@. +-- +-- @since 0.1.1.0 +int8 :: Parser Int8 +int8 = intL32 +{-# INLINE int8 #-} + +-- Parse an Int(<=32) via Int. +intL32 :: forall a. (Bounded a, Integral a) => Parser a +intL32 = int >>= \i -> + if fromIntegral (minBound :: a) <= i && i <= fromIntegral (maxBound :: a) + then pure $! fromIntegral i + else failParser "IntOutOfBounds" +{-# INLINE intL32 #-} + +-- | Decode a Bencode integer as a @Word64@. Fails on a non-integer or if the +-- integer is out of bounds for a @Word64@. +-- +-- @since 0.1.1.0 +word64 :: Parser Word64 +word64 = integerDirect >>= maybe (failParser "WordOutOfBounds") pure . go + where + go s = case BC.uncons s of + Just ('-', _) -> Nothing + _ -> Util.readKnownNaturalAsWord64 s +{-# INLINE word64 #-} + +-- | Decode a Bencode integer as a @Word32@. Fails on a non-integer or if the +-- integer is out of bounds for a @Word32@. +-- +-- @since 0.1.1.0 +word32 :: Parser Word32 +word32 = wordL32 +{-# INLINE word32 #-} + +-- | Decode a Bencode integer as a @Word16@. Fails on a non-integer or if the +-- integer is out of bounds for a @Word16@. +-- +-- @since 0.1.1.0 +word16 :: Parser Word16 +word16 = wordL32 +{-# INLINE word16 #-} + +-- | Decode a Bencode integer as a @Word8@. Fails on a non-integer or if the +-- integer is out of bounds for a @Word8@. +-- +-- @since 0.1.1.0 +word8 :: Parser Word8 +word8 = wordL32 +{-# INLINE word8 #-} + +-- Parse a Word(<=32) via Word. +wordL32 :: forall a. (Bounded a, Integral a) => Parser a +wordL32 = word >>= \i -> + if fromIntegral (minBound :: a) <= i && i <= fromIntegral (maxBound :: a) + then pure $! fromIntegral i + else failParser "WordOutOfBounds" +{-# INLINE wordL32 #-} + +-- | Run the function on the parsed value, fail with 'empty' if the result is +-- @Nothing@. +-- +-- @since 0.1.1.0 +mapMaybe :: (a -> Maybe b) -> Parser a -> Parser b +mapMaybe f p = p >>= maybe empty pure . f +{-# INLINE mapMaybe #-} + +-- | Run the function on the parsed value, fail with 'fail' if the result is a +-- @Left@. +-- +-- @since 0.1.1.0 +mapOrFail :: (a -> Either String b) -> Parser a -> Parser b +mapOrFail f p = p >>= either fail pure . f +{-# INLINE mapOrFail #-} + -- | Binary search. The array must be sorted by key. -binarySearch :: B.ByteString -> A.Array AST.KeyValue -> Maybe AST.Value +binarySearch + :: B.ByteString + -> A.Array AST.KeyValue + -> (# (# #) | (# X.Int#, AST.Value #) #) binarySearch k a = go 0 (A.sizeofArray a) where - go l r | l == r = Nothing + go l r | l == r = (# (# #) | #) go l r = case compare k k' of LT -> go l m - EQ -> Just v + EQ -> (# | (# case m of X.I# m# -> m#, 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 #-} +-- binarySearch returns an unboxed type, which serves as an equivalent of +-- Maybe (Int, Value). This is to avoid allocating the (,) and the I#. This +-- won't be necessary if GHC gets +-- https://gitlab.haskell.org/ghc/ghc/-/issues/14259. +-- A (not-so-good) alternative is to inline binarySearch. +------------------------------ +-- Documentation +------------------------------ + +-- $quick +-- Decoding is done using parsers. This module defines parsers that can be +-- composed to build 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 the @File@ parser +-- will fail to decode. +-- +-- >>> D.decode fileParser "d4:hash4:xxxx4:tagsl4:work6:backupee" +-- Left "KeyNotFound \"size\"" +-- +-- For more examples, see the [Recipes](#g:recipes) section at the end of this +-- page. + + -- $recipes -- Recipes for some common and uncommon usages. -- @@ -358,11 +636,26 @@ -- >>> D.decode colorParser "5:black" -- Left "Fail: unknown color" -- --- === Decode differently based on dict contents +-- === Decode a dict, failing on leftover keys -- -- @ --- import Control.Applicative ('(<|>)') +-- data File = File { name :: Text, size :: Int } deriving Show -- +-- fileParser :: D.'Parser' File +-- fileParser = D.'dict'' $ +-- File +-- \<$> D.'field'' "name" D.'text' +-- \<*> D.'field'' "size" D.'int' +-- @ +-- +-- >>> D.decode fileParser "d4:name9:hello.txt4:sizei32ee" +-- Right (File {name = "hello.txt", size = 32}) +-- >>> D.decode fileParser "d6:hiddeni1e4:name9:hello.txt4:sizei32ee" +-- Left "UnrecognizedKey \"hidden\"" +-- +-- === Decode differently based on dict contents +-- +-- @ -- data Response = Response -- { id_ :: Int -- , result :: Either Text ByteString @@ -371,14 +664,15 @@ -- 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' +-- status <- D.'field' "status" D.'string' +-- case status of +-- "failure" -> do +-- reason <- D.'field' "reason" D.'text' +-- pure $ Response id_ (Left reason) +-- "success" -> do +-- data_ <- D.'field' "data" D.'string' +-- pure $ Response id_ (Right data_) +-- _ -> D.'fail' "unknown status" -- @ -- -- >>> D.decode responseParser "d2:idi42e6:reason12:unauthorized6:status7:failuree" @@ -399,5 +693,20 @@ -- @ -- -- >>> D.decode fileParser "d8:metadatad4:infod4:sizei32eee4:name9:hello.txte" +-- Right (File {name = "hello.txt", size = 32}) +-- +-- === Decode a heterogeneous list +-- +-- @ +-- data File = File { name :: Text, size :: Int } deriving Show +-- +-- fileParser :: D.'Parser' File +-- fileParser = D.'list'' $ +-- File +-- \<$> D.'elem' D.'text' +-- \<*> D.'elem' D.'int' +-- @ +-- +-- >>> D.decode fileParser "l9:hello.txti32ee" -- Right (File {name = "hello.txt", size = 32}) -- diff --git a/src/Data/Bencode/Encode.hs b/src/Data/Bencode/Encode.hs --- a/src/Data/Bencode/Encode.hs +++ b/src/Data/Bencode/Encode.hs @@ -2,85 +2,51 @@ -- | -- 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 + -- * Quick start + -- $quick + + -- * Encoding Encoding , toBuilder - -- * Primary encoders + -- * String encoders , string - , integer - , list - , dict - - -- * More encoders , text + + -- * Integer encoders + , integer , int + , int64 + , int32 + , int16 + , int8 , word + , word64 + , word32 + , word16 + , word8 + + -- * List encoders + , list + + -- * Dictionary encoders + , dict , field , dict' , FieldEncodings + + -- * Miscellaneous , value - -- * Recipes - -- - -- $recipes + -- * Recipes #recipes# + -- $recipes ) where +import Data.Int import Data.Monoid (Endo(..)) +import Data.Word import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.Map as M @@ -103,37 +69,39 @@ -- | Encode an integer as a Bencode integer. integer :: Integer -> Encoding -integer i = Encoding $ BB.char7 'i' <> BB.integerDec i <> BB.char7 'e' +integer = integer_ BB.integerDec -- | 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' +{-# INLINE list #-} -- | 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)) +{-# INLINE dict #-} -- | 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 +{-# INLINE text #-} -- 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' +int = integer_ BB.intDec -- | Encode a @Word@ as a Bencode integer. word :: Word -> Encoding -word w = Encoding $ BB.char7 'i' <> BB.wordDec w <> BB.char7 'e' - --- Option 1 +word = integer_ BB.wordDec --- | A key-value encoding for a Bencode dictionary. +-- | A key-value encoding for a Bencode dictionary. Convert to an @Encoding@ +-- with 'dict''. field :: B.ByteString -> (a -> Encoding) -> a -> FieldEncodings field k enc v = FE (Endo ((k, enc v):)) {-# INLINE field #-} @@ -144,8 +112,9 @@ -- arbitrary key-value pair among them will be encoded and the rest discarded. dict' :: FieldEncodings -> Encoding dict' = dict id . M.fromList . ($ []) . appEndo . unFE +{-# INLINE dict' #-} --- | Key-value encodings for a Bencode dictionary. +-- | Key-value encodings for a Bencode dictionary. See 'field' and 'dict''. newtype FieldEncodings = FE { unFE :: Endo [(B.ByteString, Encoding)] } deriving (Semigroup, Monoid) -- FieldEncodings is not just a type alias because there are multiple ways to @@ -160,8 +129,111 @@ List vs -> list value vs Dict vs -> dict value vs +-- | Encode an @Int64@ as a Bencode integer. +-- +-- @since 0.1.1.0 +int64 :: Int64 -> Encoding +int64 = integer_ BB.int64Dec + +-- | Encode an @Int32@ as a Bencode integer. +-- +-- @since 0.1.1.0 +int32 :: Int32 -> Encoding +int32 = integer_ BB.int32Dec + +-- | Encode an @Int16@ as a Bencode integer. +-- +-- @since 0.1.1.0 +int16 :: Int16 -> Encoding +int16 = integer_ BB.int16Dec + +-- | Encode an @Int8@ as a Bencode integer. +-- +-- @since 0.1.1.0 +int8 :: Int8 -> Encoding +int8 = integer_ BB.int8Dec + +-- | Encode a @Word64@ as a Bencode integer. +-- +-- @since 0.1.1.0 +word64 :: Word64 -> Encoding +word64 = integer_ BB.word64Dec + +-- | Encode a @Word32@ as a Bencode integer. +-- +-- @since 0.1.1.0 +word32 :: Word32 -> Encoding +word32 = integer_ BB.word32Dec + +-- | Encode a @Word16@ as a Bencode integer. +-- +-- @since 0.1.1.0 +word16 :: Word16 -> Encoding +word16 = integer_ BB.word16Dec + +-- | Encode a @Word8@ as a Bencode integer. +-- +-- @since 0.1.1.0 +word8 :: Word8 -> Encoding +word8 = integer_ BB.word8Dec + +integer_ :: (a -> BB.Builder) -> a -> Encoding +integer_ f = \x -> Encoding $ BB.char7 'i' <> f x <> BB.char7 'e' +{-# INLINE integer_ #-} + +------------------------------ +-- Documentation +------------------------------ + +-- $quick +-- Encoding is done using encoders. An encoder is simply a function from a +-- Haskell type to 'Encoding'. This module defines encoders that can be +-- composed to build 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](#g:recipes) section at the end of this +-- page. + + -- $recipes --- Recipies for some common and uncommon usages. +-- Recipes for some common and uncommon usages. -- -- The following preface is assumed. -- @@ -169,6 +241,7 @@ -- {-# LANGUAGE OverloadedStrings #-} -- import Data.ByteString.Builder (toLazyByteString) -- import Data.Text (Text) +-- import qualified Data.Vector as V -- import qualified Data.Bencode.Encode as E -- -- toLBS = toLazyByteString . E.toBuilder @@ -244,4 +317,17 @@ -- -- >>> toLBS $ encodeFile $ File "hello.txt" 32 -- "d8:metadatad4:infod4:sizei32eee4:name9:hello.txte" +-- +-- === Encode as a heterogeneous list +-- +-- @ +-- data File = File { name :: Text, size :: Int } +-- +-- encodeFile :: File -> E.'Encoding' +-- encodeFile (File name size) =\ +-- E.'list' id $ V.fromList [E.'text' name, E.'int' size] +-- @ +-- +-- >>> toLBS $ encodeFile $ File "hello.txt" 32 +-- "l9:hello.txti32ee" -- diff --git a/src/Data/Bencode/Type.hs b/src/Data/Bencode/Type.hs --- a/src/Data/Bencode/Type.hs +++ b/src/Data/Bencode/Type.hs @@ -1,9 +1,8 @@ -- | -- 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. +-- See "Data.Bencode.Decode" and "Data.Bencode.Encode" to perform decoding +-- and encoding. -- module Data.Bencode.Type ( Value(..) diff --git a/src/Data/Bencode/Util.hs b/src/Data/Bencode/Util.hs --- a/src/Data/Bencode/Util.hs +++ b/src/Data/Bencode/Util.hs @@ -1,58 +1,100 @@ +{-# LANGUAGE BangPatterns #-} module Data.Bencode.Util - ( readKnownNaturalAsInt + ( arrayFromRevListN + , readKnownNaturalAsInt + , readKnownNaturalAsInt64 , readKnownNaturalAsWord + , readKnownNaturalAsWord64 ) where import Data.Bits +import Data.Int +import Data.Word import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.Primitive.Array as A +-- | Create an array from a list in reverse order. The list length must be n. +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" + -- | 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 +readKnownNaturalAsInt = readInt maxIntLen where - (sl,sr) = B.splitAt (maxIntLen - 1) s - n = B.foldl' (\acc d -> acc * 10 + fromIntegral d - 48) 0 sl + maxIntLen = case finiteBitSize (0 :: Int) of + 32 -> 10 + 64 -> 19 + _ -> error "unsupported word size" +{-# INLINE readKnownNaturalAsInt #-} -iMaxDiv10 :: Int -iMaxDiv10 = maxBound `div` 10 +-- | Similar to 'readKnownNaturalAsInt', for 'Int64'. +readKnownNaturalAsInt64 :: Bool -> B.ByteString -> Maybe Int64 +readKnownNaturalAsInt64 = readInt 19 +{-# INLINE readKnownNaturalAsInt64 #-} -maxIntLen :: Int -maxIntLen = case finiteBitSize (0 :: Int) of - 32 -> 10 - 64 -> 19 - _ -> error "unsupported word size" +readInt :: (Bounded a, Integral a) => Int -> Bool -> B.ByteString -> Maybe a +readInt maxLen neg s = if neg then fmap negate n else n + where + -- last digit of maxBound = 7, minBound = 8 + n = readWord maxLen (maxBound `div` 10) (7 + fromIntegral (fromEnum neg)) s +{-# INLINE readInt #-} -- | 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 +readKnownNaturalAsWord = readWord maxWordLen (maxBound `div` 10) 5 where - (sl,sr) = B.splitAt (maxWordLen - 1) s - n = B.foldl' (\acc d -> acc * 10 + fromIntegral d - 48) 0 sl + -- last digit of maxBound = 5 + maxWordLen = case finiteBitSize (0 :: Word) of + 32 -> 10 + 64 -> 20 + _ -> error "unsupported word size" +{-# INLINE readKnownNaturalAsWord #-} -wMaxDiv10 :: Word -wMaxDiv10 = maxBound `div` 10 +-- | Similar to 'readKnownNaturalAsWord', for 'Word64'. +readKnownNaturalAsWord64 :: B.ByteString -> Maybe Word64 +readKnownNaturalAsWord64 = readWord 20 (maxBound `div` 10) 5 +{-# INLINE readKnownNaturalAsWord64 #-} -maxWordLen :: Int -maxWordLen = case finiteBitSize (0 :: Word) of - 32 -> 10 - 64 -> 20 - _ -> error "unsupported word size" +-- maxLen must be > 0! +readWord :: (Bounded a, Integral a) => Int -> a -> a -> B.ByteString -> Maybe a +readWord maxLen maxValueDiv10 maxValueMod10 s = + case compare (B.length s) maxLen of + LT -> Just $! readFull' s + EQ -> + let n = readFull (B.unsafeInit s) + d = digitToI (B.unsafeLast s) + in if n < maxValueDiv10 || n == maxValueDiv10 && d <= maxValueMod10 + then Just $! n*10 + d + else Nothing + GT -> Nothing +{-# INLINE readWord #-} + +readFull :: Integral a => B.ByteString -> a +readFull = B.foldl' (\acc c -> acc * 10 + digitToI c) 0 +{-# INLINE readFull #-} + +-- Same as readFull but avoids +-- https://gitlab.haskell.org/ghc/ghc/-/issues/24203 +readFull' :: Integral a => B.ByteString -> a +readFull' s = case B.unsnoc s of + Nothing -> 0 + Just (s',c) -> readFull s' * 10 + digitToI c +{-# INLINE readFull' #-} + +digitToI :: Integral a => Word8 -> a +digitToI c = fromIntegral c - 48 +{-# INLINE digitToI #-} diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,15 +1,19 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- Arbitrary instances import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck +import Control.Applicative +import Control.Monad 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.Foldable as F import qualified Data.Map as M import qualified Data.Vector as V @@ -18,7 +22,7 @@ import qualified Data.Bencode.Type as Ben main :: IO () -main = defaultMain $ testGroup "Tests" +main = defaultMain $ localOption (QuickCheckTests 2000) $ testGroup "Tests" [ astTests , decodeTests , encodeTests @@ -102,81 +106,144 @@ [ 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" + , testCase "type mismatch integer" $ D.decode D.string "i0e" @?= Left "TypeMismatch String Integer" + , testCase "type mismatch list" $ D.decode D.string "le" @?= Left "TypeMismatch String List" + , testCase "type mismatch dict" $ 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" + , testCase "type mismatch string" $ D.decode D.integer "0:" @?= Left "TypeMismatch Integer String" + , testCase "type mismatch list" $ D.decode D.integer "le" @?= Left "TypeMismatch Integer List" + , testCase "type mismatch dict" $ 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" + , testCase "elem type mismatch" $ D.decode (D.list D.string) "l3:fooi1ee" @?= Left "TypeMismatch String Integer" + , testCase "type mismatch string" $ D.decode (D.list D.value) "0:" @?= Left "TypeMismatch List String" + , testCase "type mismatch integer" $ D.decode (D.list D.value) "i0e" @?= Left "TypeMismatch List Integer" + , testCase "type mismatch dict" $ 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" + , testCase "value type mismatch" $ D.decode (D.dict D.string) "d3:foo3:bar3:quxi1ee" @?= Left "TypeMismatch String Integer" + , testCase "type mismatch string" $ D.decode (D.dict D.value) "0:" @?= Left "TypeMismatch Dict String" + , testCase "type mismatch integer" $ D.decode (D.dict D.value) "i0e" @?= Left "TypeMismatch Dict Integer" + , testCase "type mismatch list" $ 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 "" $ 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" + , testCase "invalid UTF-8" $ D.decode D.text "2:\xd8\x00" @?= Left "UTF8DecodeFailure" + , testCase "type mismatch integer" $ D.decode D.text "i0e" @?= Left "TypeMismatch String Integer" + , testCase "type mismatch list" $ D.decode D.text"le" @?= Left "TypeMismatch String List" + , testCase "type mismatch dict" $ 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" + , testGroupIntegral "int" False D.int + , testGroupIntegral "int64" False D.int64 + , testGroupIntegral "int32" False D.int32 + , testGroupIntegral "int16" False D.int16 + , testGroupIntegral "int8" False D.int8 + , testGroupIntegral "word" True D.word + , testGroupIntegral "word64" True D.word64 + , testGroupIntegral "word32" True D.word32 + , testGroupIntegral "word16" True D.word16 + , testGroupIntegral "word8" True D.word8 + , testGroup "index" + [ testCase "l3:fooe" $ D.decode (D.index 0 D.string) "l3:fooe" @?= Right "foo" + , testCase "out of bounds -1" $ D.decode (D.index (-1) D.string) "l3:fooe" @?= Left "IndexOutOfBounds" + , testCase "out of bounds 1" $ D.decode (D.index 1 D.string) "l3:fooe" @?= Left "IndexOutOfBounds" + , testCase "li2ee" $ D.decode (D.index 0 D.string) "li2ee" @?= Left "TypeMismatch String Integer" + , let p = D.index 5 (Left <$> D.string) + <|> D.index 0 (Right <$> D.int) + <|> D.index 1 (Left <$> D.string) in + testCase "alt" $ D.decode p "l3:foo3:bare" @?= Right (Left "bar") + , let p = (,,) <$> D.index 1 D.string + <*> D.index 2 (D.list D.integer) + <*> D.index 0 D.integer in + testCase "multiple types" $ D.decode p "li1e3:twoli0ei0ei0eee" @?= Right ("two", [0,0,0], 1) + , testCase "type mismatch string" $ D.decode (D.index 0 D.string) "0:" @?= Left "TypeMismatch List String" + , testCase "type mismatch integer" $ D.decode (D.index 0 D.string) "i0e" @?= Left "TypeMismatch List Integer" + , testCase "type mismatch dict" $ D.decode (D.index 0 D.string) "de" @?= Left "TypeMismatch List 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 "list'" + [ testCase "l3:fooe" $ D.decode (D.list' $ D.elem D.string) "l3:fooe" @?= Right "foo" + , testCase "too short" $ D.decode (D.list' $ D.elem D.string) "le" @?= Left "ListElemsExhausted" + , testCase "too long" $ D.decode (D.list' $ D.elem D.string) "l3:foo3:bare" @?= Left "ListElemsLeft" + , testCase "elem type mismatch" $ D.decode (D.list' $ D.elem D.string) "li2ee" @?= Left "TypeMismatch String Integer" + , let p = D.list' $ + D.elem D.string + <|> D.elem D.integer *> D.elem D.string in + testCase "Elem alt" $ D.decode p "li1e3:fooe" @?= Right "foo" + , let p = D.list' $ + (,,) <$> D.elem D.integer + <*> D.elem D.string + <*> D.elem (D.list D.integer) in + testCase "multiple types" $ D.decode p "li1e3:twoli0ei0ei0eee" @?= Right (1, "two", [0,0,0]) + , testCase "type mismatch string" $ D.decode (D.list' $ pure ()) "0:" @?= Left "TypeMismatch List String" + , testCase "type mismatch integer" $ D.decode (D.list' $ pure ()) "i0e" @?= Left "TypeMismatch List Integer" + , testCase "type mismatch dict" $ D.decode (D.list' $ pure ()) "de" @?= Left "TypeMismatch List 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" + [ testCase "key not found" $ D.decode (D.field "foo" D.string) "de" @?= Left "KeyNotFound \"foo\"" + , testCase "d3:foo3:bare" $ D.decode (D.field "foo" D.string) "d3:foo3:bare" @?= Right "bar" + , testCase "extra keys ignored" $ D.decode (D.field "baz" D.string) "d3:baz3:qux3:foo3:bare" @?= Right "qux" + , let p = D.field "bar" D.string <|> D.field "foo" D.string in + testCase "alt" $ D.decode p "d3:foo3:bare" @?= Right "bar" + , testCase "value type mismatch" $ 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]) + testCase "multiple types" $ D.decode p "d3:onei1e5:threeli0ei0ei0ee3:two3:twoe" @?= Right (1, "two", [0,0,0]) + , testCase "type mismatch string" $ D.decode (D.field "foo" D.string) "0:" @?= Left "TypeMismatch Dict String" + , testCase "type mismatch integer" $ D.decode (D.field "foo" D.string) "i0e" @?= Left "TypeMismatch Dict Integer" + , testCase "type mismatch list" $ D.decode (D.field "foo" D.string) "le" @?= Left "TypeMismatch Dict List" ] + , testGroup "dict'" + [ testCase "key not found" $ D.decode (D.dict' $ D.field' "foo" D.string) "de" @?= Left "KeyNotFound \"foo\"" + , testCase "d3:foo3:bare" $ D.decode (D.dict' $ D.field' "foo" D.string) "d3:foo3:bare" @?= Right "bar" + , testCase "extra keys fails" $ D.decode (D.dict' $ D.field' "baz" D.string) "d3:baz3:qux3:foo3:bare" @?= Left "UnrecognizedKey \"foo\"" + , let p = D.dict' $ D.field' "bar" D.string <|> D.field' "foo" D.string in + testCase "Fields alt" $ D.decode p "d3:foo3:bare" @?= Right "bar" + , testCase "value type mismatch" $ D.decode (D.dict' $ D.field' "foo" D.string) "d3:fooi2ee" @?= Left "TypeMismatch String Integer" + , let p = D.dict' $ + (,,) <$> D.field' "one" D.integer + <*> D.field' "two" D.string + <*> D.field' "three" (D.list D.integer) in + testCase "multiple types" $ D.decode p "d3:onei1e5:threeli0ei0ei0ee3:two3:twoe" @?= Right (1, "two", [0,0,0]) + , testCase "type mismatch string" $ D.decode (D.dict' $ pure ()) "0:" @?= Left "TypeMismatch Dict String" + , testCase "type mismatch integer" $ D.decode (D.dict' $ pure ()) "i0e" @?= Left "TypeMismatch Dict Integer" + , testCase "type mismatch list" $ D.decode (D.dict' $ pure ()) "le" @?= Left "TypeMismatch Dict List" + ] , testGroup "fail" [ testCase "3:foo" $ D.decode (D.fail "error!" :: D.Parser B.ByteString) "3:foo" @?= Left "Fail: error!" ] ] + where + testGroupIntegral :: forall a. (Bounded a, Integral a, Show a) + => String -> Bool -> D.Parser a -> TestTree + testGroupIntegral name isW p = testGroup name + [ testCase "i0e" $ D.decode p "i0e" @?= Right 0 + , testCase "i32e" $ D.decode p "i32e" @?= Right 32 + , testCase "i-32e" $ D.decode p "i-32e" @?= if isW then Left oob else Right (-32) + , testCase "minBound-1" $ D.decode p ("i" <> BC.pack (show (minBoundI - 1)) <> "e") @?= Left oob + , testCase "minBound" $ D.decode p ("i" <> BC.pack (show minBoundI) <> "e") @?= Right minBound + , testCase "maxBound" $ D.decode p ("i" <> BC.pack (show maxBoundI) <> "e") @?= Right maxBound + , testCase "maxBound+1" $ D.decode p ("i" <> BC.pack (show (maxBoundI + 1)) <> "e") @?= Left oob + , testCase "i98765432109876543210e" $ D.decode p "i98765432109876543210e" @?= Left oob + , testCase "type mismatch string" $ D.decode p "0:" @?= Left "TypeMismatch Integer String" + , testCase "type mismatch list" $ D.decode p "le" @?= Left "TypeMismatch Integer List" + , testCase "type mismatch dict" $ D.decode p "de" @?= Left "TypeMismatch Integer Dict" + ] + where + minBoundI, maxBoundI :: Integer + minBoundI = fromIntegral (minBound :: a) + maxBoundI = fromIntegral (maxBound :: a) + oob = if isW then "WordOutOfBounds" else "IntOutOfBounds" encodeTests :: TestTree encodeTests = testGroup "Encode" @@ -202,19 +269,16 @@ [ 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" - ] + , testGroupIntegral "int" False E.int + , testGroupIntegral "int64" False E.int64 + , testGroupIntegral "int32" False E.int32 + , testGroupIntegral "int16" False E.int16 + , testGroupIntegral "int8" False E.int8 + , testGroupIntegral "word" True E.word + , testGroupIntegral "word64" True E.word64 + , testGroupIntegral "word32" True E.word32 + , testGroupIntegral "word16" True E.word16 + , testGroupIntegral "word8" True E.word8 , testGroup "field" [ testCase "{}" $ enc id (E.dict' mempty) @?= "de" , let e = E.dict' $ @@ -224,20 +288,32 @@ testCase "{one:1,two:two,three:[0,0,0]}" $ enc id e @?= "d3:onei1e5:threeli0ei0ei0ee3:two3:twoe" ] ] + where + testGroupIntegral :: forall a. (Bounded a, Integral a, Show a) + => String -> Bool -> (a -> E.Encoding) -> TestTree + testGroupIntegral name isW e = testGroup name $ + [ testCase "0" $ enc e 0 @?= "i0e" + , testCase "32" $ enc e 32 @?= "i32e" + ] ++ + [ testCase "-32" $ enc e (-32) @?= "i-32e" | not isW ] ++ + [ testCase "minBound" $ enc e minBound @?= "i" <> BLC.pack (show (minBound :: a)) <> "e" + , testCase "maxBound" $ enc e maxBound @?= "i" <> BLC.pack (show (maxBound :: a)) <> "e" + ] 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 +encodeDecodeTests = testGroup "EncodeDecode, decode . encode == Right" + [ testProperty "Value" $ + \v -> (D.decode D.value . toBS . E.value) v === Right v + , testProperty "Val" $ + \(TV t v) -> + (fmap Clean . D.decode (mkParser t) . toBS . encodeVal) v + === Right (Clean v) ] + where + toBS = BL.toStrict . BB.toLazyByteString . E.toBuilder instance Arbitrary Ben.Value where arbitrary = sized $ \n -> do @@ -250,16 +326,214 @@ then Ben.String <$> arbitrary else Ben.Integer <$> arbitrary go n = do - ns <- partition n >>= shuffle + ns <- partition (n-1) 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) + shrink (Ben.String s) = Ben.String <$> shrink s + shrink (Ben.Integer i) = Ben.Integer <$> shrink i + shrink (Ben.List xs) = Ben.List . V.fromList <$> shrink (V.toList xs) + shrink (Ben.Dict kxs) = Ben.Dict . M.fromList <$> shrink (M.toList kxs) + instance Arbitrary B.ByteString where arbitrary = B.pack <$> arbitrary + shrink = map B.pack . shrink . B.unpack + +-- The code below generates some random "type" (Typ) together with a "value" +-- (Val) of that type. +-- The Typ describes how to generate a value and how to parse a value. +-- A Val can have some junk which will be encoded but not decoded, to test that +-- parsers which are supposed to ignore data do so (field and index). + +data Val + = String !B.ByteString + | Integer !Integer + | List !(V.Vector Val) + | Dict !(M.Map B.ByteString Val) + | Int !Int + | Word !Word + | Fields + !(M.Map B.ByteString Val) -- ^ contents + !(M.Map B.ByteString Val) -- ^ junk + | Fields' !(M.Map B.ByteString Val) + | Index + !(V.Vector Val) -- ^ contents and junk together + !(V.Vector Int) -- ^ indices of the contents + | Elems !(V.Vector Val) + deriving Show + +data Sized a = Sized !Int !a deriving Show + +data Typ + = TString + | TInteger + | TList !(Sized Typ) + | TDict !(Sized Typ) + | TInt + | TWord + | TFields !(M.Map B.ByteString (Sized Typ)) !(M.Map B.ByteString (Sized Typ)) + | TFields' !(M.Map B.ByteString (Sized Typ)) + | TIndex !(V.Vector (Sized Typ)) !(V.Vector Int) + | TElems !(V.Vector (Sized Typ)) + deriving Show + +-- Newtype to compare the non-junk parts of a Val via Eq. +newtype Clean = Clean Val deriving Show + +instance Eq Clean where + Clean x1 == Clean x2 = case (x1,x2) of + (String s1 , String s2 ) -> s1 == s2 + (Integer i1 , Integer i2 ) -> i1 == i2 + (List l1 , List l2 ) -> fmap Clean l1 == fmap Clean l2 + (Dict d1 , Dict d2 ) -> fmap Clean d1 == fmap Clean d2 + (Int i1 , Int i2 ) -> i1 == i2 + (Word w1 , Word w2 ) -> w1 == w2 + (Fields m1 _ , Fields m2 _ ) -> fmap Clean m1 == fmap Clean m2 + (Fields' m1 , Fields' m2 ) -> fmap Clean m1 == fmap Clean m2 + (Index l1 is1, Index l2 is2) -> fmap Clean (V.backpermute l1 is1) == + fmap Clean (V.backpermute l2 is2) + (Elems l1 , Elems l2 ) -> fmap Clean l1 == fmap Clean l2 + _ -> False + +encodeVal :: Val -> E.Encoding +encodeVal x = case x of + String s -> E.string s + Integer i -> E.integer i + List l -> E.list encodeVal l + Dict d -> E.dict encodeVal d + Int i -> E.int i + Word w -> E.word w + Fields m1 m2 -> E.dict' $ + M.foldMapWithKey (\k -> E.field k encodeVal) (m1 <> m2) + Fields' m -> E.dict' $ M.foldMapWithKey (\k -> E.field k encodeVal) m + Index l _ -> E.list encodeVal l + Elems l -> E.list encodeVal l + +mkParser :: Sized Typ -> D.Parser Val +mkParser (Sized _ t) = case t of + TString -> String <$> D.string + TInteger -> Integer <$> D.integer + TList t' -> List <$> D.list (mkParser t') + TDict t' -> Dict <$> D.dict (mkParser t') + TInt -> Int <$> D.int + TWord -> Word <$> D.word + TFields m1 _ -> + Fields <$> M.traverseWithKey (\k -> D.field k . mkParser) m1 + <*> pure M.empty + TFields' m -> + Fields' <$> D.dict' (M.traverseWithKey (\k -> D.field' k . mkParser) m) + TIndex l is -> + Index <$> traverse (\i -> D.index i (mkParser (l V.! i))) is + <*> pure (V.generate (V.length is) id) + TElems l -> Elems <$> D.list' (traverse (D.elem . mkParser) l) + +data TV = TV !(Sized Typ) !Val deriving Show + +instance Arbitrary TV where + arbitrary = sized $ \n -> do + n' <- choose (0,n) + go (n'+1) + where + go n = do + t <- genTyp n + v <- genVal n t + pure $ TV t v + +-- | Generate a Typ and its minimum number of nodes, such that it is <= n. +genTyp :: Int -> Gen (Sized Typ) +genTyp n | n <= 0 = error "genTyp n | n <= 0" +genTyp 1 = Sized 1 <$> elements [TString, TInteger, TInt, TWord] +genTyp n = oneof + [ Sized 1 . TList <$> genTypMany (n-1) + , Sized 1 . TDict <$> genTypMany (n-1) + , do + n' <- choose (0, n-1) + Sized n1 m1 <- goMap n' + Sized n2 m2 <- goMap (n-1-n') + pure $ Sized (n1+n2+1) (TFields m1 m2) + , do + Sized n1 m1 <- goMap (n-1) + pure $ Sized (n1+1) (TFields' m1) + , do + Sized n1 v1 <- goVec (n-1) + is <- V.fromList <$> sublistOf [0 .. V.length v1 - 1] + pure $ Sized (n1+1) (TIndex v1 is) + , do + Sized n1 v1 <- goVec (n-1) + pure $ Sized (n1+1) (TElems v1) + ] + where + genTypMany m = partition m >>= genTyp . minimum + goMap m = do + ms <- partition m + kvs <- traverse (\m' -> (,) <$> arbitrary <*> genTyp m') ms + pure $ sizedF (M.fromList kvs) + goVec m = do + ms <- partition m + sizedF . V.fromList <$> traverse genTyp ms + sizedF xs = Sized (sizeF xs) xs + +-- | Generate a value with at most n nodes +genVal :: Int -> Sized Typ -> Gen Val +genVal n (Sized n' _) | n < n' = error "genVal: n < size of type" +genVal n (Sized _ t) = case t of + TString -> String <$> arbitrary + TInteger -> Integer <$> arbitrary + TList t' -> List . V.fromList <$> goMany (n-1) t' + TDict t' -> do + vs <- goMany (n-1) t' + ks <- replicateM (length vs) arbitrary + pure $ Dict $ M.fromList $ zip ks vs + TInt -> Int <$> arbitrary + TWord -> Word <$> arbitrary + TFields mp1 mp2 -> do + ~[m1,m2] <- partitionWithMin (n-1) [sizeF mp1, sizeF mp2] + Fields <$> goMap m1 mp1 <*> goMap m2 mp2 + TFields' mp -> Fields' <$> goMap (n-1) mp + TIndex l is -> flip Index is . V.fromList <$> goVec (n-1) (F.toList l) + TElems l -> Elems . V.fromList <$> goVec (n-1) (F.toList l) + where + goMany m t'@(Sized n' _) = do + ns <- partitionWithMin m (replicate (div m n') n') + traverse (flip genVal t') ns + goMap m mp = do + ns <- partitionWithMin m (sizes (M.elems mp)) + M.fromList . zip (M.keys mp) <$> zipWithM genVal ns (M.elems mp) + goVec m l = do + ns <- partitionWithMin m (sizes l) + zipWithM genVal ns l + +sizeF :: Foldable f => f (Sized a) -> Int +sizeF = F.foldl' (\acc (Sized n _) -> acc + n) 0 + +sizes :: Functor f => f (Sized a) -> f Int +sizes = fmap (\(Sized n _) -> n) + +-- | Partition m into pieces with a given minimum value of each piece. +partitionWithMin :: Int -> [Int] -> Gen [Int] +partitionWithMin m xs | m < sum xs = error "partitionWithMin: n not big enough" +partitionWithMin m xs = zipWith (+) xs <$> partitionN (length xs) (m - sum xs) + +-- | Partition m into n pieces. Pieces can be 0. +partitionN :: Int -> Int -> Gen [Int] +partitionN n0 _ | n0 <= 0 = error "partitionN: n <= 0" +partitionN n0 m0 = go n0 m0 >>= shuffle + where + go 1 m = pure [m] + go n 0 = (0:) <$> go (n-1) 0 + go n m = do + x <- choose (1,m) + (x:) <$> go (n-1) (m-x) + +-- | Partition into pieces >= 0 +partition :: Int -> Gen [Int] +partition m0 | m0 < 0 = error "partition: m < 0" +partition m0 = go m0 >>= shuffle + where + go 0 = pure [] + go m = do + x <- choose (1,m) + (x:) <$> go (m-x)