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     , bValToBList
  24     , bValToBytestr
  25     , bValToInfoDict
  26     , bValToInteger
  27     , bstrToString
  28     , decode
  29     , encode
  30     ) where
  31
  32 import Prelude hiding (length, concat)
  33
  34 import Data.ByteString (ByteString, length, concat)
  35 import Data.ByteString.Char8 (unpack, pack)
  36 import Data.Char (isLetter, isNumber, isPrint, isAscii)
  37 import Data.Map.Strict (Map, fromList, toList)
  38 import Text.ParserCombinators.Parsec
  39 import qualified Text.Parsec.ByteString as ParsecBS
  40 import Test.QuickCheck
  41
  42 data BVal = Bint Integer
  43           | Bstr ByteString
  44           | Blist [BVal]
  45           | Bdict (Map String BVal)
  46             deriving (Ord, Eq, Show)
  47
  48 genNonEmptyString :: Gen String
  49 genNonEmptyString = arbitrary `suchThat` (\s -> ((s /= "") &&
  50                                                  (all isAscii s) &&
  51                                                  (all isLetter s)))
  52
  53 instance Arbitrary ByteString where
  54   arbitrary = pack <$> arbitrary
  55
  56 instance Arbitrary BVal where
  57   arbitrary = sized bval
  58               where
  59                 bval :: Int -> Gen BVal
  60                 bval 0 = oneof [ Bint <$> arbitrary
  61                                , Bstr <$> arbitrary]
  62                 bval n = oneof [ Bint <$> arbitrary
  63                                , Bstr <$> arbitrary
  64                                , Blist <$> vectorOf n (bval (n `div` 4))
  65                                , do keys <- vectorOf n genNonEmptyString
  66                                     vals <- vectorOf n (bval (n `div` 4))
  67                                     return $ Bdict $ fromList $ zip keys vals ]
  68
  69 -- getters
  70 bValToInteger :: BVal -> Maybe Integer
  71 bValToInteger (Bint x) = Just x
  72 bValToInteger _        = Nothing
  73
  74 bValToBytestr :: BVal  -> Maybe ByteString
  75 bValToBytestr (Bstr bs) = Just bs
  76 bValToBytestr _         = Nothing
  77
  78 bValToBList :: BVal    -> Maybe [BVal]
  79 bValToBList (Blist lst) = Just lst
  80 bValToBList _           = Nothing
  81
  82 bValToInfoDict :: BVal     -> Maybe (Map String BVal)
  83 bValToInfoDict (Bdict dict) = Just dict
  84 bValToInfoDict _            = Nothing
  85
  86 bstrToString :: BVal -> Maybe String
  87 bstrToString bval     = unpack <$> bValToBytestr bval
  88
  89 -- $setup
  90 -- >>> import Data.Either
  91
  92 -- | parse strings
  93 --
  94 -- >>> parse bencStr "Bstr" (pack "4:spam")
  95 -- Right "spam"
  96 -- >>> parse bencStr "Bstr" (pack "0:")
  97 -- Right ""
  98 -- >>> parse bencStr "Bstr" (pack "0:hello")
  99 -- Right ""
 100 --
 101 bencStr :: ParsecBS.Parser ByteString
 102 bencStr = do ds <- many1 digit <* char ':'
 103              s <- count (read ds) anyChar
 104              return (pack s)
 105
 106 -- | parse integers
 107 --
 108 -- >>> parse bencInt "Bint" (pack "i42e")
 109 -- Right 42
 110 -- >>> parse bencInt "Bint" (pack "i123e")
 111 -- Right 123
 112 -- >>> parse bencInt "Bint" (pack "i1e")
 113 -- Right 1
 114 -- >>> parse bencInt "Bint" (pack "i0e")
 115 -- Right 0
 116 -- >>> parse bencInt "Bint" (pack "i-1e")
 117 -- Right (-1)
 118 -- >>> isLeft $ parse bencInt "Bint" (pack "i01e")
 119 -- True
 120 -- >>> isLeft $ parse bencInt "Bint" (pack "i00e")
 121 -- True
 122 -- >>> isLeft $ parse bencInt "Bint" (pack "i002e")
 123 -- True
 124 bencInt :: ParsecBS.Parser Integer
 125 bencInt = do ds <- between (char 'i') (char 'e') numbers
 126              return (read ds)
 127                where numbers = do d' <- char '-' <|> digit
 128                                   ds' <- many digit
 129                                   parseNumber d' ds'
 130                      parseNumber '0' []  = return "0"
 131                      parseNumber '0' _ = unexpected "numbers cannot be left-padded with zeros"
 132                      parseNumber '-' []  = unexpected "sign without any digits"
 133                      parseNumber '-' (d'':_) | d'' == '0' = unexpected "numbers cannot be left-padded with zeros"
 134                      parseNumber d'' ds'' = return (d'':ds'')
 135
 136 -- | parse lists
 137 --
 138 -- >>> parse bencList "Blist" (pack "le")
 139 -- Right []
 140 -- >>> parse bencList "Blist" (pack "l4:spam4:eggse")
 141 -- Right [Bstr "spam",Bstr "eggs"]
 142 -- >>> parse bencList "Blist" (pack "l4:spami42ee")
 143 -- Right [Bstr "spam",Bint 42]
 144 -- >>> parse bencList "Blist" (pack "l4:spam4:eggsli42eee")
 145 -- Right [Bstr "spam",Bstr "eggs",Blist [Bint 42]]
 146 bencList :: ParsecBS.Parser [BVal]
 147 bencList = between (char 'l') (char 'e') (many bencVal)
 148
 149 -- | parse dict
 150 --
 151 -- >>> parse bencDict "Bdict" (pack "de")
 152 -- Right (fromList [])
 153 -- >>> parse bencDict "Bdict" (pack "d3:cow3:moo4:spam4:eggse")
 154 -- Right (fromList [("cow",Bstr "moo"),("spam",Bstr "eggs")])
 155 -- >>> parse bencDict "Bdict" (pack "d4:spaml1:a1:bee")
 156 -- Right (fromList [("spam",Blist [Bstr "a",Bstr "b"])])
 157 -- >>> parse bencDict "Bdict" (pack "d9:publisher3:bob17:publisher-webpage15:www.example.com18:publisher.location4:homee")
 158 -- Right (fromList [("publisher",Bstr "bob"),("publisher-webpage",Bstr "www.example.com"),("publisher.location",Bstr "home")])
 159 bencDict :: ParsecBS.Parser (Map String BVal)
 160 bencDict = between (char 'd') (char 'e') $ fromList <$> many kvpair
 161   where kvpair = do k <- bdictKey
 162                     v <- bencVal
 163                     return (k, v)
 164         bdictKey = do
 165           ds <- many1 digit <* char ':'
 166           s <- count (read ds) alphaNum
 167           return s
 168
 169
 170 bencVal :: ParsecBS.Parser BVal
 171 bencVal = Bstr <$> bencStr <|>
 172           Bint <$> bencInt <|>
 173           Blist <$> bencList <|>
 174           Bdict <$> bencDict
 175
 176 decode :: ByteString -> Either ParseError BVal
 177 decode = parse bencVal "BVal"
 178
 179 -- Encode BVal into a bencoded ByteString. Inverse of decode
 180
 181 -- TODO: Use builders and lazy byte string to get O(1) concatenation over O(n)
 182 -- provided by lists.
 183
 184 -- TODO: encode . decode pair might be a good candidate for Quickcheck.
 185 -- | encode bencoded-values
 186 --
 187 -- >>> encode (Bstr (pack ""))
 188 -- "0:"
 189 -- >>> encode (Bstr (pack "spam"))
 190 -- "4:spam"
 191 -- >>> encode (Bint 0)
 192 -- "i0e"
 193 -- >>> encode (Bint 42)
 194 -- "i42e"
 195 -- >>> encode (Blist [(Bstr (pack "spam")), (Bstr (pack "eggs"))])
 196 -- "l4:spam4:eggse"
 197 -- >>> encode (Blist [])
 198 -- "le"
 199 -- >>> encode (Bdict (fromList [("spam", Bstr $ pack "eggs")]))
 200 -- "d4:spam4:eggse"
 201 encode :: BVal -> ByteString
 202 encode (Bstr bs) = pack $ show (length bs) ++ ":" ++ unpack bs
 203 encode (Bint i) = pack $ "i" ++ show i ++ "e"
 204 encode (Blist xs) = concat ["l", concat $ map encode xs, "e"]
 205 encode (Bdict d) = concat ["d", concat kvlist, "e"]
 206     where
 207       kvlist :: [ByteString]
 208       kvlist = [encPair kv | kv <- toList d]
 209       encPair (k, v) = concat [encode (Bstr (pack k)), encode v]