-----------------------------------------------------------------------------
-- |
-- Module      :  Data.BEncode
-- Copyright   :  (c) 2005 Jesper Louis Andersen <jlouis@mongers.org>
--                    2006 Lemmih <lemmih@gmail.com>
-- License     :  BSD3
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  believed to be stable
-- Portability :  portable
--
-- Provides a BEncode data type is well as functions for converting this
-- data type to and from a String.
--
-- Also supplies a number of properties which the module must satisfy.
-----------------------------------------------------------------------------
module Data.BEncode
  (
   -- * Data types
   BEncode(..),
   -- * Functions
   bRead,
   bShow,
   bPack
  )
where

import qualified Data.Map as Map
import Data.Map (Map)
import Data.List (sort)
import Text.ParserCombinators.Parsec
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Char8 as BS
import Data.Binary

import Data.BEncode.Lexer ( Token (..), lexer )


type BParser a = GenParser Token () a

{- | The B-coding defines an abstract syntax tree given as a simple
     data type here
-}
data BEncode = BInt Integer
             | BString L.ByteString
             | BList [BEncode]
             | BDict (Map String BEncode)
               deriving (BEncode -> BEncode -> Bool
(BEncode -> BEncode -> Bool)
-> (BEncode -> BEncode -> Bool) -> Eq BEncode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BEncode -> BEncode -> Bool
$c/= :: BEncode -> BEncode -> Bool
== :: BEncode -> BEncode -> Bool
$c== :: BEncode -> BEncode -> Bool
Eq, Eq BEncode
Eq BEncode =>
(BEncode -> BEncode -> Ordering)
-> (BEncode -> BEncode -> Bool)
-> (BEncode -> BEncode -> Bool)
-> (BEncode -> BEncode -> Bool)
-> (BEncode -> BEncode -> Bool)
-> (BEncode -> BEncode -> BEncode)
-> (BEncode -> BEncode -> BEncode)
-> Ord BEncode
BEncode -> BEncode -> Bool
BEncode -> BEncode -> Ordering
BEncode -> BEncode -> BEncode
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BEncode -> BEncode -> BEncode
$cmin :: BEncode -> BEncode -> BEncode
max :: BEncode -> BEncode -> BEncode
$cmax :: BEncode -> BEncode -> BEncode
>= :: BEncode -> BEncode -> Bool
$c>= :: BEncode -> BEncode -> Bool
> :: BEncode -> BEncode -> Bool
$c> :: BEncode -> BEncode -> Bool
<= :: BEncode -> BEncode -> Bool
$c<= :: BEncode -> BEncode -> Bool
< :: BEncode -> BEncode -> Bool
$c< :: BEncode -> BEncode -> Bool
compare :: BEncode -> BEncode -> Ordering
$ccompare :: BEncode -> BEncode -> Ordering
$cp1Ord :: Eq BEncode
Ord, Int -> BEncode -> ShowS
[BEncode] -> ShowS
BEncode -> String
(Int -> BEncode -> ShowS)
-> (BEncode -> String) -> ([BEncode] -> ShowS) -> Show BEncode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BEncode] -> ShowS
$cshowList :: [BEncode] -> ShowS
show :: BEncode -> String
$cshow :: BEncode -> String
showsPrec :: Int -> BEncode -> ShowS
$cshowsPrec :: Int -> BEncode -> ShowS
Show)

instance Binary BEncode where
    put :: BEncode -> Put
