src/FuncTorrent/Bencode.hs

   1 {-
   2  - Copyright (C) 2015-2016 Ramakrishnan Muthukrishnan <ram@rkrishnan.org>
   3  -
   4  - This file is part of FuncTorrent.
   5  -
   6  - FuncTorrent is free software; you can redistribute it and/or modify
   7  - it under the terms of the GNU General Public License as published by
   8  - the Free Software Foundation; either version 3 of the License, or
   9  - (at your option) any later version.
  10  -
  11  - FuncTorrent is distributed in the hope that it will be useful,
  12  - but WITHOUT ANY WARRANTY; without even the implied warranty of
  13  - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14  - GNU General Public License for more details.
  15  -
  16  - You should have received a copy of the GNU General Public License
  17  - along with FuncTorrent; if not,  see <http://www.gnu.org/licenses/>
  18  -}
  19
  20 {-# LANGUAGE OverloadedStrings #-}
  21 module FuncTorrent.Bencode
  22     (BVal(..)
  23     , bValToInteger
  24     , bstrToString
  25     , decode
  26     , encode
  27     ) where
  28
  29 import Prelude hiding (length, concat)
  30
  31 import Data.ByteString (ByteString, length, concat)
  32 import Data.ByteString.Char8 (unpack, pack)
  33 import Data.Char (isLetter, isAscii)
  34 import Data.Map.Strict (Map, fromList, toList)
  35 import Text.ParserCombinators.Parsec
  36 import qualified Text.Parsec.ByteString as ParsecBS
  37 import Test.QuickCheck
  38
  39 data BVal = Bint Integer
  40           | Bstr ByteString
  41           | Blist [BVal]
  42           | Bdict (Map String BVal)
  43             deriving (Ord, Eq, Show)
  44
  45 genNonEmptyString :: Gen String
  46 genNonEmptyString = arbitrary `suchThat` (\s -> ((s /= "") &&
  47                                                  (all isAscii s) &&
  48                                                  (all isLetter s)))
  49
  50 instance Arbitrary ByteString where
  51   arbitrary = pack <$> arbitrary
  52
  53 instance Arbitrary BVal where
  54   arbitrary = sized bval
  55               where
  56                 bval :: Int -> Gen BVal
  57                 bval 0 = oneof [ Bint <$> arbitrary
  58                                , Bstr <$> arbitrary]
  59                 bval n = oneof [ Bint <$> arbitrary
  60                                , Bstr <$> arbitrary
  61                                , Blist <$> vectorOf n (bval (n `div` 4))
  62                                , do keys <- vectorOf n genNonEmptyString
  63                                     vals <- vectorOf n (bval (n `div` 4))
  64                                     return $ Bdict $ fromList $ zip keys vals ]
  65
  66 -- getters
  67 bValToInteger :: BVal -> Maybe Integer
  68 bValToInteger (Bint x) = Just x
  69 bValToInteger _        = Nothing
  70
  71 bValToBytestr :: BVal  -> Maybe ByteString
  72 bValToBytestr (Bstr bs) = Just bs
  73 bValToBytestr _         = Nothing
  74
  75 bstrToString :: BVal -> Maybe String
  76 bstrToString bval     = unpack <$> bValToBytestr bval
  77
  78 -- $setup
  79 -- >>> import Data.Either
  80
  81 -- | parse strings
  82 --
  83 -- >>> parse bencStr "Bstr" (pack "4:spam")
  84 -- Right "spam"
  85 -- >>> parse bencStr "Bstr" (pack "0:")
  86 -- Right ""
  87 -- >>> parse bencStr "Bstr" (pack "0:hello")
  88 -- Right ""
  89 --
  90 bencStr :: ParsecBS.Parser ByteString
  91 bencStr = do ds <- many1 digit <* char ':'
  92              s <- count (read ds) anyChar
  93              return (pack s)
  94
  95 -- | parse integers
  96 --
  97 -- >>> parse bencInt "Bint" (pack "i42e")
  98 -- Right 42
  99 -- >>> parse bencInt "Bint" (pack "i123e")
 100 -- Right 123
 101 -- >>> parse bencInt "Bint" (pack "i1e")
 102 -- Right 1
 103 -- >>> parse bencInt "Bint" (pack "i0e")
 104 -- Right 0
 105 -- >>> parse bencInt "Bint" (pack "i-1e")
 106 -- Right (-1)
 107 -- >>> isLeft $ parse bencInt "Bint" (pack "i01e")
 108 -- True
 109 -- >>> isLeft $ parse bencInt "Bint" (pack "i00e")
 110 -- True
 111 -- >>> isLeft $ parse bencInt "Bint" (pack "i002e")
 112 -- True
 113 bencInt :: ParsecBS.Parser Integer
 114 bencInt = do ds <- between (char 'i') (char 'e') numbers
 115              return (read ds)
 116                where numbers = do d' <- char '-' <|> digit
 117                                   ds' <- many digit
 118                                   parseNumber d' ds'
 119                      parseNumber '0' []  = return "0"
 120                      parseNumber '0' _ = unexpected "numbers cannot be left-padded with zeros"
 121                      parseNumber '-' []  = unexpected "sign without any digits"
 122                      parseNumber '-' (d'':_) | d'' == '0' = unexpected "numbers cannot be left-padded with zeros"
 123                      parseNumber d'' ds'' = return (d'':ds'')
 124
 125 -- | parse lists
 126 --
 127 -- >>> parse bencList "Blist" (pack "le")
 128 -- Right []
 129 -- >>> parse bencList "Blist" (pack "l4:spam4:eggse")
 130 -- Right [Bstr "spam",Bstr "eggs"]
 131 -- >>> parse bencList "Blist" (pack "l4:spami42ee")
 132 -- Right [Bstr "spam",Bint 42]
 133 -- >>> parse bencList "Blist" (pack "l4:spam4:eggsli42eee")
 134 -- Right [Bstr "spam",Bstr "eggs",Blist [Bint 42]]
 135 bencList :: ParsecBS.Parser [BVal]
 136 bencList = between (char 'l') (char 'e') (many bencVal)
 137
 138 -- | parse dict
 139 --
 140 -- >>> parse bencDict "Bdict" (pack "de")
 141 -- Right (fromList [])
 142 -- >>> parse bencDict "Bdict" (pack "d3:cow3:moo4:spam4:eggse")
 143 -- Right (fromList [("cow",Bstr "moo"),("spam",Bstr "eggs")])
 144 -- >>> parse bencDict "Bdict" (pack "d4:spaml1:a1:bee")
 145 -- Right (fromList [("spam",Blist [Bstr "a",Bstr "b"])])
 146 -- >>> parse bencDict "Bdict" (pack "d9:publisher3:bob17:publisher-webpage15:www.example.com18:publisher.location4:homee")
 147 -- Right (fromList [("publisher",Bstr "bob"),("publisher-webpage",Bstr "www.example.com"),("publisher.location",Bstr "home")])
 148 bencDict :: ParsecBS.Parser (Map String BVal)
 149 bencDict = between (char 'd') (char 'e') $ fromList <$> many kvpair
 150   where kvpair = do k <- bdictKey
 151                     v <- bencVal
 152                     return (k, v)
 153         bdictKey = do
 154           ds <- many1 digit <* char ':'
 155           s <- count (read ds) anyChar
 156           return s
 157
 158
 159 bencVal :: ParsecBS.Parser BVal
 160 bencVal = Bstr <$> bencStr <|>
 161           Bint <$> bencInt <|>
 162           Blist <$> bencList <|>
 163           Bdict <$> bencDict
 164
 165 decode :: ByteString -> Either ParseError BVal
 166 decode = parse bencVal "BVal"
 167
 168 -- Encode BVal into a bencoded ByteString. Inverse of decode
 169
 170 -- TODO: Use builders and lazy byte string to get O(1) concatenation over O(n)
 171 -- provided by lists.
 172
 173 -- TODO: encode . decode pair might be a good candidate for Quickcheck.
 174 -- | encode bencoded-values
 175 --
 176 -- >>> encode (Bstr (pack ""))
 177 -- "0:"
 178 -- >>> encode (Bstr (pack "spam"))
 179 -- "4:spam"
 180 -- >>> encode (Bint 0)
 181 -- "i0e"
 182 -- >>> encode (Bint 42)
 183 -- "i42e"
 184 -- >>> encode (Blist [(Bstr (pack "spam")), (Bstr (pack "eggs"))])
 185 -- "l4:spam4:eggse"
 186 -- >>> encode (Blist [])
 187 -- "le"
 188 -- >>> encode (Bdict (fromList [("spam", Bstr $ pack "eggs")]))
 189 -- "d4:spam4:eggse"
 190 encode :: BVal -> ByteString
 191 encode (Bstr bs) = pack $ show (length bs) ++ ":" ++ unpack bs
 192 encode (Bint i) = pack $ "i" ++ show i ++ "e"
 193 encode (Blist xs) = concat ["l", concat $ map encode xs, "e"]
 194 encode (Bdict d) = concat ["d", concat kvlist, "e"]
 195     where
 196       kvlist :: [ByteString]
 197       kvlist = [encPair kv | kv <- toList d]
 198       encPair (k, v) = concat [encode (Bstr (pack k)), encode v]