diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/JSON/Canonical.hs b/Text/JSON/Canonical.hs new file mode 100644 --- /dev/null +++ b/Text/JSON/Canonical.hs @@ -0,0 +1,65 @@ +-------------------------------------------------------------------- +-- | +-- Module : Text.JSON.Canonical +-- Copyright : (c) Duncan Coutts 2017 +-- +-- +-- An implementation of 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 + diff --git a/Text/JSON/Canonical/Class.hs b/Text/JSON/Canonical/Class.hs new file mode 100644 --- /dev/null +++ b/Text/JSON/Canonical/Class.hs @@ -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') diff --git a/Text/JSON/Canonical/Parse.hs b/Text/JSON/Canonical/Parse.hs new file mode 100644 --- /dev/null +++ b/Text/JSON/Canonical/Parse.hs @@ -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. +-- +-- +-- +-- 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 + diff --git a/Text/JSON/Canonical/Types.hs b/Text/JSON/Canonical/Types.hs new file mode 100644 --- /dev/null +++ b/Text/JSON/Canonical/Types.hs @@ -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 + diff --git a/canonical-json.cabal b/canonical-json.cabal new file mode 100644 --- /dev/null +++ b/canonical-json.cabal @@ -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. + . + + . + 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