-- |
--   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 (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') forall a. Monoid a => a -> a -> a
`mappend`
                          BInteger -> Builder
integerDecimal BInteger
i 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') forall a. Monoid a => a -> a -> a
`mappend`
                        forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap BValue -> Builder
go BList
l 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') forall a. Monoid a => a -> a -> a
`mappend`
                        forall m a. Monoid m => (ByteString -> a -> m) -> BDictMap a -> m
foldMapWithKey ByteString -> BValue -> Builder
mkKV BDict
d 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 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) forall a. Monoid a => a -> a -> a
`mappend`
                      Word8 -> Builder
B.word8 (Char -> Word8
c2w Char
':') 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 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 -> 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 forall a. Ord a => a -> a -> Bool
<= Char
'9' -> ByteString -> BValue
BString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
stringP
              Char
'i' -> Parser Char
P.anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((BInteger -> BValue
BInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser BInteger
integerP)  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char
P.anyChar)
              Char
'l' -> Parser Char
P.anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((BList -> BValue
BList    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString BList
listBodyP) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char
P.anyChar)
              Char
'd' -> Parser Char
P.anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>  (BDict -> BValue
BDict    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser BDict
dictBodyP) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char
P.anyChar
              Char
t   -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"bencode unknown tag: " forall a. [a] -> [a] -> [a]
++ [Char
t])

    dictBodyP :: Parser BDict
    dictBodyP :: Parser BDict
dictBodyP = forall a. ByteString -> a -> BDictMap a -> BDictMap a
Cons forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
stringP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser BValue
valueP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser BDict
dictBodyP
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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' -> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Maybe Char
_        -> (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser BValue
valueP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString BList
listBodyP

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

    integerP :: Parser Integer
    integerP :: Parser BInteger
integerP = do
      Maybe Char
c <- Parser (Maybe Char)
P.peekChar
      case Maybe Char
c of
        Just Char
'-' -> do
          Char
_ <- Parser Char
P.anyChar
          forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Integral a => Parser a
P.decimal
        Maybe Char
_        ->  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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
L.map Word8 -> Char
w2c 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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
L.map BValue -> Doc
ppBEncode BList
l
ppBEncode (BDict    BDict
d)
    = Doc -> Doc
braces forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
L.map (ByteString, BValue) -> Doc
ppKV forall a b. (a -> b) -> a -> b
$ 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