put e :: BEncode
e = ByteString -> Put
forall t. Binary t => t -> Put
put ([ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ BEncode -> ByteString
bPack BEncode
e)
    get :: Get BEncode
get = do ByteString
s <- Get ByteString
forall t. Binary t => Get t
get
             case ByteString -> Maybe BEncode
bRead ([ByteString] -> ByteString
L.fromChunks [ByteString
s]) of
               Just e :: BEncode
e  -> BEncode -> Get BEncode
forall (m :: * -> *) a. Monad m => a -> m a
return BEncode
e
               Nothing -> String -> Get BEncode
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Failed to parse BEncoded data"

-- Source position is pretty useless in BEncoded data. FIXME
updatePos :: (SourcePos -> Token -> [Token] -> SourcePos)
updatePos :: SourcePos -> Token -> [Token] -> SourcePos
updatePos pos :: SourcePos
pos _ _ = SourcePos
pos

bToken :: Token -> BParser ()
bToken :: Token -> BParser ()
bToken t :: Token
t = (Token -> String)
-> (SourcePos -> Token -> [Token] -> SourcePos)
-> (Token -> Maybe ())
-> BParser ()
forall s (m :: * -> *) t a u.
Stream s m t =>
(t -> String)
-> (SourcePos -> t -> s -> SourcePos)
-> (t -> Maybe a)
-> ParsecT s u m a
tokenPrim Token -> String
forall a. Show a => a -> String
show SourcePos -> Token -> [Token] -> SourcePos
updatePos Token -> Maybe ()
fn
    where fn :: Token -> Maybe ()
fn t' :: Token
t' | Token
t' Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
t = () -> Maybe ()
forall a. a -> Maybe a
Just ()
          fn _ = Maybe ()
forall a. Maybe a
Nothing

token' :: (Token -> Maybe a) -> BParser a
token' :: (Token -> Maybe a) -> BParser a
token' = (Token -> String)
-> (SourcePos -> Token -> [Token] -> SourcePos)
-> (Token -> Maybe a)
-> BParser a
forall s (m :: * -> *) t a u.
Stream s m t =>
(t -> String)
-> (SourcePos -> t -> s -> SourcePos)
-> (t -> Maybe a)
-> ParsecT s u m a
tokenPrim Token -> String
forall a. Show a => a -> String
show SourcePos -> Token -> [Token] -> SourcePos
updatePos

tnumber :: BParser Integer
tnumber :: BParser Integer
tnumber = (Token -> Maybe Integer) -> BParser Integer
forall a. (Token -> Maybe a) -> BParser a
token' Token -> Maybe Integer
fn
    where fn :: Token -> Maybe Integer
fn (TNumber i :: Integer
i) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i
          fn _ = Maybe Integer
forall a. Maybe a
Nothing

tstring :: BParser L.ByteString
tstring :: BParser ByteString
tstring = (Token -> Maybe ByteString) -> BParser ByteString
forall a. (Token -> Maybe a) -> BParser a
token' Token -> Maybe ByteString
fn
    where fn :: Token -> Maybe ByteString
fn (TString str :: ByteString
str) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
str
          fn _ = Maybe ByteString
forall a. Maybe a
Nothing

withToken :: Token -> BParser a -> BParser a
withToken :: Token -> BParser a -> BParser a
withToken tok :: Token
tok
    = BParser () -> BParser () -> BParser a -> BParser a
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (Token -> BParser ()
bToken Token
tok) (Token -> BParser ()
bToken Token
TEnd)

--------------------------------------------------------------
--------------------------------------------------------------

bInt :: BParser BEncode
bInt :: BParser BEncode
bInt = Token -> BParser BEncode -> BParser BEncode
forall a. Token -> BParser a -> BParser a
withToken Token
TInt (BParser BEncode -> BParser BEncode)
-> BParser BEncode -> BParser BEncode
forall a b. (a -> b) -> a -> b
$ (Integer -> BEncode) -> BParser Integer -> BParser BEncode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> BEncode
BInt BParser Integer
tnumber

bString :: BParser BEncode
bString :: BParser BEncode
bString = (ByteString -> BEncode) -> BParser ByteString -> BParser BEncode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> BEncode
BString BParser ByteString
tstring

bList :: BParser BEncode
bList :: BParser BEncode
bList = Token -> BParser BEncode -> BParser BEncode
forall a. Token -> BParser a -> BParser a
withToken Token
TList (BParser BEncode -> BParser BEncode)
-> BParser BEncode -> BParser BEncode
forall a b. (a -> b) -> a -> b
$ ([BEncode] -> BEncode)
-> ParsecT [Token] () Identity [BEncode] -> BParser BEncode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [BEncode] -> BEncode
BList (BParser BEncode -> ParsecT [Token] () Identity [BEncode]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many BParser BEncode
bParse)

bDict :: BParser BEncode
bDict :: BParser BEncode
bDict = Token -> BParser BEncode -> BParser BEncode
forall a. Token -> BParser a -> BParser a
withToken Token
TDict (BParser BEncode -> BParser BEncode)
-> BParser BEncode -> BParser BEncode
forall a b. (a -> b) -> a -> b
$
    ([(String, BEncode)] -> BEncode)
-> ParsecT [Token] () Identity [(String, BEncode)]
-> BParser BEncode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map String BEncode -> BEncode
BDict (Map String BEncode -> BEncode)
-> ([(String, BEncode)] -> Map String BEncode)
-> [(String, BEncode)]
-> BEncode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, BEncode)] -> Map String BEncode
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList) ([(String, BEncode)]
-> ParsecT [Token] () Identity [(String, BEncode)]
forall a (m :: * -> *). (Ord a, MonadFail m) => [a] -> m [a]
checkList ([(String, BEncode)]
 -> ParsecT [Token] () Identity [(String, BEncode)])
-> ParsecT [Token] () Identity [(String, BEncode)]
-> ParsecT [Token] () Identity [(String, BEncode)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ParsecT [Token] () Identity (String, BEncode)
-> ParsecT [Token] () Identity [(String, BEncode)]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT [Token] () Identity (String, BEncode)
bAssocList)
    where checkList :: [a] -> m [a]
checkList lst :: [a]
lst = if [a]
lst [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
/= [a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
lst
                            then String -> m [a]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "dictionary not sorted"
                            else [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
lst
          bAssocList :: ParsecT [Token] () Identity (String, BEncode)
bAssocList
              = do ByteString
str <- BParser ByteString
tstring
                   BEncode
value <- BParser BEncode
bParse
                   (String, BEncode) -> ParsecT [Token] () Identity (String, BEncode)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> String
L.unpack ByteString
str,BEncode
value)

bParse :: BParser BEncode
bParse :: BParser BEncode
bParse = BParser BEncode
bDict BParser BEncode -> BParser BEncode -> BParser BEncode
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> BParser BEncode
bList BParser BEncode -> BParser BEncode -> BParser BEncode
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> BParser BEncode
bString BParser BEncode -> BParser BEncode -> BParser BEncode
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> BParser BEncode
bInt

{- | bRead is a conversion routine. It assumes a B-coded string as input
     and attempts a parse of it into a BEncode data type
-}
bRead :: L.ByteString -> Maybe BEncode
bRead :: ByteString -> Maybe BEncode
bRead str :: ByteString
str = case BParser BEncode -> String -> [Token] -> Either ParseError BEncode
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse BParser BEncode
bParse "" (ByteString -> [Token]
lexer ByteString
str) of
              Left _err :: ParseError
_err -> Maybe BEncode
forall a. Maybe a
Nothing
              Right b :: BEncode
b   -> BEncode -> Maybe BEncode
forall a. a -> Maybe a
Just BEncode
b

-- | Render a BEncode structure to a B-coded string
bShow :: BEncode -> ShowS
bShow :: BEncode -> ShowS
bShow = BEncode -> ShowS
bShow'
  where
    sc :: Char -> ShowS
sc = Char -> ShowS
showChar
    ss :: String -> ShowS
ss = String -> ShowS
showString
    sKV :: (String, BEncode) -> ShowS
sKV (k :: String
k,v :: BEncode
v) = String -> Int -> ShowS
forall a. Show a => String -> a -> ShowS
sString String
k (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
k) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BEncode -> ShowS
bShow' BEncode
v
    sDict :: Map String BEncode -> ShowS
sDict dict :: Map String BEncode
dict = ((String, BEncode) -> ShowS -> ShowS)
-> ShowS -> [(String, BEncode)] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (ShowS -> ShowS -> ShowS)
-> ((String, BEncode) -> ShowS)
-> (String, BEncode)
-> ShowS
-> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, BEncode) -> ShowS
sKV) ShowS
forall a. a -> a
id (Map String BEncode -> [(String, BEncode)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map String BEncode
dict)
    sList :: [BEncode] -> ShowS
sList = (BEncode -> ShowS -> ShowS) -> ShowS -> [BEncode] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (ShowS -> ShowS -> ShowS)
-> (BEncode -> ShowS) -> BEncode -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BEncode -> ShowS
bShow') ShowS
forall a. a -> a
id
    sString :: String -> a -> ShowS
sString str :: String
str len :: a
len = a -> ShowS
forall a. Show a => a -> ShowS
shows a
len ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc ':' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
str
    bShow' :: BEncode -> ShowS
bShow' b :: BEncode
b =
      case BEncode
b of
        BInt i :: Integer
i    -> Char -> ShowS
sc 'i' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> ShowS
forall a. Show a => a -> ShowS
shows Integer
i ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc 'e'
        BString s :: ByteString
s -> String -> Int64 -> ShowS
forall a. Show a => String -> a -> ShowS
sString (ByteString -> String
L.unpack ByteString
s) (ByteString -> Int64
L.length ByteString
s)
        BList bl :: [BEncode]
bl  -> Char -> ShowS
sc 'l' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [BEncode] -> ShowS
sList [BEncode]
bl ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc 'e'
        BDict bd :: Map String BEncode
bd  -> Char -> ShowS
sc 'd' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String BEncode -> ShowS
sDict Map String BEncode
bd ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc 'e'

bPack :: BEncode -> L.ByteString
bPack :: BEncode -> ByteString
bPack be :: BEncode
be = [ByteString] -> ByteString
L.fromChunks (BEncode -> [ByteString] -> [ByteString]
bPack' BEncode
be [])
    where intTag :: ByteString
intTag = String -> ByteString
BS.pack "i"
          colonTag :: ByteString
colonTag = String -> ByteString
BS.pack ":"
          endTag :: ByteString
endTag = String -> ByteString
BS.pack "e"
          listTag :: ByteString
listTag = String -> ByteString
BS.pack "l"
          dictTag :: ByteString
dictTag = String -> ByteString
BS.pack "d"
          sString :: ByteString -> [ByteString] -> [ByteString]
sString s :: ByteString
s r :: [ByteString]
r = String -> ByteString
BS.pack (Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
L.length ByteString
s)) ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString
colonTag ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString -> [ByteString]
L.toChunks ByteString
s [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString]
r
          bPack' :: BEncode -> [ByteString] -> [ByteString]
bPack' (BInt i :: Integer
i) r :: [ByteString]
r = ByteString
intTag ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: String -> ByteString
BS.pack (Integer -> String
forall a. Show a => a -> String
show Integer
i) ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString
endTag ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
r
          bPack' (BString s :: ByteString
s) r :: [ByteString]
r = ByteString -> [ByteString] -> [ByteString]
sString ByteString
s [ByteString]
r
          bPack' (BList bl :: [BEncode]
bl) r :: [ByteString]
r = ByteString
listTag ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: (BEncode -> [ByteString] -> [ByteString])
-> [ByteString] -> [BEncode] -> [ByteString]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr BEncode -> [ByteString] -> [ByteString]
bPack' (ByteString
endTag ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
r) [BEncode]
bl
          bPack' (BDict bd :: Map String BEncode
bd) r :: [ByteString]
r = ByteString
dictTag ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ((String, BEncode) -> [ByteString] -> [ByteString])
-> [ByteString] -> [(String, BEncode)] -> [ByteString]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(k :: String
k,v :: BEncode
v) -> ByteString -> [ByteString] -> [ByteString]
sString (String -> ByteString
L.pack String
k) ([ByteString] -> [ByteString])
-> ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BEncode -> [ByteString] -> [ByteString]
bPack' BEncode
v) (ByteString
endTag ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
r) (Map String BEncode -> [(String, BEncode)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map String BEncode
bd)

--check be = bShow be "" == L.unpack (bPack be)