diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for canonical-json +## 0.5.0.1 2018-10-26 + +* ghc-8.4 compatibility. +* Move the test suite from the hackage-security library + ## 0.5.0.0 2017-09-06 * Canonical JSON code extracted from hackage-security-0.5.2.2 into diff --git a/Text/JSON/Canonical/Parse.hs b/Text/JSON/Canonical/Parse.hs --- a/Text/JSON/Canonical/Parse.hs +++ b/Text/JSON/Canonical/Parse.hs @@ -30,6 +30,9 @@ #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ((<$>), (<$), pure, (<*>), (<*), (*>)) #endif +#if MIN_VERSION_base(4,11,0) +import Prelude hiding ((<>)) +#endif import Data.Char (isDigit, digitToInt) import Data.Function (on) import Data.List (foldl', sortBy) diff --git a/canonical-json.cabal b/canonical-json.cabal --- a/canonical-json.cabal +++ b/canonical-json.cabal @@ -1,5 +1,5 @@ name: canonical-json -version: 0.5.0.0 +version: 0.5.0.1 synopsis: Canonical JSON for signing and hashing JSON values description: An implementation of Canonical JSON. . @@ -20,11 +20,16 @@ author: Duncan Coutts, Edsko de Vries maintainer: duncan@well-typed.com, edsko@well-typed.com copyright: Copyright 2015-2017 Well-Typed LLP +homepage: https://github.com/well-typed/canonical-json category: Text, JSON build-type: Simple extra-source-files: ChangeLog.md cabal-version: >=1.10 +source-repository head + type: git + location: https://github.com/well-typed/canonical-json.git + library exposed-modules: Text.JSON.Canonical Text.JSON.Canonical.Class @@ -38,5 +43,21 @@ containers >= 0.4 && < 0.6, parsec >= 3.1 && < 3.2, pretty >= 1.0 && < 1.2 + default-language: Haskell2010 + ghc-options: -Wall + +test-suite tests + type: exitcode-stdio-1.0 + main-is: TestSuite.hs + hs-source-dirs: tests + build-depends: base, + bytestring, + canonical-json, + aeson == 1.4.*, + vector, + unordered-containers, + QuickCheck >= 2.11 && < 2.13, + tasty, + tasty-quickcheck default-language: Haskell2010 ghc-options: -Wall diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite.hs @@ -0,0 +1,104 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Main (main) where + +import Data.Int +import Data.List (sortBy, nubBy) +import Data.Function (on) +import qualified Data.ByteString.Lazy.Char8 as BS +import Text.JSON.Canonical + +import qualified Data.Aeson as Aeson (Value (..), eitherDecode) +import Data.String (fromString) +import qualified Data.Vector as V (fromList) +import qualified Data.HashMap.Strict as HM (fromList) + +import Test.QuickCheck +import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty (TestTree, defaultMain, testGroup) + + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Canonical JSON" [ + testProperty "prop_roundtrip_canonical" prop_roundtrip_canonical + , testProperty "prop_roundtrip_pretty" prop_roundtrip_pretty + , testProperty "prop_canonical_pretty" prop_canonical_pretty + , testProperty "prop_aeson_canonical" prop_aeson_canonical + ] + + +prop_roundtrip_canonical, + prop_roundtrip_pretty, + prop_canonical_pretty, + prop_aeson_canonical + :: JSValue -> Bool + +prop_roundtrip_canonical jsval = + parseCanonicalJSON (renderCanonicalJSON jsval) == Right (canonicalise jsval) + +prop_roundtrip_pretty jsval = + parseCanonicalJSON (BS.pack (prettyCanonicalJSON jsval)) == Right jsval + +prop_canonical_pretty jsval = + parseCanonicalJSON (renderCanonicalJSON jsval) == + fmap canonicalise (parseCanonicalJSON (BS.pack (prettyCanonicalJSON jsval))) + +prop_aeson_canonical jsval = + Aeson.eitherDecode (renderCanonicalJSON jsval) == Right (toAeson jsval) + +canonicalise :: JSValue -> JSValue +canonicalise v@JSNull = v +canonicalise v@(JSBool _) = v +canonicalise v@(JSNum _) = v +canonicalise v@(JSString _) = v +canonicalise (JSArray vs) = JSArray [ canonicalise v | v <- vs] +canonicalise (JSObject vs) = JSObject [ (k, canonicalise v) + | (k,v) <- sortBy (compare `on` fst) vs ] + +toAeson :: JSValue -> Aeson.Value +toAeson JSNull = Aeson.Null +toAeson (JSBool b) = Aeson.Bool b +toAeson (JSNum n) = Aeson.Number (fromIntegral n) +toAeson (JSString s) = Aeson.String (fromString s) +toAeson (JSArray xs) = Aeson.Array $ V.fromList [ toAeson x | x <- xs ] +toAeson (JSObject xs) = Aeson.Object $ HM.fromList [ (fromString k, toAeson v) + | (k, v) <- xs ] + +instance Arbitrary JSValue where + arbitrary = + sized $ \sz -> + frequency + [ (1, pure JSNull) + , (1, JSBool <$> arbitrary) + , (2, JSNum <$> arbitrary) + , (2, JSString . getASCIIString <$> arbitrary) + , (3, JSArray <$> resize (sz `div` 2) arbitrary) + , (3, JSObject . mapFirst getASCIIString . noDupFields <$> resize (sz `div` 2) arbitrary) + ] + where + noDupFields = nubBy (\(x,_) (y,_) -> x==y) + mapFirst f = map (\(x, y) -> (f x, y)) + + shrink JSNull = [] + shrink (JSBool _) = [] + shrink (JSNum n) = [ JSNum n' | n' <- shrink n ] + shrink (JSString s) = [ JSString s' | s' <- shrink s ] + shrink (JSArray vs) = [ JSArray vs' | vs' <- shrink vs ] + shrink (JSObject vs) = [ JSObject vs' | vs' <- shrinkList shrinkSnd vs ] + where + shrinkSnd (a,b) = [ (a,b') | b' <- shrink b ] + +instance Arbitrary Int54 where + arbitrary = fromIntegral <$> + frequency [ (1, pure lowerbound) + , (1, pure upperbound) + , (8, choose (lowerbound, upperbound)) + ] + where + upperbound, lowerbound :: Int64 + upperbound = 999999999999999 -- 15 decimal digits + lowerbound = (-999999999999999) + shrink = shrinkIntegral +