{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
module Main
( main -- :: IO ()
) where
import Control.Monad
import System.FilePath
import System.Environment
import System.Exit ( exitFailure )
import System.IO ( hPutStrLn, stderr )
import Text.Printf ( printf )
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import qualified Data.Aeson as Aeson
import Data.Aeson.Encode.Pretty as Aeson.Pretty
import qualified Data.ByteString.Lazy as LB
import qualified Data.Text.Lazy.IO as LT
import qualified Data.Text.Lazy.Builder as LT
import Codec.CBOR.JSON
import Codec.CBOR.Pretty
import Codec.CBOR.Read as Read
import qualified Codec.CBOR.Write as Write
import Codec.CBOR.Term ( decodeTerm, encodeTerm )
--------------------------------------------------------------------------------
-- JSON -> CBOR conversion
-- | Convert an arbitrary JSON file into CBOR format.
jsonToCbor :: FilePath -> IO ()
jsonToCbor file = do
bs <- LB.readFile file
case Aeson.decode bs of
Nothing -> fail "invalid JSON file!"
Just v -> do
let encVal = encodeValue v
cborFile = dropExtension file <.> "cbor"
-- Now write the blob
LB.writeFile cborFile (Write.toLazyByteString encVal)
--------------------------------------------------------------------------------
-- Dumping code
-- | Dump a CBOR file as JSON
dumpCborAsJson :: Bool -> FilePath -> IO ()
dumpCborAsJson lenient file = LB.readFile file >>= go
where go :: LB.ByteString -> IO ()
go bs =
case deserialiseFromBytes (decodeValue lenient) bs of
Left (Read.DeserialiseFailure off err) ->
fail $ "deserialization error (at offset " ++ show off ++ "): " ++ err
Right (trailing, v) -> do
let builder = Aeson.Pretty.encodePrettyToTextBuilder v
LT.putStrLn (LT.toLazyText builder)
unless (LB.null trailing) (go trailing)
-- | Dump a CBOR file as a Term, or optionally as pretty hex
dumpCborFile :: Bool -> FilePath -> IO ()
dumpCborFile pretty file = LB.readFile file >>= go
where go :: LB.ByteString -> IO ()
go bs =
case deserialiseFromBytes decodeTerm bs of
Left (Read.DeserialiseFailure off err) ->
fail $ "deserialization error (at offset " ++ show off ++ "): " ++ err
Right (trailing, v) -> do
if pretty
then putStrLn (prettyHexEnc $ encodeTerm v)
else print v
unless (LB.null trailing) (go trailing)
dumpAsHex :: FilePath -> IO ()
dumpAsHex file = do
bs <- LB.readFile file
putStrLn (showHexString bs)
-- | Show a @'ByteString'@ as a hex string.
showHexString :: LB.ByteString -> String
showHexString = concat . toHex
where
toHex = map (printf "%02X ") . LB.unpack
--------------------------------------------------------------------------------
-- Driver code
-- | Main entry point.
main :: IO ()
main = do
let help = unlines
[ "usage: cbor-tool <action> [options] <file>"
, ""
, " Useful tool for dealing with and analyzing raw files containing"
, " CBOR values. <action> and <file> are both mandatory options."
, ""
, " Actions:"
, ""
, " dump [--json|--hex|--pretty|--term] [--lenient] <file>"
, " Read the CBOR values inside <file> and dump them in the"
, " specified format. --json will dump JSON files, while --hex"
, " will dump the output in hexadecimal format. --pretty will"
, " use the internal 'Encoding' pretty-printer. --term is the"
, " internal 'Term' format type. You must specify either"
, " --json, --hex, --pretty, or --term (there is no default)."
, ""
, " When printing CBOR as JSON, the only valid type for JSON"
, " object keys is a UTF8 string. If you have a CBOR map that"
, " uses non-String types for keys, this will cause the decoder"
, " to fail when creating JSON. Use the --lenient option to"
, " remove this restriction -- this will allow numbers to also"
, " be valid as CBOR keys, by printing them as strings. However,"
, " this may risk collision of some keys as CBOR is more general,"
, " resulting in invalid JSON -- so use it with caution."
, ""
, " encode [--json] <file>"
, " Read the <file> in a specified format and dump a copy of"
, " the input in CBOR form under <file>.cbor. --json reads"
, " JSON files. You must specify --json (there is no default,"
, " for future compatibility.)"
]
args <- getArgs
case args of
("dump" : "--json" : "--lenient" : file : _) -> dumpCborAsJson True file
("dump" : "--json" : file : _) -> dumpCborAsJson False file
("dump" : "--hex" : file : _) -> dumpAsHex file
("dump" : "--pretty" : file : _) -> dumpCborFile True file
("dump" : "--term" : file : _) -> dumpCborFile False file
("encode" : "--json" : file : _) -> jsonToCbor file
_ -> hPutStrLn stderr help >> exitFailure