-- |
--   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
import GHC.Integer.GMP.Internals

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

integerDecimal :: Integer -> B.Builder
integerDecimal :: Integer -> Builder
integerDecimal (S# Int#
i#) = Int -> Builder
B.intDec (Int# -> Int
I# Int#
i#)
integerDecimal  Integer
i      = String -> Builder
B.string7 (Integer -> String
forall a. Show a => a -> String
show Integer
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 Integer
i) = Word8 -> Builder
B.word8 (Char -> Word8
c2w Char
'i') Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                          Integer -> Builder
integerDecimal Integer
i Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                        Word8 -> Builder
B.word8 (Char -> Word8
c2w Char
'e')
      go (BString  BString
s) = BString -> Builder
buildString BString
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 (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`
                        (BString -> BValue -> Builder) -> BDict -> Builder
forall m a. Monoid m => (BString -> a -> m) -> BDictMap a -> m
foldMapWithKey BString -> 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 :: BString -> BValue -> Builder
mkKV BString
k BValue
v = BString -> Builder
buildString BString
k Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` BValue -> Builder
go BValue
v

      buildString :: BString -> Builder
buildString BString
s = Int -> Builder
B.intDec (BString -> Int
B.length BString
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`
                      BString -> Builder
B.byteString BString
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 (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' -> BString -> BValue
BString (BString -> BValue) -> Parser BString BString -> Parser BValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser BString BString
stringP
              Char
'i' -> Parser Char
P.anyChar Parser Char -> Parser BValue -> Parser BValue
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((Integer -> BValue
BInteger (Integer -> BValue) -> Parser BString Integer -> Parser BValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser BString Integer
integerP)  Parser BValue -> Parser Char -> Parser BValue
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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((BList -> BValue
BList    (BList -> BValue) -> Parser BString BList -> Parser BValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser BString BList
listBodyP) Parser BValue -> Parser Char -> Parser BValue
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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>  (BDict -> BValue
BDict    (BDict -> BValue) -> Parser BString BDict -> Parser BValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser BString BDict
dictBodyP) Parser BValue -> Parser Char -> Parser BValue
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char
P.anyChar
              Char
t   -> String -> Parser BValue
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 BString BDict
dictBodyP = BString -> BValue -> BDict -> BDict
forall a. BString -> a -> BDictMap a -> BDictMap a
Cons (BString -> BValue -> BDict -> BDict)
-> Parser BString BString
-> Parser BString (BValue -> BDict -> BDict)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser BString BString
stringP Parser BString (BValue -> BDict -> BDict)
-> Parser BValue -> Parser BString (BDict -> BDict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser BValue
valueP Parser BString (BDict -> BDict)
-> Parser BString BDict -> Parser BString BDict
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser BString BDict
dictBodyP
            Parser BString BDict
-> Parser BString BDict -> Parser BString BDict
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> BDict -> Parser BString BDict
forall (f :: * -> *) a. Applicative f => a -> f a
pure BDict
forall a. BDictMap a
Nil

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

    stringP :: Parser ByteString
    stringP :: Parser BString BString
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 BString BString
P.take Int
n
    {-# INLINE stringP #-}

    integerP :: Parser Integer
    integerP :: Parser BString Integer
integerP = do
      Maybe Char
c <- Parser (Maybe Char)
P.peekChar
      case Maybe Char
c of
        Just Char
'-' -> do
          Char
_ <- Parser Char
P.anyChar
          Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer)
-> Parser BString Integer -> Parser BString Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser BString Integer
forall a. Integral a => Parser a
P.decimal
        Maybe Char
_        ->  Parser BString Integer
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 :: BString -> Either String BValue
parse = Parser BValue -> BString -> Either String BValue
forall a. Parser a -> BString -> Either String a
P.parseOnly Parser BValue
parser

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

ppBS :: ByteString -> Doc
ppBS :: BString -> Doc
ppBS = String -> Doc
text (String -> Doc) -> (BString -> String) -> BString -> 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) -> (BString -> [Word8]) -> BString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BString -> [Word8]
B.unpack

-- | Convert to easily readable JSON-like document. Typically used for
-- debugging purposes.
ppBEncode :: BValue -> Doc
ppBEncode :: BValue -> Doc
ppBEncode (BInteger Integer
i) = Int -> Doc
int (Int -> Doc) -> Int -> Doc
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i
ppBEncode (BString  BString
s) = BString -> Doc
ppBS BString
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
$ ((BString, BValue) -> Doc) -> [(BString, BValue)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
L.map (BString, BValue) -> Doc
ppKV ([(BString, BValue)] -> [Doc]) -> [(BString, BValue)] -> [Doc]
forall a b. (a -> b) -> a -> b
$ BDict -> [(BString, BValue)]
forall a. BDictMap a -> [(BString, a)]
BD.toAscList BDict
d
  where
    ppKV :: (BString, BValue) -> Doc
ppKV (BString
k, BValue
v) = BString -> Doc
ppBS BString
k Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> BValue -> Doc
ppBEncode BValue
v