Merge pull request #315 from well-typed/yaitskov-support-bytestring-i…

…n-json-as-hex

Support bytestring in json as Base64Url

cborg-json/cborg-json.cabal

@@ -33,6 +33,7 @@ library
     base                 >=4.11 && < 4.19,
     aeson                >=0.7  && <2.2,
     aeson-pretty         >=0.8  && <0.9,
+    base64-bytestring    >=1.0  && <1.3,
     unordered-containers >=0.2  && <0.3,
     scientific           >=0.3  && <0.4,
     text                 >=1.1  && <2.1,
@@ -71,3 +72,32 @@ benchmark bench
 
     cborg,
     cborg-json
+
+
+test-suite tests
+  type:              exitcode-stdio-1.0
+  hs-source-dirs:    tests
+  main-is:           Main.hs
+
+  default-language:  Haskell2010
+  ghc-options:
+    -Wall -fno-warn-orphans
+    -threaded -rtsopts "-with-rtsopts=-N2"
+
+  other-modules:
+
+  build-depends:
+    base                    >= 4.7     && < 4.19,
+    base-orphans,
+    base16-bytestring       >= 1.0     && < 1.1,
+    bytestring              >= 0.10.4  && < 0.12,
+    cborg,
+    cborg-json,
+    aeson                   >= 0.7     && < 2.2,
+    QuickCheck              >= 2.9     && < 2.15,
+    tasty                   >= 0.11    && < 1.5,
+    tasty-hunit             >= 0.9     && < 0.11,
+    text                    >= 1.1     && < 2.1
+  if !impl(ghc >= 8.0)
+    build-depends:
+      fail                    >= 4.9.0.0 && < 4.10

cborg-json/src/Codec/CBOR/JSON.hs

@@ -14,8 +14,10 @@ import           Codec.CBOR.Encoding
 import           Codec.CBOR.Decoding
 import           Data.Aeson                          ( Value(..) )
 import qualified Data.Aeson                          as Aeson
+import qualified Data.ByteString.Base64.URL          as Base64url
 import           Data.Scientific                     as Scientific
 import qualified Data.Text                           as T
+import qualified Data.Text.Encoding                  as TE
 import qualified Data.Vector                         as V
 
 #if MIN_VERSION_aeson(2,0,0)
@@ -77,8 +79,13 @@ decodeValue lenient = do
       TypeListLenIndef -> decodeListLenIndef >> decodeListIndef lenient []
       TypeMapLen       -> decodeMapLen >>= flip (decodeMapN lenient) mempty
 
+      TypeBytes   -> bytesToBase64Text <$> decodeBytes
+
       _           -> fail $ "unexpected CBOR token type for a JSON value: "
                          ++ show tkty
+    where
+      bytesToBase64Text = String . TE.decodeLatin1 . Base64url.encode
+
 
 decodeNumberIntegral :: Decoder s Value
 decodeNumberIntegral = Number . fromInteger <$> decodeInteger
@@ -95,7 +102,7 @@ decodeNumberFloat16 = do
 
 decodeListN :: Bool -> Int -> Decoder s Value
 decodeListN !lenient !n = do
-  vec <- V.replicateM n (decodeValue lenient) 
+  vec <- V.replicateM n (decodeValue lenient)
   return $! Array vec
 
 decodeListIndef :: Bool -> [Value] -> Decoder s Value

cborg-json/tests/Main.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (main) where
+
+import           Codec.CBOR.JSON
+import           Codec.CBOR.Read
+import           Data.Aeson (Value (String))
+import qualified Data.ByteString.Base16 as HEX
+import           Data.ByteString.Lazy (fromStrict)
+import           Test.Tasty (TestTree, defaultMain, testGroup)
+import           Test.Tasty.HUnit (testCase, (@=?))
+
+
+main :: IO ()
+main = do
+  defaultMain tests
+
+
+tests :: TestTree
+tests =
+  testGroup "CBOR-JSON"
+    [ testGroup "unit tests"
+        [ testCase "decode variable ByteString as Base62Url String" $
+            Right ("", String "MDEy") @=? deserialiseFromBytes (decodeValue True)
+                                              (fromStrict . either error id $ HEX.decode "5803303132")
+        ]
+    ]