#if __GLASGOW_HASKELL__ >= 702
#endif
module Data.BEncode
(
BInteger
, BString
, BList
, BDict
, BKey
, BValue (..)
, ppBEncode
, BEncode (..)
, Result
, encode
, decode
, encoded
, decoded
, Assoc
, (-->)
, (-->?)
, fromAssocs
, fromAscAssocs
, decodingError
, reqKey
, optKey
, (>--)
, (>--?)
, isInteger
, isString
, isList
, isDict
, builder
, parser
) where
import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Data.Int
import Data.Maybe (mapMaybe)
import Data.Monoid
import Data.Foldable (foldMap)
import Data.Traversable (traverse)
import Data.Word (Word8, Word16, Word32, Word64, Word)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as P
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.ByteString.Lazy.Builder as B
import qualified Data.ByteString.Lazy.Builder.ASCII as B
import Data.ByteString.Internal as B (c2w, w2c)
import Data.Text (Text)
import qualified Data.Text.Encoding as T
import Data.Typeable
import Data.Version
import Text.PrettyPrint hiding ((<>))
import qualified Text.ParserCombinators.ReadP as ReadP
#if __GLASGOW_HASKELL__ >= 702
import GHC.Generics
#endif
type BInteger = Integer
type BString = ByteString
type BList = [BValue]
type BDict = Map BKey BValue
type BKey = ByteString
data BValue
= BInteger !BInteger
| BString !BString
| BList BList
| BDict BDict
deriving (Show, Read, Eq, Ord)
instance NFData BValue where
rnf (BInteger i) = rnf i
rnf (BString s) = rnf s
rnf (BList l) = rnf l
rnf (BDict d) = rnf d
type Result = Either String
class BEncode a where
toBEncode :: a -> BValue
#if __GLASGOW_HASKELL__ >= 702
default toBEncode
:: Generic a
=> GBEncodable (Rep a) BValue
=> a -> BValue
toBEncode = gto . from
#endif
fromBEncode :: BValue -> Result a
#if __GLASGOW_HASKELL__ >= 702
default fromBEncode
:: Generic a
=> GBEncodable (Rep a) BValue
=> BValue -> Result a
fromBEncode x = to <$> gfrom x
#endif
decodingError :: String -> Result a
decodingError s = Left ("fromBEncode: unable to decode " ++ s)
#if __GLASGOW_HASKELL__ >= 702
class GBEncodable f e where
gto :: f a -> e
gfrom :: e -> Result (f a)
instance BEncode f
=> GBEncodable (K1 R f) BValue where
gto = toBEncode . unK1
gfrom x = K1 <$> fromBEncode x
instance (Eq e, Monoid e)
=> GBEncodable U1 e where
gto U1 = mempty
gfrom x
| x == mempty = pure U1
| otherwise = decodingError "U1"
instance (GBEncodable a BList, GBEncodable b BList)
=> GBEncodable (a :*: b) BList where
gto (a :*: b) = gto a ++ gto b
gfrom (x : xs) = (:*:) <$> gfrom [x] <*> gfrom xs
gfrom [] = decodingError "generic: not enough fields"
instance (GBEncodable a BDict, GBEncodable b BDict)
=> GBEncodable (a :*: b) BDict where
gto (a :*: b) = gto a <> gto b
gfrom dict = (:*:) <$> gfrom dict <*> gfrom dict
instance (GBEncodable a e, GBEncodable b e)
=> GBEncodable (a :+: b) e where
gto (L1 x) = gto x
gto (R1 x) = gto x
gfrom x = case gfrom x of
Right lv -> return (L1 lv)
Left le -> do
case gfrom x of
Right rv -> return (R1 rv)
Left re -> decodingError $ "generic: both" ++ le ++ " " ++ re
selRename :: String -> String
selRename = dropWhile ('_'==)
gfromM1S :: forall c. Selector c
=> GBEncodable f BValue
=> BDict -> Result (M1 i c f p)
gfromM1S dict
| Just va <- M.lookup (BC.pack (selRename name)) dict = M1 <$> gfrom va
| otherwise = decodingError $ "generic: Selector not found " ++ show name
where
name = selName (error "gfromM1S: impossible" :: M1 i c f p)
instance (Selector s, GBEncodable f BValue)
=> GBEncodable (M1 S s f) BDict where
gto s @ (M1 x) = BC.pack (selRename (selName s)) `M.singleton` gto x
gfrom = gfromM1S
instance GBEncodable f BValue
=> GBEncodable (M1 S s f) BList where
gto (M1 x) = [gto x]
gfrom [x] = M1 <$> gfrom x
gfrom _ = decodingError "generic: empty selector"
instance (Constructor c, GBEncodable f BDict, GBEncodable f BList)
=> GBEncodable (M1 C c f) BValue where
gto con @ (M1 x)
| conIsRecord con = BDict (gto x)
| otherwise = BList (gto x)
gfrom (BDict a) = M1 <$> gfrom a
gfrom (BList a) = M1 <$> gfrom a
gfrom _ = decodingError "generic: Constr"
instance GBEncodable f e
=> GBEncodable (M1 D d f) e where
gto (M1 x) = gto x
gfrom x = M1 <$> gfrom x
#endif
instance BEncode BValue where
toBEncode = id
fromBEncode = pure
instance BEncode BInteger where
toBEncode = BInteger
fromBEncode (BInteger i) = pure i
fromBEncode _ = decodingError "BInteger"
instance BEncode BString where
toBEncode = BString
fromBEncode (BString s) = pure s
fromBEncode _ = decodingError "BString"
toBEncodeIntegral :: Integral a => a -> BValue
toBEncodeIntegral = BInteger . fromIntegral
fromBEncodeIntegral :: forall a. Typeable a => Integral a => BValue -> Result a
fromBEncodeIntegral (BInteger i) = pure (fromIntegral i)
fromBEncodeIntegral _
= decodingError $ show $ typeOf (undefined :: a)
instance BEncode Word8 where
toBEncode = toBEncodeIntegral
fromBEncode = fromBEncodeIntegral
instance BEncode Word16 where
toBEncode = toBEncodeIntegral
fromBEncode = fromBEncodeIntegral
instance BEncode Word32 where
toBEncode = toBEncodeIntegral
fromBEncode = fromBEncodeIntegral
instance BEncode Word64 where
toBEncode = toBEncodeIntegral
fromBEncode = fromBEncodeIntegral
instance BEncode Word where
toBEncode = toBEncodeIntegral
fromBEncode = fromBEncodeIntegral
instance BEncode Int8 where
toBEncode = toBEncodeIntegral
fromBEncode = fromBEncodeIntegral
instance BEncode Int16 where
toBEncode = toBEncodeIntegral
fromBEncode = fromBEncodeIntegral
instance BEncode Int32 where
toBEncode = toBEncodeIntegral
fromBEncode = fromBEncodeIntegral
instance BEncode Int64 where
toBEncode = toBEncodeIntegral
fromBEncode = fromBEncodeIntegral
instance BEncode Int where
toBEncode = toBEncodeIntegral
fromBEncode = fromBEncodeIntegral
instance BEncode Bool where
toBEncode = toBEncode . fromEnum
fromBEncode b = do
i <- fromBEncode b
case i :: Int of
0 -> return False
1 -> return True
_ -> decodingError "Bool"
instance BEncode Text where
toBEncode = toBEncode . T.encodeUtf8
fromBEncode b = T.decodeUtf8 <$> fromBEncode b
instance BEncode a => BEncode [a] where
toBEncode = BList . map toBEncode
fromBEncode (BList xs) = mapM fromBEncode xs
fromBEncode _ = decodingError "list"
instance BEncode a => BEncode (Map BKey a) where
toBEncode = BDict . M.map toBEncode
fromBEncode (BDict d) = traverse fromBEncode d
fromBEncode _ = decodingError "dictionary"
instance (Eq a, BEncode a) => BEncode (Set a) where
toBEncode = BList . map toBEncode . S.toAscList
fromBEncode (BList xs) = S.fromAscList <$> traverse fromBEncode xs
fromBEncode _ = decodingError "Data.Set"
instance BEncode Version where
toBEncode = toBEncode . BC.pack . showVersion
fromBEncode (BString bs)
| [(v, _)] <- ReadP.readP_to_S parseVersion (BC.unpack bs)
= return v
fromBEncode _ = decodingError "Data.Version"
instance BEncode () where
toBEncode () = BList []
fromBEncode (BList []) = Right ()
fromBEncode _ = decodingError "Unable to decode unit value"
instance (BEncode a, BEncode b) => BEncode (a, b) where
toBEncode (a, b) = BList [toBEncode a, toBEncode b]
fromBEncode (BList [a, b]) = (,) <$> fromBEncode a <*> fromBEncode b
fromBEncode _ = decodingError "Unable to decode a pair."
instance (BEncode a, BEncode b, BEncode c) => BEncode (a, b, c) where
toBEncode (a, b, c) = BList [toBEncode a, toBEncode b, toBEncode c]
fromBEncode (BList [a, b, c]) =
(,,) <$> fromBEncode a <*> fromBEncode b <*> fromBEncode c
fromBEncode _ = decodingError "Unable to decode a triple"
instance (BEncode a, BEncode b, BEncode c, BEncode d)
=> BEncode (a, b, c, d) where
toBEncode (a, b, c, d) = BList [ toBEncode a, toBEncode b
, toBEncode c, toBEncode d
]
fromBEncode (BList [a, b, c, d]) =
(,,,) <$> fromBEncode a <*> fromBEncode b
<*> fromBEncode c <*> fromBEncode d
fromBEncode _ = decodingError "Unable to decode a tuple4"
instance (BEncode a, BEncode b, BEncode c, BEncode d, BEncode e)
=> BEncode (a, b, c, d, e) where
toBEncode (a, b, c, d, e) = BList [ toBEncode a, toBEncode b
, toBEncode c, toBEncode d
, toBEncode e
]
fromBEncode (BList [a, b, c, d, e]) =
(,,,,) <$> fromBEncode a <*> fromBEncode b
<*> fromBEncode c <*> fromBEncode d <*> fromBEncode e
fromBEncode _ = decodingError "Unable to decode a tuple5"
newtype Assoc = Assoc { unAssoc :: Maybe (ByteString, BValue) }
(-->) :: BEncode a => BKey -> a -> Assoc
key --> val = Assoc $ Just $ (key, toBEncode val)
(-->?) :: BEncode a => BKey -> Maybe a -> Assoc
key -->? mval = Assoc $ ((,) key . toBEncode) <$> mval
fromAssocs :: [Assoc] -> BValue
fromAssocs = BDict . M.fromList . mapMaybe unAssoc
fromAscAssocs :: [Assoc] -> BValue
fromAscAssocs = BDict . M.fromAscList . mapMaybe unAssoc
reqKey :: BEncode a => BDict -> BKey -> Result a
reqKey d key
| Just b <- M.lookup key d = fromBEncode b
| otherwise = Left msg
where
msg = "required field `" ++ BC.unpack key ++ "' not found"
optKey :: BEncode a => BDict -> BKey -> Result (Maybe a)
optKey d key
| Just b <- M.lookup key d
, Right r <- fromBEncode b = return (Just r)
| otherwise = return Nothing
(>--) :: BEncode a => BDict -> BKey -> Result a
(>--) = reqKey
(>--?) :: BEncode a => BDict -> BKey -> Result (Maybe a)
(>--?) = optKey
isInteger :: BValue -> Bool
isInteger (BInteger _) = True
isInteger _ = False
isString :: BValue -> Bool
isString (BString _) = True
isString _ = False
isList :: BValue -> Bool
isList (BList _) = True
isList _ = False
isDict :: BValue -> Bool
isDict (BList _) = True
isDict _ = False
encode :: BValue -> Lazy.ByteString
encode = B.toLazyByteString . builder
decode :: ByteString -> Result BValue
decode = P.parseOnly parser
decoded :: BEncode a => ByteString -> Result a
decoded = decode >=> fromBEncode
encoded :: BEncode a => a -> Lazy.ByteString
encoded = encode . toBEncode
builder :: BValue -> B.Builder
builder = go
where
go (BInteger i) = B.word8 (c2w 'i') <>
B.integerDec i <>
B.word8 (c2w 'e')
go (BString s) = buildString s
go (BList l) = B.word8 (c2w 'l') <>
foldMap go l <>
B.word8 (c2w 'e')
go (BDict d) = B.word8 (c2w 'd') <>
foldMap mkKV (M.toAscList d) <>
B.word8 (c2w 'e')
where
mkKV (k, v) = buildString k <> go v
buildString s = B.intDec (B.length s) <>
B.word8 (c2w ':') <>
B.byteString s
parser :: Parser BValue
parser = valueP
where
valueP = do
mc <- P.peekChar
case mc of
Nothing -> fail "end of input"
Just c ->
case c of
di | di <= '9' -> BString <$> stringP
'i' -> P.anyChar *> ((BInteger <$> integerP) <* P.anyChar)
'l' -> P.anyChar *> ((BList <$> listBody) <* P.anyChar)
'd' -> do
P.anyChar
(BDict . M.fromDistinctAscList <$>
many ((,) <$> stringP <*> valueP))
<* P.anyChar
t -> fail ("bencode unknown tag: " ++ [t])
listBody = do
c <- P.peekChar
case c of
Just 'e' -> return []
_ -> (:) <$> valueP <*> listBody
stringP :: Parser ByteString
stringP = do
n <- P.decimal :: Parser Int
P.char ':'
P.take n
integerP :: Parser Integer
integerP = do
c <- P.peekChar
case c of
Just '-' -> do
P.anyChar
negate <$> P.decimal
_ -> P.decimal
ppBS :: ByteString -> Doc
ppBS = text . map w2c . B.unpack
ppBEncode :: BValue -> Doc
ppBEncode (BInteger i) = int $ fromIntegral i
ppBEncode (BString s) = ppBS s
ppBEncode (BList l) = brackets $ hsep $ punctuate comma $ map ppBEncode l
ppBEncode (BDict d)
= braces $ vcat $ punctuate comma $ map ppKV $ M.toAscList d
where
ppKV (k, v) = ppBS k <+> colon <+> ppBEncode v