canonical-json 0.5.0.0 → 0.5.0.1
raw patch · 4 files changed
+134/−1 lines, 4 filesdep +QuickCheckdep +aesondep +canonical-jsondep ~basedep ~bytestring
Dependencies added: QuickCheck, aeson, canonical-json, tasty, tasty-quickcheck, unordered-containers, vector
Dependency ranges changed: base, bytestring
Files
- ChangeLog.md +5/−0
- Text/JSON/Canonical/Parse.hs +3/−0
- canonical-json.cabal +22/−1
- tests/TestSuite.hs +104/−0
ChangeLog.md view
@@ -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
Text/JSON/Canonical/Parse.hs view
@@ -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)
canonical-json.cabal view
@@ -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
+ tests/TestSuite.hs view
@@ -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+