{-# LANGUAGE Safe #-}
-- | A MessagePack parser.
--
-- Example usage:
--   $ echo -ne "\x94\x01\xa1\x32\xa1\x33\xa4\x50\x6f\x6f\x66" | ./msgpack-parser
-- or
--   $ echo 'ObjectArray [ObjectInt 97, ObjectStr "test",  ObjectBool True]' | ./msgpack-parser
--
-- This tool performs two symmetrical functions:
--   1. It can decode binary data representing a
--      Data.MessagePack.Object into a human-readable string.
--   2. It can do the reverse: encode a human-readable string into
--      a binary representation of Data.MessagePack.Object.
--
-- No flags are required as it automatically detects which of these
-- two functions it should perform.  This is done by first assuming
-- the input is human readable.  If it fails to parse it, it then
-- considers it as binary data.
--
-- Therefore, given a valid input, the tool has the following property
--   $ ./msgpack-parser < input.bin | ./msgpack-parser
-- will output back the contents of input.bin.
--
-- In case the input is impossible to parse, nothing is output.
--
-- Known bugs:
--   - If no input is given, the tool exits with
--     "Data.Binary.Get.runGet at position 0: not enough bytes"
--   - The tool does not check that all the input is parsed.
--     Therefore, "abc" is interpreted as just "ObjectInt 97".
--
module Test.MessagePack.Parser (parse) where

import           Control.Applicative        ((<|>))
import qualified Data.ByteString.Lazy       as L
import qualified Data.ByteString.Lazy.Char8 as L8
import           Data.Int                   (Int64)
import           Data.Maybe                 (fromMaybe)
import           Data.MessagePack.Types     (Object)
import           Data.Time.Clock            (diffUTCTime, getCurrentTime)
import           System.IO                  (hPutStr, hPutStrLn, stderr)
import           Text.Read                  (readMaybe)


display :: Int64 -> Object -> String
display :: Int64 -> Object -> String
display Int64
len | Int64
len Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
10 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1024 = String -> Object -> String
forall a b. a -> b -> a
const (String -> Object -> String) -> String -> Object -> String
forall a b. (a -> b) -> a -> b
$ Int64 -> String
forall a. Show a => a -> String
show Int64
len String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" bytes (too large to display)"
display Int64
_   = Object -> String
forall a. Show a => a -> String
show


parseBidirectional
    :: (Object -> L.ByteString)
    -> (L.ByteString -> Maybe Object)
    -> L.ByteString
    -> L.ByteString
parseBidirectional :: (Object -> ByteString)
-> (ByteString -> Maybe Object) -> ByteString -> ByteString
parseBidirectional Object -> ByteString
pack ByteString -> Maybe Object
unpack ByteString
str = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
L.empty (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
    Object -> ByteString
pack (Object -> ByteString) -> Maybe Object -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Object
forall a. Read a => String -> Maybe a
readMaybe (ByteString -> String
L8.unpack ByteString
str)
    Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
    String -> ByteString
L8.pack (String -> ByteString)
-> (Object -> String) -> Object -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String) -> String -> String -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> String
forall a. [a] -> [a] -> [a]
(++) String
"\n" (String -> String) -> (Object -> String) -> Object -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Object -> String
display (ByteString -> Int64
L.length ByteString
str) (Object -> ByteString) -> Maybe Object -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe Object
unpack ByteString
str


showSpeed :: Int64 -> Double -> String
showSpeed :: Int64 -> Double -> String
showSpeed Int64
size Double
time =
    Double -> String
forall a. Show a => a -> String
show (Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
size Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
1024 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1024) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
time) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" MiB/s"


parse :: (Object -> L.ByteString) -> (L.ByteString -> Maybe Object) -> IO ()
parse :: (Object -> ByteString) -> (ByteString -> Maybe Object) -> IO ()
parse Object -> ByteString
pack ByteString -> Maybe Object
unpack = do
    UTCTime
start <- IO UTCTime
getCurrentTime
    ByteString
packed <- IO ByteString
L.getContents
    Handle -> String -> IO ()
hPutStr Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Read " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
L.length ByteString
packed) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" bytes"
    UTCTime
readTime <- IO UTCTime
getCurrentTime
    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
readTime UTCTime
start)

    let parsed :: ByteString
parsed = (Object -> ByteString)
-> (ByteString -> Maybe Object) -> ByteString -> ByteString
parseBidirectional Object -> ByteString
pack ByteString -> Maybe Object
unpack ByteString
packed
    Handle -> String -> IO ()
hPutStr Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Parsed into " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
L.length ByteString
parsed) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" bytes"
    UTCTime
unpackTime <- IO UTCTime
getCurrentTime
    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
unpackTime UTCTime
readTime)

    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unpacking speed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int64 -> Double -> String
showSpeed (ByteString -> Int64
L.length ByteString
packed) (NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
unpackTime UTCTime
readTime))

    ByteString -> IO ()
L.putStr ByteString
parsed