canonical-json (empty) → 0.5.0.0
raw patch · 8 files changed
+705/−0 lines, 8 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, parsec, pretty
Files
- ChangeLog.md +6/−0
- LICENSE +31/−0
- Setup.hs +2/−0
- Text/JSON/Canonical.hs +65/−0
- Text/JSON/Canonical/Class.hs +196/−0
- Text/JSON/Canonical/Parse.hs +291/−0
- Text/JSON/Canonical/Types.hs +72/−0
- canonical-json.cabal +42/−0
+ ChangeLog.md view
@@ -0,0 +1,6 @@+# Revision history for canonical-json++## 0.5.0.0 2017-09-06++* Canonical JSON code extracted from hackage-security-0.5.2.2 into+ separate library.
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2015-2017 Well-Typed LLP+Portions based on the 'json' package, Copyright (c) 2007-2009 Galois, Inc.++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
+ Text/JSON/Canonical.hs view
@@ -0,0 +1,65 @@+--------------------------------------------------------------------+-- |+-- Module : Text.JSON.Canonical+-- Copyright : (c) Duncan Coutts 2017+--+--+-- An implementation of Canonical JSON.+--+-- <http://wiki.laptop.org/go/Canonical_JSON>+--+-- The \"canonical JSON\" format is designed to provide repeatable hashes of+-- JSON-encoded data. It is designed for applications that need to hash, sign+-- or authenitcate JSON data structures.+--+-- The format is an extended subset of the normal JSON format.+--+-- Canonical JSON is parsable with any full JSON parser, and it allows+-- whitespace for pretty-printed human readable presentation, but it can be put+-- into a canonical form which then has a stable serialised representation and+-- thus a stable hash.+--+-- The basic concept is that a file in the canonical JSON format can be read+-- using 'parseCanonicalJSON'. Note that this input file does /not/ itself need+-- to be in canonical form, it just needs to be in the canonical JSON format.+-- Then the 'renderCanonicalJSON' function is used to render into the canonical+-- form. This is then the form that can be hashed or signed etc.+--+-- The 'prettyCanonicalJSON' is for convenience to render in a human readable+-- style, since the canoncal form eliminates unnecessary white space which+-- makes the output hard to read. This style is again suitable to read using+-- 'parseCanonicalJSON'. So this is suitable to use for producing output that+-- has to be later hashed or otherwise checked.+--+-- Known bugs\/limitations:+--+-- * Decoding\/encoding Unicode code-points beyond @U+00ff@ is currently broken+--+module Text.JSON.Canonical (+ -- * Types+ JSValue(..)+ , Int54+ -- * Parsing and printing+ , parseCanonicalJSON+ , renderCanonicalJSON+ , prettyCanonicalJSON+ -- * Type classes+ , ToJSON(..)+ , FromJSON(..)+ , ToObjectKey(..)+ , FromObjectKey(..)+ , ReportSchemaErrors(..)+ , Expected+ , Got+ , expectedButGotValue+ -- * Utility+ , fromJSObject+ , fromJSField+ , fromJSOptField+ , mkObject+ ) where++import Text.JSON.Canonical.Types+import Text.JSON.Canonical.Parse+import Text.JSON.Canonical.Class+
+ Text/JSON/Canonical/Class.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-}+#endif++--------------------------------------------------------------------+-- |+-- Module : Text.JSON.Canonical.Class+-- Copyright : (c) Edsko de Vries, Duncan Coutts 2015+--+--+-- Type classes and utilities for converting to and from 'JSValue'.+--+module Text.JSON.Canonical.Class (+ -- * Type classes+ ToJSON(..)+ , FromJSON(..)+ , ToObjectKey(..)+ , FromObjectKey(..)+ , ReportSchemaErrors(..)+ , Expected+ , Got+ , expectedButGotValue+ -- * Utility+ , fromJSObject+ , fromJSField+ , fromJSOptField+ , mkObject+ ) where++import Text.JSON.Canonical.Types++import Control.Monad (liftM)+import Data.Maybe (catMaybes)+import Data.Map (Map)+import qualified Data.Map as Map++#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative (Applicative, (<$>), (<*>))+#endif+++--import Hackage.Security.Util.Path++{-------------------------------------------------------------------------------+ ToJSON and FromJSON classes++ We parameterize over the monad here to avoid mutual module dependencies.+-------------------------------------------------------------------------------}++class ToJSON m a where+ toJSON :: a -> m JSValue++class FromJSON m a where+ fromJSON :: JSValue -> m a++-- | Used in the 'ToJSON' instance for 'Map'+class ToObjectKey m a where+ toObjectKey :: a -> m String++-- | Used in the 'FromJSON' instance for 'Map'+class FromObjectKey m a where+ fromObjectKey :: String -> m (Maybe a)++-- | Monads in which we can report schema errors+class (Applicative m, Monad m) => ReportSchemaErrors m where+ expected :: Expected -> Maybe Got -> m a++type Expected = String+type Got = String++expectedButGotValue :: ReportSchemaErrors m => Expected -> JSValue -> m a+expectedButGotValue descr val = expected descr (Just (describeValue val))+ where+ describeValue :: JSValue -> String+ describeValue (JSNull ) = "null"+ describeValue (JSBool _) = "bool"+ describeValue (JSNum _) = "num"+ describeValue (JSString _) = "string"+ describeValue (JSArray _) = "array"+ describeValue (JSObject _) = "object"++unknownField :: ReportSchemaErrors m => String -> m a+unknownField field = expected ("field " ++ show field) Nothing++{-------------------------------------------------------------------------------+ ToObjectKey and FromObjectKey instances+-------------------------------------------------------------------------------}++instance Monad m => ToObjectKey m String where+ toObjectKey = return++instance Monad m => FromObjectKey m String where+ fromObjectKey = return . Just++{-------------------------------------------------------------------------------+ ToJSON and FromJSON instances+-------------------------------------------------------------------------------}++instance Monad m => ToJSON m JSValue where+ toJSON = return++instance Monad m => FromJSON m JSValue where+ fromJSON = return++instance Monad m => ToJSON m String where+ toJSON = return . JSString++instance ReportSchemaErrors m => FromJSON m String where+ fromJSON (JSString str) = return str+ fromJSON val = expectedButGotValue "string" val++instance Monad m => ToJSON m Int54 where+ toJSON = return . JSNum++instance ReportSchemaErrors m => FromJSON m Int54 where+ fromJSON (JSNum i) = return i+ fromJSON val = expectedButGotValue "int" val++instance+#if __GLASGOW_HASKELL__ >= 710+ {-# OVERLAPPABLE #-}+#endif+ (Monad m, ToJSON m a) => ToJSON m [a] where+ toJSON = liftM JSArray . mapM toJSON++instance+#if __GLASGOW_HASKELL__ >= 710+ {-# OVERLAPPABLE #-}+#endif+ (ReportSchemaErrors m, FromJSON m a) => FromJSON m [a] where+ fromJSON (JSArray as) = mapM fromJSON as+ fromJSON val = expectedButGotValue "array" val+++instance ( Monad m+ , ToObjectKey m k+ , ToJSON m a+ ) => ToJSON m (Map k a) where+ toJSON = liftM JSObject . mapM aux . Map.toList+ where+ aux :: (k, a) -> m (String, JSValue)+ aux (k, a) = do k' <- toObjectKey k; a' <- toJSON a; return (k', a')++instance ( ReportSchemaErrors m+ , Ord k+ , FromObjectKey m k+ , FromJSON m a+ ) => FromJSON m (Map k a) where+ fromJSON enc = do+ obj <- fromJSObject enc+ Map.fromList . catMaybes <$> mapM aux obj+ where+ aux :: (String, JSValue) -> m (Maybe (k, a))+ aux (k, a) = knownKeys <$> fromObjectKey k <*> fromJSON a+ knownKeys :: Maybe k -> a -> Maybe (k, a)+ knownKeys Nothing _ = Nothing+ knownKeys (Just k) a = Just (k, a)+++{-------------------------------------------------------------------------------+ Utility+-------------------------------------------------------------------------------}++fromJSObject :: ReportSchemaErrors m => JSValue -> m [(String, JSValue)]+fromJSObject (JSObject obj) = return obj+fromJSObject val = expectedButGotValue "object" val++-- | Extract a field from a JSON object+fromJSField :: (ReportSchemaErrors m, FromJSON m a)+ => JSValue -> String -> m a+fromJSField val nm = do+ obj <- fromJSObject val+ case lookup nm obj of+ Just fld -> fromJSON fld+ Nothing -> unknownField nm++fromJSOptField :: (ReportSchemaErrors m, FromJSON m a)+ => JSValue -> String -> m (Maybe a)+fromJSOptField val nm = do+ obj <- fromJSObject val+ case lookup nm obj of+ Just fld -> Just <$> fromJSON fld+ Nothing -> return Nothing++mkObject :: forall m. Monad m => [(String, m JSValue)] -> m JSValue+mkObject = liftM JSObject . sequenceFields+ where+ sequenceFields :: [(String, m JSValue)] -> m [(String, JSValue)]+ sequenceFields [] = return []+ sequenceFields ((fld,val):flds) = do val' <- val+ flds' <- sequenceFields flds+ return ((fld,val'):flds')
+ Text/JSON/Canonical/Parse.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE CPP #-}+--------------------------------------------------------------------+-- |+-- Module : Text.JSON.Canonical.Parse+-- Copyright : (c) Galois, Inc. 2007-2009, Duncan Coutts 2015, 2017+--+--+-- Minimal implementation of Canonical JSON parsing and printing.+--+-- <http://wiki.laptop.org/go/Canonical_JSON>+--+-- TODO: Known bugs/limitations:+--+-- * Decoding/encoding Unicode code-points beyond @U+00ff@ is currently broken+--+module Text.JSON.Canonical.Parse+ ( parseCanonicalJSON+ , renderCanonicalJSON+ , prettyCanonicalJSON+ ) where++import Text.JSON.Canonical.Types++import Text.ParserCombinators.Parsec+ ( CharParser, (<|>), (<?>), many, between, sepBy+ , satisfy, char, string, digit, spaces+ , parse )+import Text.PrettyPrint hiding (char)+import qualified Text.PrettyPrint as Doc+#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative ((<$>), (<$), pure, (<*>), (<*), (*>))+#endif+import Data.Char (isDigit, digitToInt)+import Data.Function (on)+import Data.List (foldl', sortBy)+import qualified Data.ByteString.Lazy.Char8 as BS++++------------------------------------------------------------------------------+-- rendering flat+--++-- | Render a JSON value in canonical form. This rendered form is canonical+-- and so allows repeatable hashes.+--+-- For pretty printing, see prettyCanonicalJSON.+--+-- NB: Canonical JSON's string escaping rules deviate from RFC 7159+-- JSON which requires+--+-- "All Unicode characters may be placed within the quotation+-- marks, except for the characters that must be escaped: quotation+-- mark, reverse solidus, and the control characters (@U+0000@+-- through @U+001F@)."+--+-- Whereas the current specification of Canonical JSON explicitly+-- requires to violate this by only escaping the quotation mark and+-- the reverse solidus. This, however, contradicts Canonical JSON's+-- statement that "Canonical JSON is parsable with any full JSON+-- parser"+--+-- Consequently, Canonical JSON is not a proper subset of RFC 7159.+--+renderCanonicalJSON :: JSValue -> BS.ByteString+renderCanonicalJSON v = BS.pack (s_value v [])++s_value :: JSValue -> ShowS+s_value JSNull = showString "null"+s_value (JSBool False) = showString "false"+s_value (JSBool True) = showString "true"+s_value (JSNum n) = shows n+s_value (JSString s) = s_string s+s_value (JSArray vs) = s_array vs+s_value (JSObject fs) = s_object (sortBy (compare `on` fst) fs)++s_string :: String -> ShowS+s_string s = showChar '"' . showl s+ where showl [] = showChar '"'+ showl (c:cs) = s_char c . showl cs++ s_char '"' = showChar '\\' . showChar '"'+ s_char '\\' = showChar '\\' . showChar '\\'+ s_char c = showChar c++s_array :: [JSValue] -> ShowS+s_array [] = showString "[]"+s_array (v0:vs0) = showChar '[' . s_value v0 . showl vs0+ where showl [] = showChar ']'+ showl (v:vs) = showChar ',' . s_value v . showl vs++s_object :: [(String, JSValue)] -> ShowS+s_object [] = showString "{}"+s_object ((k0,v0):kvs0) = showChar '{' . s_string k0+ . showChar ':' . s_value v0+ . showl kvs0+ where showl [] = showChar '}'+ showl ((k,v):kvs) = showChar ',' . s_string k+ . showChar ':' . s_value v+ . showl kvs++------------------------------------------------------------------------------+-- parsing+--++-- | Parse a canonical JSON format string as a JSON value. The input string+-- does not have to be in canonical form, just in the \"canonical JSON\"+-- format.+--+-- Use 'renderCanonicalJSON' to convert into canonical form.+--+parseCanonicalJSON :: BS.ByteString -> Either String JSValue+parseCanonicalJSON = either (Left . show) Right+ . parse p_value ""+ . BS.unpack++p_value :: CharParser () JSValue+p_value = spaces *> p_jvalue++tok :: CharParser () a -> CharParser () a+tok p = p <* spaces++{-+value:+ string+ number+ object+ array+ true+ false+ null+-}+p_jvalue :: CharParser () JSValue+p_jvalue = (JSNull <$ p_null)+ <|> (JSBool <$> p_boolean)+ <|> (JSArray <$> p_array)+ <|> (JSString <$> p_string)+ <|> (JSObject <$> p_object)+ <|> (JSNum <$> p_number)+ <?> "JSON value"++p_null :: CharParser () ()+p_null = tok (string "null") >> return ()++p_boolean :: CharParser () Bool+p_boolean = tok+ ( (True <$ string "true")+ <|> (False <$ string "false")+ )+{-+array:+ []+ [ elements ]+elements:+ value+ value , elements+-}+p_array :: CharParser () [JSValue]+p_array = between (tok (char '[')) (tok (char ']'))+ $ p_jvalue `sepBy` tok (char ',')++{-+string:+ ""+ " chars "+chars:+ char+ char chars+char:+ any byte except hex 22 (") or hex 5C (\)+ \\+ \"+-}+p_string :: CharParser () String+p_string = between (char '"') (tok (char '"')) (many p_char)+ where p_char = (char '\\' >> p_esc)+ <|> (satisfy (\x -> x /= '"' && x /= '\\'))++ p_esc = ('"' <$ char '"')+ <|> ('\\' <$ char '\\')+ <?> "escape character"+{-+object:+ {}+ { members }+members:+ pair+ pair , members+pair:+ string : value+-}+p_object :: CharParser () [(String,JSValue)]+p_object = between (tok (char '{')) (tok (char '}'))+ $ p_field `sepBy` tok (char ',')+ where p_field = (,) <$> (p_string <* tok (char ':')) <*> p_jvalue++{-+number:+ int+int:+ digit+ digit1-9 digits+ - digit1-9+ - digit1-9 digits+digits:+ digit+ digit digits+-}++-- | Parse an int+--+-- TODO: Currently this allows for a maximum of 15 digits (i.e. a maximum value+-- of @999,999,999,999,999@) as a crude approximation of the 'Int54' range.+p_number :: CharParser () Int54+p_number = tok+ ( (char '-' *> (negate <$> pnat))+ <|> pnat+ <|> zero+ )+ where pnat = (\d ds -> strToInt (d:ds)) <$> digit19 <*> manyN 14 digit+ digit19 = satisfy (\c -> isDigit c && c /= '0') <?> "digit"+ strToInt = foldl' (\x d -> 10*x + digitToInt54 d) 0+ zero = 0 <$ char '0'++digitToInt54 :: Char -> Int54+digitToInt54 = fromIntegral . digitToInt++manyN :: Int -> CharParser () a -> CharParser () [a]+manyN 0 _ = pure []+manyN n p = ((:) <$> p <*> manyN (n-1) p)+ <|> pure []++------------------------------------------------------------------------------+-- rendering nicely+--++-- | Render a JSON value in a reasonable human-readable form. This rendered+-- form is /not the canonical form/ used for repeatable hashes, use+-- 'renderCanonicalJSON' for that.++-- It is suitable however as an external form as any canonical JSON parser can+-- read it and convert it into the form used for repeatable hashes.+--+prettyCanonicalJSON :: JSValue -> String+prettyCanonicalJSON = render . jvalue++jvalue :: JSValue -> Doc+jvalue JSNull = text "null"+jvalue (JSBool False) = text "false"+jvalue (JSBool True) = text "true"+jvalue (JSNum n) = integer (fromIntegral (int54ToInt64 n))+jvalue (JSString s) = jstring s+jvalue (JSArray vs) = jarray vs+jvalue (JSObject fs) = jobject fs++jstring :: String -> Doc+jstring = doubleQuotes . hcat . map jchar++jchar :: Char -> Doc+jchar '"' = Doc.char '\\' <> Doc.char '"'+jchar '\\' = Doc.char '\\' <> Doc.char '\\'+jchar c = Doc.char c++jarray :: [JSValue] -> Doc+jarray = sep . punctuate' lbrack comma rbrack+ . map jvalue++jobject :: [(String, JSValue)] -> Doc+jobject = sep . punctuate' lbrace comma rbrace+ . map (\(k,v) -> sep [jstring k <> colon, nest 2 (jvalue v)])+++-- | Punctuate in this style:+--+-- > [ foo, bar ]+--+-- if it fits, or vertically otherwise:+--+-- > [ foo+-- > , bar+-- > ]+--+punctuate' :: Doc -> Doc -> Doc -> [Doc] -> [Doc]+punctuate' l _ r [] = [l <> r]+punctuate' l _ r [x] = [l <+> x <+> r]+punctuate' l p r (x:xs) = l <+> x : go xs+ where+ go [] = []+ go [y] = [p <+> y, r]+ go (y:ys) = (p <+> y) : go ys+
+ Text/JSON/Canonical/Types.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+--------------------------------------------------------------------+-- |+-- Module : Text.JSON.Canonical.Types+-- Copyright : (c) Duncan Coutts 2015, 2017+--+module Text.JSON.Canonical.Types+ ( JSValue(..)+ , Int54(..)+ ) where++import Control.Arrow (first)+import Data.Bits (Bits)+#if MIN_VERSION_base(4,7,0)+import Data.Bits (FiniteBits)+#endif+import Data.Data (Data)+import Data.Int (Int64)+import Data.Ix (Ix)+import Data.Typeable (Typeable)+import Foreign.Storable (Storable)+import Text.Printf (PrintfArg)+++data JSValue+ = JSNull+ | JSBool !Bool+ | JSNum !Int54+ | JSString String+ | JSArray [JSValue]+ | JSObject [(String, JSValue)]+ deriving (Show, Read, Eq, Ord)++-- | 54-bit integer values+--+-- JavaScript can only safely represent numbers between @-(2^53 - 1)@ and+-- @2^53 - 1@.+--+-- TODO: Although we introduce the type here, we don't actually do any bounds+-- checking and just inherit all type class instance from Int64. We should+-- probably define `fromInteger` to do bounds checking, give different instances+-- for type classes such as `Bounded` and `FiniteBits`, etc.+newtype Int54 = Int54 { int54ToInt64 :: Int64 }+ deriving ( Enum+ , Eq+ , Integral+ , Data+ , Num+ , Ord+ , Real+ , Ix+#if MIN_VERSION_base(4,7,0)+ , FiniteBits+#endif+ , Bits+ , Storable+ , PrintfArg+ , Typeable+ )++instance Bounded Int54 where+ maxBound = Int54 ( 2^(53 :: Int) - 1)+ minBound = Int54 (-(2^(53 :: Int) - 1))++instance Show Int54 where+ show = show . int54ToInt64++instance Read Int54 where+ readsPrec p = map (first Int54) . readsPrec p+
+ canonical-json.cabal view
@@ -0,0 +1,42 @@+name: canonical-json+version: 0.5.0.0+synopsis: Canonical JSON for signing and hashing JSON values+description: An implementation of Canonical JSON.+ .+ <http://wiki.laptop.org/go/Canonical_JSON>+ .+ The \"canonical JSON\" format is designed to provide+ repeatable hashes of JSON-encoded data. It is designed+ for applications that need to hash, sign or authenitcate+ JSON data structures, including embedded signatures.+ .+ Canonical JSON is parsable with any full JSON parser, and+ it allows whitespace for pretty-printed human readable+ presentation, but it can be put into a canonical form+ which then has a stable serialised representation and+ thus a stable hash.+license: BSD3+license-file: LICENSE+author: Duncan Coutts, Edsko de Vries+maintainer: duncan@well-typed.com, edsko@well-typed.com+copyright: Copyright 2015-2017 Well-Typed LLP+category: Text, JSON+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++library+ exposed-modules: Text.JSON.Canonical+ Text.JSON.Canonical.Class+ Text.JSON.Canonical.Parse+ Text.JSON.Canonical.Types+ other-extensions: CPP, GeneralizedNewtypeDeriving, DeriveDataTypeable,+ MultiParamTypeClasses, FlexibleInstances,+ ScopedTypeVariables, OverlappingInstances+ build-depends: base >= 4.5 && < 5,+ bytestring >= 0.9 && < 0.11,+ containers >= 0.4 && < 0.6,+ parsec >= 3.1 && < 3.2,+ pretty >= 1.0 && < 1.2+ default-language: Haskell2010+ ghc-options: -Wall