    -----------------------------------------------------------------------------
    -- |
    -- 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
    $c== :: BEncode -> BEncode -> Bool
    == :: BEncode -> BEncode -> Bool
    $c/= :: BEncode -> BEncode -> Bool
    /= :: 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
    $ccompare :: BEncode -> BEncode -> Ordering
    compare :: BEncode -> BEncode -> Ordering
    $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
    >= :: BEncode -> BEncode -> Bool
    $cmax :: BEncode -> BEncode -> BEncode
    max :: BEncode -> BEncode -> BEncode
    $cmin :: BEncode -> BEncode -> BEncode
    min :: BEncode -> BEncode -> 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
    $cshowsPrec :: Int -> BEncode -> ShowS
    showsPrec :: Int -> BEncode -> ShowS
    $cshow :: BEncode -> String
    show :: BEncode -> String
    $cshowList :: [BEncode] -> ShowS
    showList :: [BEncode] -> ShowS
    Show)

    instance Binary BEncode where
        put :: BEncode -> Put
    put 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 s <- Get ByteString
    forall t. Binary t => Get t
    get
                 case bRead (L.fromChunks [s]) of
                   Just BEncode
    e  -> BEncode -> Get BEncode
    forall a. a -> Get a
    forall (m :: * -> *) a. Monad m => a -> m a
    return BEncode
    e
                   Maybe BEncode
    Nothing -> String -> Get BEncode
    forall a. String -> Get a
    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 = (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 Token
    t' | Token
    t' Token -> Token -> Bool
    forall a. Eq a => a -> a -> Bool
    == Token
    t = () -> Maybe ()
    forall a. a -> Maybe a
    Just ()
              fn Token
    _ = Maybe ()
    forall a. Maybe a
    Nothing

    token' :: (Token -> Maybe a) -> BParser a
    token' :: forall a. (Token -> Maybe a) -> BParser a
    token' = (Token -> String)
    -> (SourcePos -> Token -> [Token] -> SourcePos)
    -> (Token -> Maybe a)
    -> ParsecT [Token] () Identity 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 Integer
    i) = Integer -> Maybe Integer
    forall a. a -> Maybe a
    Just Integer
    i
              fn Token
    _ = 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 ByteString
    str) = ByteString -> Maybe ByteString
    forall a. a -> Maybe a
    Just ByteString
    str
              fn Token
    _ = Maybe ByteString
    forall a. Maybe a
    Nothing

    withToken :: Token -> BParser a -> BParser a
    withToken :: forall a. Token -> BParser a -> BParser a
    withToken Token
    tok
        = BParser ()
    -> BParser ()
    -> ParsecT [Token] () Identity a
    -> ParsecT [Token] () Identity 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 a b.
    (a -> b)
    -> ParsecT [Token] () Identity a -> ParsecT [Token] () Identity 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 = (ByteString -> BEncode) -> BParser ByteString -> BParser BEncode
    forall a b.
    (a -> b)
    -> ParsecT [Token] () Identity a -> ParsecT [Token] () Identity b
    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 a b.
    (a -> b)
    -> ParsecT [Token] () Identity a -> ParsecT [Token] () Identity b
    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 a b.
    (a -> b)
    -> ParsecT [Token] () Identity a -> ParsecT [Token] () Identity b
    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 [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 a. String -> m a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "dictionary not sorted"
                                else [a] -> m [a]
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [a]
    lst
              bAssocList :: ParsecT [Token] () Identity (String, BEncode)
    bAssocList
                  = do str <- BParser ByteString
    tstring
                       value <- bParse
                       return (L.unpack str,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 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 String
    "" (ByteString -> [Token]
    lexer ByteString
    str) of
                  Left ParseError
    _err -> Maybe BEncode
    forall a. Maybe a
    Nothing
                  Right 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 (String
    k,BEncode
    v) = String -> Int -> ShowS
    forall {a}. Show a => String -> a -> ShowS
    sString String
    k (String -> Int
    forall a. [a] -> 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 Map String BEncode
    dict = ((String, BEncode) -> ShowS -> ShowS)
    -> ShowS -> [(String, BEncode)] -> ShowS
    forall a b. (a -> b -> b) -> b -> [a] -> b
    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 a b. (a -> b -> b) -> b -> [a] -> b
    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 String
    str 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 Char
    ':' ShowS -> ShowS -> ShowS
    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' 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 Char
    'e'
            BString 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 [BEncode]
    bl  -> Char -> ShowS
    sc Char
    '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 Char
    'e'
            BDict Map String BEncode
    bd  -> Char -> ShowS
    sc Char
    '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 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 (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 Integer
    i) [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 ByteString
    s) [ByteString]
    r = ByteString -> [ByteString] -> [ByteString]
    sString ByteString
    s [ByteString]
    r
              bPack' (BList [BEncode]
    bl) [ByteString]
    r = ByteString
    listTag ByteString -> [ByteString] -> [ByteString]
    forall a. a -> [a] -> [a]
    : (BEncode -> [ByteString] -> [ByteString])
    -> [ByteString] -> [BEncode] -> [ByteString]
    forall a b. (a -> b -> b) -> b -> [a] -> b
    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 Map String BEncode
    bd) [ByteString]
    r = ByteString
    dictTag ByteString -> [ByteString] -> [ByteString]
    forall a. a -> [a] -> [a]
    : ((String, BEncode) -> [ByteString] -> [ByteString])
    -> [ByteString] -> [(String, BEncode)] -> [ByteString]
    forall a b. (a -> b -> b) -> b -> [a] -> b
    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) ([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)