module Data.BEncode
(
BEncode(..),
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
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"
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 :: 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
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)