src/FuncTorrent/Bencode.hs

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