diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,15 @@ # Revision history for canonical-json +## 0.6.0.0 2019-07-31 + +* Introduced JSString type rather than using String, for improved memory use. + +* Improved parser performance + +* Reduce stack space usage and introduce stack use tests + +* Added benchmarks + ## 0.5.0.1 2018-10-26 * ghc-8.4 compatibility. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,45 @@ +An implementation of [Canonical JSON]. + +The "canonical JSON" format is designed to provide repeatable hashes of +JSON values. 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 white +space 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. + +See the [API docs] on Hackage. + +This package has been extracted from the [hackage-security] package where +canonical JSON is used for all the signed TUF files, such as the +[root keys file], etc. As you can see from that, canoncal JSON allows keeping +JSON files in a human readable pretty-printed form, and still allows verifying +signatures. In particular this demonstrates the use of embedded signatures, +where the `root.json` both contains a body value and multiple signatures of +that body all within the same file. This is because canoncal JSON is about +hashes for *JSON values, not serialised JSON text*. + +[Canonical JSON]: http://wiki.laptop.org/go/Canonical_JSON +[API docs]: https://hackage.haskell.org/package/canonical-json +[hackage-security]: https://hackage.haskell.org/package/hackage-security +[root keys file]: https://hackage.haskell.org/root.json + + +Known bugs limitations +----------------------- + + * Decoding/encoding Unicode code-points beyond `U+00ff` is currently broken + diff --git a/Text/JSON/Canonical.hs b/Text/JSON/Canonical.hs --- a/Text/JSON/Canonical.hs +++ b/Text/JSON/Canonical.hs @@ -39,6 +39,7 @@ -- * Types JSValue(..) , Int54 + , JSString -- * Parsing and printing , parseCanonicalJSON , renderCanonicalJSON @@ -53,6 +54,8 @@ , Got , expectedButGotValue -- * Utility + , toJSString + , fromJSString , fromJSObject , fromJSField , fromJSOptField diff --git a/Text/JSON/Canonical/Class.hs b/Text/JSON/Canonical/Class.hs --- a/Text/JSON/Canonical/Class.hs +++ b/Text/JSON/Canonical/Class.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -33,7 +34,7 @@ import Text.JSON.Canonical.Types -import Control.Monad (liftM) +import Control.Monad (foldM, liftM) import Data.Maybe (catMaybes) import Data.Map (Map) import qualified Data.Map as Map @@ -59,11 +60,11 @@ -- | Used in the 'ToJSON' instance for 'Map' class ToObjectKey m a where - toObjectKey :: a -> m String + toObjectKey :: a -> m JSString -- | Used in the 'FromJSON' instance for 'Map' class FromObjectKey m a where - fromObjectKey :: String -> m (Maybe a) + fromObjectKey :: JSString -> m (Maybe a) -- | Monads in which we can report schema errors class (Applicative m, Monad m) => ReportSchemaErrors m where @@ -83,19 +84,25 @@ describeValue (JSArray _) = "array" describeValue (JSObject _) = "object" -unknownField :: ReportSchemaErrors m => String -> m a +unknownField :: ReportSchemaErrors m => JSString -> m a unknownField field = expected ("field " ++ show field) Nothing {------------------------------------------------------------------------------- ToObjectKey and FromObjectKey instances -------------------------------------------------------------------------------} -instance Monad m => ToObjectKey m String where +instance Monad m => ToObjectKey m JSString where toObjectKey = return -instance Monad m => FromObjectKey m String where +instance Monad m => FromObjectKey m JSString where fromObjectKey = return . Just +instance Monad m => ToObjectKey m String where + toObjectKey = return . toJSString + +instance Monad m => FromObjectKey m String where + fromObjectKey = return . Just . fromJSString + {------------------------------------------------------------------------------- ToJSON and FromJSON instances -------------------------------------------------------------------------------} @@ -106,13 +113,20 @@ instance Monad m => FromJSON m JSValue where fromJSON = return -instance Monad m => ToJSON m String where +instance Monad m => ToJSON m JSString where toJSON = return . JSString -instance ReportSchemaErrors m => FromJSON m String where +instance ReportSchemaErrors m => FromJSON m JSString where fromJSON (JSString str) = return str fromJSON val = expectedButGotValue "string" val +instance Monad m => ToJSON m String where + toJSON = return . JSString . toJSString + +instance ReportSchemaErrors m => FromJSON m String where + fromJSON (JSString str) = return (fromJSString str) + fromJSON val = expectedButGotValue "string" val + instance Monad m => ToJSON m Int54 where toJSON = return . JSNum @@ -125,14 +139,14 @@ {-# OVERLAPPABLE #-} #endif (Monad m, ToJSON m a) => ToJSON m [a] where - toJSON = liftM JSArray . mapM toJSON + 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 (JSArray as) = mapM' fromJSON as fromJSON val = expectedButGotValue "array" val @@ -140,10 +154,10 @@ , ToObjectKey m k , ToJSON m a ) => ToJSON m (Map k a) where - toJSON = liftM JSObject . mapM aux . Map.toList + 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') + aux :: (k, a) -> m (JSString, JSValue) + aux (k, a) = (,) <$> toObjectKey k <*> toJSON a instance ( ReportSchemaErrors m , Ord k @@ -152,26 +166,25 @@ ) => FromJSON m (Map k a) where fromJSON enc = do obj <- fromJSObject enc - Map.fromList . catMaybes <$> mapM aux obj + Map.fromList . catMaybes <$> mapM_reverse aux obj where - aux :: (String, JSValue) -> m (Maybe (k, a)) + aux :: (JSString, 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 :: ReportSchemaErrors m => JSValue -> m [(JSString, 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 + => JSValue -> JSString -> m a fromJSField val nm = do obj <- fromJSObject val case lookup nm obj of @@ -179,18 +192,27 @@ Nothing -> unknownField nm fromJSOptField :: (ReportSchemaErrors m, FromJSON m a) - => JSValue -> String -> m (Maybe a) + => JSValue -> JSString -> 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 :: forall m. Monad m => [(JSString, m JSValue)] -> m JSValue mkObject = liftM JSObject . sequenceFields where - sequenceFields :: [(String, m JSValue)] -> m [(String, JSValue)] + sequenceFields :: [(JSString, m JSValue)] -> m [(JSString, JSValue)] sequenceFields [] = return [] sequenceFields ((fld,val):flds) = do val' <- val flds' <- sequenceFields flds return ((fld,val'):flds') + +-- Avoid stack overflow on large lists +mapM' :: Monad m => (a -> m b) -> [a] -> m [b] +mapM' f = fmap reverse . mapM_reverse f + +-- For when we don't care about order, can avoid the reverse +mapM_reverse :: Monad m => (a -> m b) -> [a] -> m [b] +mapM_reverse f = foldM (\xs a -> fmap (:xs) (f a)) [] + 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 @@ -21,10 +21,12 @@ import Text.JSON.Canonical.Types -import Text.ParserCombinators.Parsec - ( CharParser, (<|>), (), many, between, sepBy +import Text.Parsec + ( (<|>), (), many, between, sepBy , satisfy, char, string, digit, spaces , parse ) +import Text.Parsec.ByteString.Lazy + ( Parser ) import Text.PrettyPrint hiding (char) import qualified Text.PrettyPrint as Doc #if !(MIN_VERSION_base(4,8,0)) @@ -77,8 +79,8 @@ 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 +s_string :: JSString -> ShowS +s_string s = showChar '"' . showl (fromJSString s) where showl [] = showChar '"' showl (c:cs) = s_char c . showl cs @@ -92,7 +94,7 @@ where showl [] = showChar ']' showl (v:vs) = showChar ',' . s_value v . showl vs -s_object :: [(String, JSValue)] -> ShowS +s_object :: [(JSString, JSValue)] -> ShowS s_object [] = showString "{}" s_object ((k0,v0):kvs0) = showChar '{' . s_string k0 . showChar ':' . s_value v0 @@ -115,12 +117,11 @@ parseCanonicalJSON :: BS.ByteString -> Either String JSValue parseCanonicalJSON = either (Left . show) Right . parse p_value "" - . BS.unpack -p_value :: CharParser () JSValue +p_value :: Parser JSValue p_value = spaces *> p_jvalue -tok :: CharParser () a -> CharParser () a +tok :: Parser a -> Parser a tok p = p <* spaces {- @@ -133,7 +134,7 @@ false null -} -p_jvalue :: CharParser () JSValue +p_jvalue :: Parser JSValue p_jvalue = (JSNull <$ p_null) <|> (JSBool <$> p_boolean) <|> (JSArray <$> p_array) @@ -142,10 +143,10 @@ <|> (JSNum <$> p_number) "JSON value" -p_null :: CharParser () () +p_null :: Parser () p_null = tok (string "null") >> return () -p_boolean :: CharParser () Bool +p_boolean :: Parser Bool p_boolean = tok ( (True <$ string "true") <|> (False <$ string "false") @@ -158,7 +159,7 @@ value value , elements -} -p_array :: CharParser () [JSValue] +p_array :: Parser [JSValue] p_array = between (tok (char '[')) (tok (char ']')) $ p_jvalue `sepBy` tok (char ',') @@ -174,8 +175,9 @@ \\ \" -} -p_string :: CharParser () String -p_string = between (char '"') (tok (char '"')) (many p_char) +p_string :: Parser JSString +p_string = between (char '"') (tok (char '"')) + (many p_char >>= \str -> return $! toJSString str) where p_char = (char '\\' >> p_esc) <|> (satisfy (\x -> x /= '"' && x /= '\\')) @@ -192,7 +194,7 @@ pair: string : value -} -p_object :: CharParser () [(String,JSValue)] +p_object :: Parser [(JSString, JSValue)] p_object = between (tok (char '{')) (tok (char '}')) $ p_field `sepBy` tok (char ',') where p_field = (,) <$> (p_string <* tok (char ':')) <*> p_jvalue @@ -214,7 +216,7 @@ -- -- 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 :: Parser Int54 p_number = tok ( (char '-' *> (negate <$> pnat)) <|> pnat @@ -228,7 +230,7 @@ digitToInt54 :: Char -> Int54 digitToInt54 = fromIntegral . digitToInt -manyN :: Int -> CharParser () a -> CharParser () [a] +manyN :: Int -> Parser a -> Parser [a] manyN 0 _ = pure [] manyN n p = ((:) <$> p <*> manyN (n-1) p) <|> pure [] @@ -256,8 +258,8 @@ jvalue (JSArray vs) = jarray vs jvalue (JSObject fs) = jobject fs -jstring :: String -> Doc -jstring = doubleQuotes . hcat . map jchar +jstring :: JSString -> Doc +jstring = doubleQuotes . hcat . map jchar . fromJSString jchar :: Char -> Doc jchar '"' = Doc.char '\\' <> Doc.char '"' @@ -268,7 +270,7 @@ jarray = sep . punctuate' lbrack comma rbrack . map jvalue -jobject :: [(String, JSValue)] -> Doc +jobject :: [(JSString, JSValue)] -> Doc jobject = sep . punctuate' lbrace comma rbrace . map (\(k,v) -> sep [jstring k <> colon, nest 2 (jvalue v)]) diff --git a/Text/JSON/Canonical/Types.hs b/Text/JSON/Canonical/Types.hs --- a/Text/JSON/Canonical/Types.hs +++ b/Text/JSON/Canonical/Types.hs @@ -9,9 +9,13 @@ module Text.JSON.Canonical.Types ( JSValue(..) , Int54(..) + , JSString + , toJSString + , fromJSString ) where import Control.Arrow (first) +import Control.DeepSeq (NFData(..)) import Data.Bits (Bits) #if MIN_VERSION_base(4,7,0) import Data.Bits (FiniteBits) @@ -19,19 +23,72 @@ import Data.Data (Data) import Data.Int (Int64) import Data.Ix (Ix) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid) +#endif +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup) +#endif import Data.Typeable (Typeable) import Foreign.Storable (Storable) +#if MIN_VERSION_base(4,7,0) +import Text.Printf (PrintfArg(..)) +import qualified Text.Printf as Printf +#else import Text.Printf (PrintfArg) +#endif +import Data.String (IsString) +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as BS data JSValue = JSNull | JSBool !Bool | JSNum !Int54 - | JSString String + | JSString !JSString | JSArray [JSValue] - | JSObject [(String, JSValue)] + | JSObject [(JSString, JSValue)] deriving (Show, Read, Eq, Ord) + +instance NFData JSValue where + rnf JSNull = () + rnf JSBool{} = () + rnf JSNum{} = () + rnf JSString{} = () + rnf (JSArray vs) = rnf vs + rnf (JSObject vs) = rnf vs + +-- | Canonical JSON strings are in fact just bytes. +-- +newtype JSString = JStr ShortByteString + deriving (Eq, Ord, IsString, +#if MIN_VERSION_base(4,9,0) + Semigroup, +#endif + Monoid) + +instance NFData JSString where + rnf JStr{} = () + +instance Show JSString where + showsPrec n (JStr bs) = showsPrec n bs + +instance Read JSString where + readsPrec p = map (first JStr) . readsPrec p + +#if MIN_VERSION_base(4,7,0) +instance PrintfArg JSString where + formatArg = Printf.formatString . fromJSString +#endif + +toJSString :: String -> JSString +toJSString str + | all (<= '\255') str = JStr . BS.pack . map (fromIntegral . fromEnum) $ str + | otherwise = error "toJSString: cannot use non-ASCII chars" + +fromJSString :: JSString -> String +fromJSString = map (toEnum . fromIntegral) . BS.unpack . (\(JStr bs) -> bs) -- | 54-bit integer values -- diff --git a/benchmark/Parse.hs b/benchmark/Parse.hs new file mode 100644 --- /dev/null +++ b/benchmark/Parse.hs @@ -0,0 +1,15 @@ + +import Text.JSON.Canonical.Parse + +import qualified Data.ByteString.Lazy as BS + +import Criterion.Main + +main :: IO () +main = defaultMain [ + env loadData $ \jsondata -> + bench "parse" $ nf parseCanonicalJSON jsondata + ] + +loadData :: IO BS.ByteString +loadData = BS.readFile "benchmark/cardano-genesis.json" 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.1 +version: 0.6.0.0 synopsis: Canonical JSON for signing and hashing JSON values description: An implementation of Canonical JSON. . @@ -19,13 +19,15 @@ 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 +copyright: Copyright 2015-2018 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 +extra-source-files: README.md + source-repository head type: git location: https://github.com/well-typed/canonical-json.git @@ -39,8 +41,9 @@ MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables, OverlappingInstances build-depends: base >= 4.5 && < 5, - bytestring >= 0.9 && < 0.11, - containers >= 0.4 && < 0.6, + bytestring >= 0.10.4 && < 0.11, + containers >= 0.4 && < 0.7, + deepseq >= 1.2 && < 1.5, parsec >= 3.1 && < 3.2, pretty >= 1.0 && < 1.2 default-language: Haskell2010 @@ -53,6 +56,7 @@ build-depends: base, bytestring, canonical-json, + containers, aeson == 1.4.*, vector, unordered-containers, @@ -60,4 +64,17 @@ tasty, tasty-quickcheck default-language: Haskell2010 - ghc-options: -Wall + -- -K100k to check for stack overflow: + ghc-options: -Wall -with-rtsopts=-K100k + +benchmark parse-bench + type: exitcode-stdio-1.0 + main-is: Parse.hs + hs-source-dirs: benchmark + build-depends: base, + bytestring, + canonical-json, + containers, + criterion >= 1.1 + default-language: Haskell2010 + ghc-options: -Wall -rtsopts diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where @@ -7,8 +9,13 @@ import qualified Data.ByteString.Lazy.Char8 as BS import Text.JSON.Canonical +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative (Applicative(..), (<$>)) +#endif + import qualified Data.Aeson as Aeson (Value (..), eitherDecode) -import Data.String (fromString) +import Data.String (IsString, fromString) +import qualified Data.Map as Map import qualified Data.Vector as V (fromList) import qualified Data.HashMap.Strict as HM (fromList) @@ -26,6 +33,16 @@ , testProperty "prop_roundtrip_pretty" prop_roundtrip_pretty , testProperty "prop_canonical_pretty" prop_canonical_pretty , testProperty "prop_aeson_canonical" prop_aeson_canonical + , testGroup "prop_toJSON_fromJSON" [ + testProperty "String" prop_toJSON_fromJSON_String + , testProperty "Int54" prop_toJSON_fromJSON_Int54 + , testProperty "[]" prop_toJSON_fromJSON_List + , testProperty "Map" prop_toJSON_fromJSON_Map + ] + , testGroup "no stack overflow" [ + testProperty "[]" unit_large_List + , testProperty "Map" unit_large_Map + ] ] @@ -48,6 +65,43 @@ prop_aeson_canonical jsval = Aeson.eitherDecode (renderCanonicalJSON jsval) == Right (toAeson jsval) +prop_toJSON_fromJSON :: (Monad m, ToJSON m a, FromJSON m a, Eq a) => a -> m Bool +prop_toJSON_fromJSON x = + toJSON x >>= fromJSON >>= \x' -> return (x' == x) + +prop_toJSON_fromJSON_String :: JSString -> Property +prop_toJSON_fromJSON_String = runM . prop_toJSON_fromJSON + +prop_toJSON_fromJSON_Int54 :: Int54 -> Property +prop_toJSON_fromJSON_Int54 = runM . prop_toJSON_fromJSON + +prop_toJSON_fromJSON_List :: [JSString] -> Property +prop_toJSON_fromJSON_List = runM . prop_toJSON_fromJSON + +prop_toJSON_fromJSON_Map :: Map.Map JSString JSString -> Property +prop_toJSON_fromJSON_Map = runM . prop_toJSON_fromJSON + +unit_large_List :: Property +unit_large_List = runM (prop_toJSON_fromJSON large) + where + large = replicate 10000 (42 :: Int54) + +unit_large_Map :: Property +unit_large_Map = runM (prop_toJSON_fromJSON large) + where + large = Map.fromList [ (show n, 42 :: Int54) | n <- [0.. 10000 :: Int] ] + + +newtype M a = M (Maybe a) + deriving (Functor, Applicative, Monad) + +runM :: Testable prop => M prop -> Property +runM (M Nothing) = property False +runM (M (Just prop)) = property prop + +instance ReportSchemaErrors M where + expected _ _ = M Nothing + canonicalise :: JSValue -> JSValue canonicalise v@JSNull = v canonicalise v@(JSBool _) = v @@ -61,11 +115,14 @@ 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 (JSString s) = Aeson.String (toAesonStr s) toAeson (JSArray xs) = Aeson.Array $ V.fromList [ toAeson x | x <- xs ] -toAeson (JSObject xs) = Aeson.Object $ HM.fromList [ (fromString k, toAeson v) +toAeson (JSObject xs) = Aeson.Object $ HM.fromList [ (toAesonStr k, toAeson v) | (k, v) <- xs ] +toAesonStr :: IsString s => JSString -> s +toAesonStr = fromString . fromJSString + instance Arbitrary JSValue where arbitrary = sized $ \sz -> @@ -73,13 +130,13 @@ [ (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) + , (2, JSString <$> arbitrary) + , (3, JSArray <$> resize (sz `div` 2) arbitrary) + , (3, JSObject . 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 _) = [] @@ -101,4 +158,8 @@ upperbound = 999999999999999 -- 15 decimal digits lowerbound = (-999999999999999) shrink = shrinkIntegral + +instance Arbitrary JSString where + arbitrary = toJSString . getASCIIString <$> arbitrary + shrink s = [ toJSString s' | s' <- shrink (fromJSString s) ]