src/FuncTorrent/Bencode.hs

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