cborg-json (empty) → 0.1.0.0

raw patch · 5 files changed

+170/−0 lines, 5 filesdep +aesondep +aeson-prettydep +basesetup-changed

Dependencies added: aeson, aeson-pretty, base, cborg, scientific, text, unordered-containers, vector

Files

ChangeLog.md +5/−0
LICENSE.txt +30/−0
Setup.hs +2/−0
cborg-json.cabal +36/−0
src/Codec/CBOR/JSON.hs +97/−0

+ ChangeLog.md view

@@ -0,0 +1,5 @@+# Revision history for cborg-json++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

+ LICENSE.txt view

@@ -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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ cborg-json.cabal view

@@ -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

+ src/Codec/CBOR/JSON.hs view

@@ -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)