src/FuncTorrent/Bencode.hs

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