src/FuncTorrent/Bencode.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module FuncTorrent.Bencode
   3     (BVal(..),
   4      InfoDict,
   5      encode,
   6      decode
   7     ) where
   8
   9 import Prelude hiding (length, concat)
  10
  11 import Control.Applicative ((<*))
  12 import Data.ByteString (ByteString, length, concat)
  13 import Data.ByteString.Char8 (unpack, pack)
  14 import Data.Functor ((<$>))
  15 import Data.Map.Strict (Map, fromList, keys, (!))
  16 import Text.ParserCombinators.Parsec
  17 import qualified Text.Parsec.ByteString as ParsecBS
  18
  19 data BVal = Bint Integer
  20           | Bstr ByteString
  21           | Blist [BVal]
  22           | Bdict InfoDict
  23             deriving (Ord, Eq, Show)
  24
  25 type InfoDict = Map String BVal
  26
  27 -- $setup
  28 -- >>> import Data.Either
  29
  30 -- | parse strings
  31 --
  32 -- >>> parse bencStr "Bstr" (pack "4:spam")
  33 -- Right "spam"
  34 -- >>> parse bencStr "Bstr" (pack "0:")
  35 -- Right ""
  36 -- >>> parse bencStr "Bstr" (pack "0:hello")
  37 -- Right ""
  38 --
  39 bencStr :: ParsecBS.Parser ByteString
  40 bencStr = do _ <- spaces
  41              ds <- many1 digit <* char ':'
  42              s <- count (read ds) anyChar
  43              return (pack s)
  44
  45 -- | parse integers
  46 --
  47 -- >>> parse bencInt "Bint" (pack "i42e")
  48 -- Right 42
  49 -- >>> parse bencInt "Bint" (pack "i123e")
  50 -- Right 123
  51 -- >>> parse bencInt "Bint" (pack "i1e")
  52 -- Right 1
  53 -- >>> parse bencInt "Bint" (pack "i0e")
  54 -- Right 0
  55 -- >>> parse bencInt "Bint" (pack "i-1e")
  56 -- Right (-1)
  57 -- >>> isLeft $ parse bencInt "Bint" (pack "i01e")
  58 -- True
  59 -- >>> isLeft $ parse bencInt "Bint" (pack "i00e")
  60 -- True
  61 -- >>> isLeft $ parse bencInt "Bint" (pack "i002e")
  62 -- True
  63 bencInt :: ParsecBS.Parser Integer
  64 bencInt = do _ <- spaces
  65              ds <- between (char 'i') (char 'e') numbers
  66              return (read ds)
  67                where numbers = do d' <- char '-' <|> digit
  68                                   ds' <- many digit
  69                                   parseNumber d' ds'
  70                      parseNumber '0' []  = return "0"
  71                      parseNumber '0' _ = unexpected "numbers cannot be left-padded with zeros"
  72                      parseNumber '-' []  = unexpected "sign without any digits"
  73                      parseNumber '-' (d'':_) | d'' == '0' = unexpected "numbers cannot be left-padded with zeros"
  74                      parseNumber d'' ds'' = return (d'':ds'')
  75
  76 -- | parse lists
  77 --
  78 -- >>> parse bencList "Blist" (pack "le")
  79 -- Right []
  80 -- >>> parse bencList "Blist" (pack "l4:spam4:eggse")
  81 -- Right [Bstr "spam",Bstr "eggs"]
  82 -- >>> parse bencList "Blist" (pack "l4:spami42ee")
  83 -- Right [Bstr "spam",Bint 42]
  84 -- >>> parse bencList "Blist" (pack "l4:spam4:eggsli42eee")
  85 -- Right [Bstr "spam",Bstr "eggs",Blist [Bint 42]]
  86 bencList :: ParsecBS.Parser [BVal]
  87 bencList = do _ <- spaces
  88               between (char 'l') (char 'e') (many bencVal)
  89
  90 -- | parse dict
  91 --
  92 -- >>> parse bencDict "Bdict" (pack "de")
  93 -- Right (fromList [])
  94 -- >>> parse bencDict "Bdict" (pack "d3:cow3:moo4:spam4:eggse")
  95 -- Right (fromList [("cow",Bstr "moo"),("spam",Bstr "eggs")])
  96 -- >>> parse bencDict "Bdict" (pack "d4:spaml1:a1:bee")
  97 -- Right (fromList [("spam",Blist [Bstr "a",Bstr "b"])])
  98 -- >>> parse bencDict "Bdict" (pack "d9:publisher3:bob17:publisher-webpage15:www.example.com18:publisher.location4:homee")
  99 -- Right (fromList [("publisher",Bstr "bob"),("publisher-webpage",Bstr "www.example.com"),("publisher.location",Bstr "home")])
 100 bencDict :: ParsecBS.Parser InfoDict
 101 bencDict = between (char 'd') (char 'e') $ fromList <$> many kvpair
 102   where kvpair = do k <- bencStr
 103                     v <- bencVal
 104                     return (unpack k, v)
 105
 106 bencVal :: ParsecBS.Parser BVal
 107 bencVal = Bstr <$> bencStr <|>
 108           Bint <$> bencInt <|>
 109           Blist <$> bencList <|>
 110           Bdict <$> bencDict
 111
 112 decode :: ByteString -> Either ParseError BVal
 113 decode = parse bencVal "BVal"
 114
 115 -- Encode BVal into a bencoded ByteString. Inverse of decode
 116
 117 -- TODO: Use builders and lazy byte string to get O(1) concatenation over O(n)
 118 -- provided by lists.
 119
 120 -- TODO: encode . decode pair might be a good candidate for Quickcheck.
 121 -- | encode bencoded-values
 122 --
 123 -- >>> encode (Bstr (pack ""))
 124 -- "0:"
 125 -- >>> encode (Bstr (pack "spam"))
 126 -- "4:spam"
 127 -- >>> encode (Bint 0)
 128 -- "i0e"
 129 -- >>> encode (Bint 42)
 130 -- "i42e"
 131 -- >>> encode (Blist [(Bstr (pack "spam")), (Bstr (pack "eggs"))])
 132 -- "l4:spam4:eggse"
 133 -- >>> encode (Blist [])
 134 -- "le"
 135 -- >>> encode (Bdict (fromList [("spam", Bstr $ pack "eggs")]))
 136 -- "d4:spam4:eggse"
 137 encode :: BVal -> ByteString
 138 encode (Bstr bs) = pack $ show (length bs) ++ ":" ++ unpack bs
 139 encode (Bint i) = pack $ "i" ++ show i ++ "e"
 140 encode (Blist xs) = pack $ "l" ++ unpack (concat $ map encode xs) ++ "e"
 141 encode (Bdict d) = concat [concat ["d", encode . Bstr . pack $ k , encode (d ! k) , "e"] | k <- keys d]