diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for cborg-json + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,30 @@ +Copyright (c) 2017, Duncan Coutts + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Duncan Coutts nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cborg-json.cabal b/cborg-json.cabal new file mode 100644 --- /dev/null +++ b/cborg-json.cabal @@ -0,0 +1,36 @@ +name: cborg-json +version: 0.1.0.0 +synopsis: A library for encoding JSON as CBOR +description: This package implements the bijection between JSON and + CBOR defined in the CBOR specification, RFC 7049. +homepage: https://github.com/well-typed/cborg +license: BSD3 +license-file: LICENSE.txt +author: Duncan Coutts +maintainer: ben@smart-cactus.org +bug-reports: https://github.com/well-typed/cborg/issues +copyright: 2015-2017 Duncan Coutts, + 2015-2017 Well-Typed LLP, + 2015 IRIS Connect Ltd +category: Codec +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +library + exposed-modules: Codec.CBOR.JSON + ghc-options: -Wall + build-depends: + base >=4.7 && <4.11, + aeson >=0.7 && <1.2, + aeson-pretty >=0.8 && <0.9, + unordered-containers >=0.2 && <0.3, + scientific >=0.3 && <0.4, + text >=1.1 && <1.3, + vector >=0.10 && <0.13, + cborg ==0.1.* + hs-source-dirs: src + default-language: Haskell2010 + + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances diff --git a/src/Codec/CBOR/JSON.hs b/src/Codec/CBOR/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/JSON.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE BangPatterns #-} + +module Codec.CBOR.JSON + ( encodeValue + , decodeValue + ) where + +import Data.Monoid +import Control.Applicative +import Prelude + +import Codec.CBOR.Encoding +import Codec.CBOR.Decoding +import Data.Aeson ( Value(..) ) +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Lazy as HM +import Data.Scientific as Scientific +import qualified Data.Text as T +import qualified Data.Vector as V + +-- | Encode a JSON value into CBOR. +encodeValue :: Value -> Encoding +encodeValue (Object vs) = encodeObject vs +encodeValue (Array vs) = encodeArray vs +encodeValue (String s) = encodeString s +encodeValue (Number n) = case Scientific.floatingOrInteger n of + Left d -> encodeDouble d + Right i -> encodeInteger i +encodeValue (Bool b) = encodeBool b +encodeValue Null = encodeNull + +encodeObject :: Aeson.Object -> Encoding +encodeObject vs = + encodeMapLen (fromIntegral (HM.size vs)) + <> HM.foldrWithKey (\k v r -> encodeString k <> encodeValue v <> r) mempty vs + +encodeArray :: Aeson.Array -> Encoding +encodeArray vs = + encodeListLen (fromIntegral (V.length vs)) + <> V.foldr (\v r -> encodeValue v <> r) mempty vs + +-- | Decode an arbitrary CBOR value into JSON. +decodeValue :: Bool -> Decoder s Value +decodeValue lenient = do + tkty <- peekTokenType + case tkty of + TypeUInt -> decodeNumberIntegral + TypeUInt64 -> decodeNumberIntegral + TypeNInt -> decodeNumberIntegral + TypeNInt64 -> decodeNumberIntegral + TypeInteger -> decodeNumberIntegral + TypeFloat64 -> decodeNumberFloating + TypeBool -> Bool <$> decodeBool + TypeNull -> Null <$ decodeNull + TypeString -> String <$> decodeString + + TypeListLen -> decodeListLen >>= flip (decodeListN lenient) [] + TypeListLenIndef -> decodeListLenIndef >> (decodeListIndef lenient) [] + TypeMapLen -> decodeMapLen >>= flip (decodeMapN lenient) HM.empty + + _ -> fail $ "unexpected CBOR token type for a JSON value: " + ++ show tkty + +decodeNumberIntegral :: Decoder s Value +decodeNumberIntegral = Number . fromInteger <$> decodeInteger + +decodeNumberFloating :: Decoder s Value +decodeNumberFloating = Number . Scientific.fromFloatDigits <$> decodeDouble + +decodeListN :: Bool -> Int -> [Value] -> Decoder s Value +decodeListN !lenient !n acc = + case n of + 0 -> return $! Array (V.fromList (reverse acc)) + _ -> do !t <- decodeValue lenient + decodeListN lenient (n-1) (t : acc) + +decodeListIndef :: Bool -> [Value] -> Decoder s Value +decodeListIndef !lenient acc = do + stop <- decodeBreakOr + if stop then return $! Array (V.fromList (reverse acc)) + else do !tm <- decodeValue lenient + decodeListIndef lenient (tm : acc) + +decodeMapN :: Bool -> Int -> Aeson.Object -> Decoder s Value +decodeMapN !lenient !n acc = + case n of + 0 -> return $! Object acc + _ -> do + !tk <- decodeValue lenient >>= \v -> case v of + String s -> return s + -- These cases are only allowed when --lenient is passed, + -- as printing them as strings may result in key collisions. + Number d | lenient -> return $ T.pack (show d) + Bool b | lenient -> return $ T.pack (show b) + _ -> fail "Could not decode map key type" + !tv <- decodeValue lenient + decodeMapN lenient (n-1) (HM.insert tk tv acc)