-----------------------------------------------------------------------------
-- |
-- 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
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
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
Ord, Int -> BEncode -> ShowS
[BEncode] -> ShowS
BEncode -> String
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 BEncode
e = forall t. Binary t => t -> Put
put ([ByteString] -> ByteString
BS.concat forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks forall a b. (a -> b) -> a -> b
$ BEncode -> ByteString
bPack BEncode
e)
    get :: Get BEncode
get = do ByteString
s <- forall t. Binary t => Get t
get
             case ByteString -> Maybe BEncode
bRead ([ByteString] -> ByteString
L.fromChunks [ByteString
s]) of
               Just BEncode
e  -> forall (m :: * -> *) a. Monad m => a -> m a
return BEncode
e
               Maybe BEncode
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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 SourcePos
pos Token
_ [Token]
_ = SourcePos
pos

bToken :: Token -> BParser ()
bToken :: Token -> BParser ()
bToken Token
t = 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 forall a. Show a => a -> String
show SourcePos -> Token -> [Token] -> SourcePos
updatePos Token -> Maybe ()
fn
    where fn :: Token -> Maybe ()
fn Token
t' | Token
t' forall a. Eq a => a -> a -> Bool
== Token
t = forall a. a -> Maybe a
Just ()
          fn Token
_ = forall a. Maybe a
Nothing

token' :: (Token -> Maybe a) -> BParser a
token' :: forall a. (Token -> Maybe a) -> BParser a
token' = 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 forall a. Show a => a -> String
show SourcePos -> Token -> [Token] -> SourcePos
updatePos

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

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

withToken :: Token -> BParser a -> BParser a
withToken :: forall a. Token -> BParser a -> BParser a
withToken Token
tok
    = 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 = forall a. Token -> BParser a -> BParser a
withToken Token
TInt forall a b. (a -> b) -> a -> b
$ 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 = 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 = forall a. Token -> BParser a -> BParser a
withToken Token
TList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [BEncode] -> BEncode
BList (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 = forall a. Token -> BParser a -> BParser a
withToken Token
TDict forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map String BEncode -> BEncode
BDict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList) (forall {a} {m :: * -> *}. (Ord a, MonadFail m) => [a] -> m [a]
checkList forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 [a]
lst = if [a]
lst forall a. Eq a => a -> a -> Bool
/= forall a. Ord a => [a] -> [a]
sort [a]
lst
                            then forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"dictionary not sorted"
                            else 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
                   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 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> BParser BEncode
bList forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> BParser BEncode
bString 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 ByteString
str = case forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse BParser BEncode
bParse String
"" (ByteString -> [Token]
lexer ByteString
str) of
              Left ParseError
_err -> forall a. Maybe a
Nothing
              Right BEncode
b   -> 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 (String
k,BEncode
v) = forall {a}. Show a => String -> a -> ShowS
sString String
k (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
k) forall b c a. (b -> c) -> (a -> b) -> a -> c
. BEncode -> ShowS
bShow' BEncode
v
    sDict :: Map String BEncode -> ShowS
sDict Map String BEncode
dict = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, BEncode) -> ShowS
sKV) forall a. a -> a
id (forall k a. Map k a -> [(k, a)]
Map.toAscList Map String BEncode
dict)
    sList :: [BEncode] -> ShowS
sList = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. BEncode -> ShowS
bShow') forall a. a -> a
id
    sString :: String -> a -> ShowS
sString String
str a
len = forall a. Show a => a -> ShowS
shows a
len forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
':' forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
str
    bShow' :: BEncode -> ShowS
bShow' BEncode
b =
      case BEncode
b of
        BInt Integer
i    -> Char -> ShowS
sc Char
'i' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows Integer
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
'e'
        BString ByteString
s -> forall {a}. Show a => String -> a -> ShowS
sString (ByteString -> String
L.unpack ByteString
s) (ByteString -> Int64
L.length ByteString
s)
        BList [BEncode]
bl  -> Char -> ShowS
sc Char
'l' forall b c a. (b -> c) -> (a -> b) -> a -> c
. [BEncode] -> ShowS
sList [BEncode]
bl forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
'e'
        BDict Map String BEncode
bd  -> Char -> ShowS
sc Char
'd' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String BEncode -> ShowS
sDict Map String BEncode
bd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
'e'

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

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