{-# LANGUAGE CPP #-}---------------------------------------------------------------------- |-- Module : Text.JSON.Parsec-- Copyright : (c) Galois, Inc. 2007-2009, Duncan Coutts 2015------ Minimal implementation of Canonical JSON.---- <http://wiki.laptop.org/go/Canonical_JSON>---- A \"canonical JSON\" format is provided in order to provide meaningful and-- repeatable hashes of JSON-encoded data. Canonical JSON is parsable with any-- full JSON parser, but security-conscious applications will want to verify-- that input is in canonical form before authenticating any hash or signature-- on that input.---- This implementation is derived from the json parser from the json package,-- with simplifications to meet the Canonical JSON grammar.---- TODO: Known bugs/limitations:---- * Decoding/encoding Unicode code-points beyond @U+00ff@ is currently broken--moduleText.JSON.Canonical(JSValue(..),Int54,parseCanonicalJSON,renderCanonicalJSON,prettyCanonicalJSON)whereimportText.ParserCombinators.Parsec(CharParser,(<|>),(<?>),many,between,sepBy,satisfy,char,string,digit,spaces,parse)importText.PrettyPrinthiding(char)importqualifiedText.PrettyPrintasDoc#if !(MIN_VERSION_base(4,7,0))importControl.Applicative((<$>),(<$),pure,(<*>),(<*),(*>))#endifimportControl.Arrow(first)importData.Bits(Bits)#if MIN_VERSION_base(4,7,0)importData.Bits(FiniteBits)#endifimportData.Char(isDigit,digitToInt)importData.Data(Data)importData.Function(on)importData.Int(Int64)importData.Ix(Ix)importData.List(foldl',sortBy)importData.Typeable(Typeable)importForeign.Storable(Storable)importText.Printf(PrintfArg)importqualifiedData.ByteString.Lazy.Char8asBSdataJSValue=JSNull|JSBool!Bool|JSNum!Int54|JSStringString|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.newtypeInt54=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)instanceBoundedInt54wheremaxBound=Int54(2^(53::Int)-1)minBound=Int54(-(2^(53::Int)-1))instanceShowInt54whereshow=show.int54ToInt64instanceReadInt54wherereadsPrecp=map(firstInt54).readsPrecp-------------------------------------------------------------------------------- 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.ByteStringrenderCanonicalJSONv=BS.pack(s_valuev[])s_value::JSValue->ShowSs_valueJSNull=showString"null"s_value(JSBoolFalse)=showString"false"s_value(JSBoolTrue)=showString"true"s_value(JSNumn)=showsns_value(JSStrings)=s_stringss_value(JSArrayvs)=s_arrayvss_value(JSObjectfs)=s_object(sortBy(compare`on`fst)fs)s_string::String->ShowSs_strings=showChar'"'.showlswhereshowl[]=showChar'"'showl(c:cs)=s_charc.showlcss_char'"'=showChar'\\'.showChar'"'s_char'\\'=showChar'\\'.showChar'\\'s_charc=showCharcs_array::[JSValue]->ShowSs_array[]=showString"[]"s_array(v0:vs0)=showChar'['.s_valuev0.showlvs0whereshowl[]=showChar']'showl(v:vs)=showChar','.s_valuev.showlvss_object::[(String,JSValue)]->ShowSs_object[]=showString"{}"s_object((k0,v0):kvs0)=showChar'{'.s_stringk0.showChar':'.s_valuev0.showlkvs0whereshowl[]=showChar'}'showl((k,v):kvs)=showChar','.s_stringk.showChar':'.s_valuev.showlkvs-------------------------------------------------------------------------------- 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->EitherStringJSValueparseCanonicalJSON=either(Left.show)Right.parsep_value"".BS.unpackp_value::CharParser()JSValuep_value=spaces*>p_jvaluetok::CharParser()a->CharParser()atokp=p<*spaces{-
value:
string
number
object
array
true
false
null
-}p_jvalue::CharParser()JSValuep_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()Boolp_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()Stringp_string=between(char'"')(tok(char'"'))(manyp_char)wherep_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',')wherep_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()Int54p_number=tok((char'-'*>(negate<$>pnat))<|>pnat<|>zero)wherepnat=(\dds->strToInt(d:ds))<$>digit19<*>manyN14digitdigit19=satisfy(\c->isDigitc&&c/='0')<?>"digit"strToInt=foldl'(\xd->10*x+digitToInt54d)0zero=0<$char'0'digitToInt54::Char->Int54digitToInt54=fromIntegral.digitToIntmanyN::Int->CharParser()a->CharParser()[a]manyN0_=pure[]manyNnp=((:)<$>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->StringprettyCanonicalJSON=render.jvaluejvalue::JSValue->DocjvalueJSNull=text"null"jvalue(JSBoolFalse)=text"false"jvalue(JSBoolTrue)=text"true"jvalue(JSNumn)=integer(fromIntegral(int54ToInt64n))jvalue(JSStrings)=jstringsjvalue(JSArrayvs)=jarrayvsjvalue(JSObjectfs)=jobjectfsjstring::String->Docjstring=doubleQuotes.hcat.mapjcharjchar::Char->Docjchar'"'=Doc.char'\\'<>Doc.char'"'jchar'\\'=Doc.char'\\'<>Doc.char'\\'jcharc=Doc.charcjarray::[JSValue]->Docjarray=sep.punctuate'lbrackcommarbrack.mapjvaluejobject::[(String,JSValue)]->Docjobject=sep.punctuate'lbracecommarbrace.map(\(k,v)->sep[jstringk<>colon,nest2(jvaluev)])-- | 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'lpr(x:xs)=l<+>x:goxswherego[]=[]go[y]=[p<+>y,r]go(y:ys)=(p<+>y):goys