-- |
--   Copyright   :  (c) Sam Truzjan 2013
--   License     :  BSD3
--   Maintainer  :  pxqr.sta@gmail.com
--   Stability   :  stable
--   Portability :  portable
--
--   This module provides bencode values serialization. Normally, you
--   don't need to import this module, use 'Data.BEncode' instead.
--
{-# LANGUAGE CPP       #-}
{-# LANGUAGE MagicHash #-}
module Data.BEncode.Internal
       ( -- * Parsing
         parser
       , parse

         -- * Rendering
       , builder
       , build
       , ppBEncode
       ) where

import Control.Applicative
import           Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as P
import           Data.ByteString as B
import           Data.ByteString.Internal as B (c2w, w2c)
import qualified Data.ByteString.Lazy as Lazy
import Data.List as L
import Text.PrettyPrint hiding ((<>))

#if MIN_VERSION_bytestring(0, 10, 12)
import qualified Data.ByteString.Builder as B
#else
import qualified Data.ByteString.Lazy.Builder as B
#endif

#if __GLASGOW_HASKELL__ < 710
import Data.Foldable
import Data.Monoid (Monoid (mappend))
#endif

import Data.BEncode.Types
import Data.BEncode.BDict as BD

import GHC.Types

#if MIN_VERSION_integer_gmp(1, 1, 0)
import GHC.Num.Integer
#else
import GHC.Integer.GMP.Internals
#endif

{--------------------------------------------------------------------
-- Serialization
--------------------------------------------------------------------}

integerDecimal :: Integer -> B.Builder
#if MIN_VERSION_integer_gmp(1, 1, 0)
integerDecimal :: BInteger -> Builder
integerDecimal (IS Int#
i#) = Int -> Builder
B.intDec (Int# -> Int
I# Int#
i#)
#else
integerDecimal (S# i#) = B.intDec (I# i#)
#endif
integerDecimal  BInteger
i      = String -> Builder
B.string7 (BInteger -> String
forall a. Show a => a -> String
show BInteger
i) -- TODO more efficient

-- | BEncode format encoder according to specification.
builder :: BValue -> B.Builder
builder :: BValue -> Builder
builder = BValue -> Builder
go
    where
      go :: BValue -> Builder
go (BInteger BInteger
i) = Word8 -> Builder
B.word8 (Char -> Word8
c2w Char
'i') Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                          BInteger -> Builder
integerDecimal BInteger
i Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                        Word8 -> Builder
B.word8 (Char -> Word8
c2w Char
'e')
      go (BString  ByteString
s) = ByteString -> Builder
buildString ByteString
s
      go (BList    BList
l) = Word8 -> Builder
B.word8 (Char -> Word8
c2w Char
'l') Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                        (BValue -> Builder) -> BList -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap BValue -> Builder
go BList
l Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                        Word8 -> Builder
B.word8 (Char -> Word8
c2w Char
'e')
      go (BDict    BDict
d) = Word8 -> Builder
B.word8 (Char -> Word8
c2w Char
'd') Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                        (ByteString -> BValue -> Builder) -> BDict -> Builder
forall m a. Monoid m => (ByteString -> a -> m) -> BDictMap a -> m
foldMapWithKey ByteString -> BValue -> Builder
mkKV BDict
d Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                        Word8 -> Builder
B.word8 (Char -> Word8
c2w Char
'e')
          where
            mkKV :: ByteString -> BValue -> Builder
mkKV ByteString
k BValue
v = ByteString -> Builder
buildString ByteString
k Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` BValue -> Builder
go BValue
v

      buildString :: ByteString -> Builder
buildString ByteString
s = Int -> Builder
B.intDec (ByteString -> Int
B.length ByteString
s) Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                      Word8 -> Builder
B.word8 (Char -> Word8
c2w Char
':') Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                      ByteString -> Builder
B.byteString ByteString
s
      {-# INLINE buildString #-}

-- | Convert bencoded value to raw bytestring according to the
-- specification.
build :: BValue -> Lazy.ByteString
build :: BValue -> ByteString
build = Builder -> ByteString
B.toLazyByteString (Builder -> ByteString)
-> (BValue -> Builder) -> BValue -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BValue -> Builder
builder

{--------------------------------------------------------------------
-- Deserialization
--------------------------------------------------------------------}

-- TODO try to replace peekChar with something else
-- | BEncode format parser according to specification.
parser :: Parser BValue
parser :: Parser BValue
parser = Parser BValue
valueP
  where
    valueP :: Parser BValue
valueP = do
      Maybe Char
mc <- Parser (Maybe Char)
P.peekChar
      case Maybe Char
mc of
        Maybe Char
Nothing -> String -> Parser BValue
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"end of input"
        Just Char
c  ->
            case Char
c of
              -- if we have digit it always should be string length
              Char
di | Char
di Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' -> ByteString -> BValue
BString (ByteString -> BValue)
-> Parser ByteString ByteString -> Parser BValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
stringP
              Char
'i' -> Parser Char
P.anyChar Parser Char -> Parser BValue -> Parser BValue
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((BInteger -> BValue
BInteger (BInteger -> BValue) -> Parser ByteString BInteger -> Parser BValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString BInteger
integerP)  Parser BValue -> Parser Char -> Parser BValue
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char
P.anyChar)
              Char
'l' -> Parser Char
P.anyChar Parser Char -> Parser BValue -> Parser BValue
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((BList -> BValue
BList    (BList -> BValue) -> Parser ByteString BList -> Parser BValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString BList
listBodyP) Parser BValue -> Parser Char -> Parser BValue
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char
P.anyChar)
              Char
'd' -> Parser Char
P.anyChar Parser Char -> Parser BValue -> Parser BValue
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>  (BDict -> BValue
BDict    (BDict -> BValue) -> Parser ByteString BDict -> Parser BValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString BDict
dictBodyP) Parser BValue -> Parser Char -> Parser BValue
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char
P.anyChar
              Char
t   -> String -> Parser BValue
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"bencode unknown tag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
t])

    dictBodyP :: Parser BDict
    dictBodyP :: Parser ByteString BDict
dictBodyP = ByteString -> BValue -> BDict -> BDict
forall a. ByteString -> a -> BDictMap a -> BDictMap a
Cons (ByteString -> BValue -> BDict -> BDict)
-> Parser ByteString ByteString
-> Parser ByteString (BValue -> BDict -> BDict)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
stringP Parser ByteString (BValue -> BDict -> BDict)
-> Parser BValue -> Parser ByteString (BDict -> BDict)
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser BValue
valueP Parser ByteString (BDict -> BDict)
-> Parser ByteString BDict -> Parser ByteString BDict
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString BDict
dictBodyP
            Parser ByteString BDict
-> Parser ByteString BDict -> Parser ByteString BDict
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> BDict -> Parser ByteString BDict
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BDict
forall a. BDictMap a
Nil

    listBodyP :: Parser ByteString BList
listBodyP = do
      Maybe Char
c <- Parser (Maybe Char)
P.peekChar
      case Maybe Char
c of
        Just Char
'e' -> BList -> Parser ByteString BList
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        Maybe Char
_        -> (:) (BValue -> BList -> BList)
-> Parser BValue -> Parser ByteString (BList -> BList)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser BValue
valueP Parser ByteString (BList -> BList)
-> Parser ByteString BList -> Parser ByteString BList
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString BList
listBodyP

    stringP :: Parser ByteString
    stringP :: Parser ByteString ByteString
stringP = do
      Int
n <- Parser Int
forall a. Integral a => Parser a
P.decimal :: Parser Int
      Char
_ <- Char -> Parser Char
P.char Char
':'
      Int -> Parser ByteString ByteString
P.take Int
n
    {-# INLINE stringP #-}

    integerP :: Parser Integer
    integerP :: Parser ByteString BInteger
integerP = do
      Maybe Char
c <- Parser (Maybe Char)
P.peekChar
      case Maybe Char
c of
        Just Char
'-' -> do
          Char
_ <- Parser Char
P.anyChar
          BInteger -> BInteger
forall a. Num a => a -> a
negate (BInteger -> BInteger)
-> Parser ByteString BInteger -> Parser ByteString BInteger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString BInteger
forall a. Integral a => Parser a
P.decimal
        Maybe Char
_        ->  Parser ByteString BInteger
forall a. Integral a => Parser a
P.decimal
    {-# INLINE integerP #-}

-- | Try to convert raw bytestring to bencoded value according to
-- specification.
parse :: ByteString -> Either String BValue
parse :: ByteString -> Either String BValue
parse = Parser BValue -> ByteString -> Either String BValue
forall a. Parser a -> ByteString -> Either String a
P.parseOnly Parser BValue
parser

{--------------------------------------------------------------------
  Pretty Printing
--------------------------------------------------------------------}

ppBS :: ByteString -> Doc
ppBS :: ByteString -> Doc
ppBS = String -> Doc
text (String -> Doc) -> (ByteString -> String) -> ByteString -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
L.map Word8 -> Char
w2c ([Word8] -> String)
-> (ByteString -> [Word8]) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
B.unpack

-- | Convert to easily readable JSON-like document. Typically used for
-- debugging purposes.
ppBEncode :: BValue -> Doc
ppBEncode :: BValue -> Doc
ppBEncode (BInteger BInteger
i) = Int -> Doc
int (Int -> Doc) -> Int -> Doc
forall a b. (a -> b) -> a -> b
$ BInteger -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral BInteger
i
ppBEncode (BString  ByteString
s) = ByteString -> Doc
ppBS ByteString
s
ppBEncode (BList    BList
l)
    = Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (BValue -> Doc) -> BList -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
L.map BValue -> Doc
ppBEncode BList
l
ppBEncode (BDict    BDict
d)
    = Doc -> Doc
braces (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ((ByteString, BValue) -> Doc) -> [(ByteString, BValue)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
L.map (ByteString, BValue) -> Doc
ppKV ([(ByteString, BValue)] -> [Doc])
-> [(ByteString, BValue)] -> [Doc]
forall a b. (a -> b) -> a -> b
$ BDict -> [(ByteString, BValue)]
forall a. BDictMap a -> [(ByteString, a)]
BD.toAscList BDict
d
  where
    ppKV :: (ByteString, BValue) -> Doc
ppKV (ByteString
k, BValue
v) = ByteString -> Doc
ppBS ByteString
k Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> BValue -> Doc
ppBEncode BValue
v