diff --git a/src/Data/Codec/JSON.purs b/src/Data/Codec/JSON.purs index 2d80b64..81b570e 100644 --- a/src/Data/Codec/JSON.purs +++ b/src/Data/Codec/JSON.purs @@ -210,10 +210,13 @@ type PropCodec a = a a --- | A codec for objects that are encoded with specific properties. +-- | A codec for objects that are encoded with specific properties. This codec +-- | will ignore any unknown properties in the incoming record. Use +-- | `Data.Codec.JSON.Strict.objectStrict` for a version that fails upon +-- | encountering unknown properties. -- | --- | See also `Data.Codec.JSON.Record.object` for a more commonly useful --- | version of this function. +-- | See also `Data.Codec.JSON.Record.object` for a more commonly useful version +-- | of this function. object ∷ ∀ a. PropCodec a → Codec a object codec = Codec.codec' diff --git a/src/Data/Codec/JSON/Record.purs b/src/Data/Codec/JSON/Record.purs index 35d7c87..0678489 100644 --- a/src/Data/Codec/JSON/Record.purs +++ b/src/Data/Codec/JSON/Record.purs @@ -1,6 +1,7 @@ module Data.Codec.JSON.Record where import Data.Codec.JSON as CJ +import Data.Codec.JSON.Strict as CJS import Data.Maybe (Maybe) import Data.Symbol (class IsSymbol) import Prim.Row as R @@ -26,6 +27,23 @@ object → CJ.Codec (Record ro) object rec = CJ.object (record rec) +-- | A version of the `object` function that fails upon encountering unknown +-- | properties while decoding a record. +-- | +-- | ```purescript +-- | type Person = { name ∷ String, age ∷ Int } +-- | +-- | personCodec ∷ CJ.Codec Person +-- | personCodec = CAR.objectStrict { name: CJ.string, age: CJ.int } +-- | ``` +objectStrict + ∷ ∀ ri ro rl + . RL.RowToList ri rl + ⇒ RowListCodecStrict rl ri ro + ⇒ Record ri + → CJ.Codec (Record ro) +objectStrict rec = CJS.objectStrict (recordStrict rec) + -- | Constructs a `JPropCodec` for a `Record` from a record of codecs. Commonly -- | the `object` function in this module will be the preferred choice, as that -- | produces a `Codec` instead. @@ -35,7 +53,18 @@ record ⇒ RowListCodec rl ri ro ⇒ Record ri → CJ.PropCodec (Record ro) -record = rowListCodec (Proxy ∷ Proxy rl) +record = rowListCodec @rl + +-- | Constructs a `JPropCodec` for a `Record` from a record of codecs. Commonly +-- | the `object` function in this module will be the preferred choice, as that +-- | produces a `Codec` instead. +recordStrict + ∷ ∀ ri ro rl + . RL.RowToList ri rl + ⇒ RowListCodecStrict rl ri ro + ⇒ Record ri + → CJS.PropCodec (Record ro) +recordStrict = rowListCodecStrict @rl -- | Used to wrap codec values provided in `record` to indicate the field is optional. -- | @@ -53,39 +82,80 @@ optional = Optional -- | The class used to enable the building of `Record` codecs by providing a -- | record of codecs. class RowListCodec (rl ∷ RL.RowList Type) (ri ∷ Row Type) (ro ∷ Row Type) | rl → ri ro where - rowListCodec ∷ ∀ proxy. proxy rl → Record ri → CJ.PropCodec (Record ro) + rowListCodec ∷ Record ri → CJ.PropCodec (Record ro) -instance rowListCodecNil ∷ RowListCodec RL.Nil () () where - rowListCodec _ _ = CJ.record +instance RowListCodec RL.Nil () () where + rowListCodec _ = CJ.record -instance rowListCodecConsOptional ∷ +instance ( RowListCodec rs ri' ro' , R.Cons sym (Optional a) ri' ri , R.Cons sym (Maybe a) ro' ro , IsSymbol sym ) ⇒ RowListCodec (RL.Cons sym (Optional a) rs) ri ro where - rowListCodec _ codecs = + rowListCodec codecs = CJ.recordPropOptional (Proxy ∷ Proxy sym) codec tail where codec ∷ CJ.Codec a codec = coerce (Rec.get (Proxy ∷ Proxy sym) codecs ∷ Optional a) tail ∷ CJ.PropCodec (Record ro') - tail = rowListCodec (Proxy ∷ Proxy rs) ((unsafeCoerce ∷ Record ri → Record ri') codecs) + tail = rowListCodec @rs ((unsafeCoerce ∷ Record ri → Record ri') codecs) -else instance rowListCodecCons ∷ +else instance ( RowListCodec rs ri' ro' , R.Cons sym (CJ.Codec a) ri' ri , R.Cons sym a ro' ro , IsSymbol sym ) ⇒ RowListCodec (RL.Cons sym (CJ.Codec a) rs) ri ro where - rowListCodec _ codecs = + rowListCodec codecs = CJ.recordProp (Proxy ∷ Proxy sym) codec tail where codec ∷ CJ.Codec a codec = Rec.get (Proxy ∷ Proxy sym) codecs tail ∷ CJ.PropCodec (Record ro') - tail = rowListCodec (Proxy ∷ Proxy rs) ((unsafeCoerce ∷ Record ri → Record ri') codecs) + tail = rowListCodec @rs ((unsafeCoerce ∷ Record ri → Record ri') codecs) + + +-- | The class used to enable the building of `Record` codecs by providing a +-- | record of codecs. +class RowListCodecStrict (rl ∷ RL.RowList Type) (ri ∷ Row Type) (ro ∷ Row Type) | rl → ri ro where + rowListCodecStrict ∷ Record ri → CJS.PropCodec (Record ro) + +instance RowListCodecStrict RL.Nil () () where + rowListCodecStrict _ = CJS.record + +instance + ( RowListCodecStrict rs ri' ro' + , R.Cons sym (Optional a) ri' ri + , R.Cons sym (Maybe a) ro' ro + , IsSymbol sym + ) ⇒ + RowListCodecStrict (RL.Cons sym (Optional a) rs) ri ro where + rowListCodecStrict codecs = + CJS.recordPropOptional (Proxy ∷ Proxy sym) codec tail + where + codec ∷ CJ.Codec a + codec = coerce (Rec.get (Proxy ∷ Proxy sym) codecs ∷ Optional a) + + tail ∷ CJS.PropCodec (Record ro') + tail = rowListCodecStrict @rs ((unsafeCoerce ∷ Record ri → Record ri') codecs) + +else instance + ( RowListCodecStrict rs ri' ro' + , R.Cons sym (CJ.Codec a) ri' ri + , R.Cons sym a ro' ro + , IsSymbol sym + ) ⇒ + RowListCodecStrict (RL.Cons sym (CJ.Codec a) rs) ri ro where + rowListCodecStrict codecs = + CJS.recordProp (Proxy ∷ Proxy sym) codec tail + where + codec ∷ CJ.Codec a + codec = Rec.get (Proxy ∷ Proxy sym) codecs + + tail ∷ CJS.PropCodec (Record ro') + tail = rowListCodecStrict @rs ((unsafeCoerce ∷ Record ri → Record ri') codecs) diff --git a/src/Data/Codec/JSON/Strict.purs b/src/Data/Codec/JSON/Strict.purs new file mode 100644 index 0000000..88bfd45 --- /dev/null +++ b/src/Data/Codec/JSON/Strict.purs @@ -0,0 +1,172 @@ +module Data.Codec.JSON.Strict + ( PropCodec + , ClaimedProps + , objectStrict + , prop + , record + , recordProp + , recordPropOptional + ) where + +import Prelude hiding ((<<<), (<=<), (>=>), (>>>)) + +import Data.Codec.JSON as CJ +import Codec.JSON.DecodeError as Error +import Control.Monad.Except (Except, lift, throwError, withExceptT) +import Control.Monad.State (StateT, modify_, runStateT) +import Data.Codec (Codec(..), codec, codec', decode, encode) as Codec +import Data.List ((:)) +import Data.List as L +import Data.Maybe (Maybe(..)) +import Data.Set as Set +import Data.String as S +import Data.Symbol (class IsSymbol, reflectSymbol) +import Data.Tuple (Tuple(..)) +import JSON (JObject, JSON) +import JSON.Object as JO +import JSON.Path as JP +import Prim.Row as Row +import Record.Unsafe as Record +import Type.Proxy (Proxy) +import Unsafe.Coerce (unsafeCoerce) + +-- | The set of properties that have been claimed "so far" during parsing of a +-- | record. This is used internally to track which properties have been parsed +-- | in order to determine which properties are unknown. +type ClaimedProps = Set.Set String + +-- | Codec type for `JObject` prop/value pairs. +type PropCodec a = + Codec.Codec + (StateT ClaimedProps (Except Error.DecodeError)) + JObject + (L.List (Tuple String JSON)) + a + a + +-- | A codec for objects that are encoded with specific properties. This codec +-- | will fail upon encountering unknown properties in the incoming record. Use +-- | `Data.Codec.JSON.object` for a version that ignores unknown properties. +-- | +-- | See also `Data.Codec.JSON.Record.objectStrict` for a more commonly useful +-- | version of this function. +objectStrict ∷ ∀ a. PropCodec a -> CJ.Codec a +objectStrict codec = Codec.codec' dec enc + where + dec j = do + obj <- Codec.decode CJ.jobject j + Tuple rec claimedProps <- runStateT (Codec.decode codec obj) Set.empty + + let unclaimedProps = Set.difference (Set.fromFoldable (JO.keys obj)) claimedProps + when (not Set.isEmpty unclaimedProps) $ + throwError $ Error.error JP.Tip $ + "Unknown field(s): " <> S.joinWith ", " (Set.toUnfoldable unclaimedProps) + + pure rec + + enc a = Codec.encode CJ.jobject $ JO.fromFoldable $ Codec.encode codec a + +-- | A codec for a property of an object. +prop ∷ ∀ a. String → CJ.Codec a → PropCodec a +prop key codec = + Codec.codec + ( \obj → do + v <- case JO.lookup key obj of + Just j → lift $ withExceptT liftError $ Codec.decode codec j + Nothing → throwError (Error.noValueFound (JP.AtKey key JP.Tip)) + modify_ $ Set.insert key + pure v + ) + (\a → pure (Tuple key (CJ.encode codec a))) + where + liftError = Error.withPath (JP.AtKey key) + + +-- | The starting value for a object-record codec. Used with `recordProp` it +-- | provides a convenient method for defining codecs for record types that +-- | encode into JSON objects of the same shape. +-- | +-- | For example, to encode a record as the JSON object +-- | `{ "name": "Karl", "age": 25 }` we would define a codec like this: +-- | ``` +-- | import Data.Codec.JSON as CJ +-- | import Type.Proxy (Proxy(..)) +-- | +-- | type Person = { name ∷ String, age ∷ Int } +-- | +-- | codecPerson ∷ CJ.Codec Person +-- | codecPerson = +-- | CJ.object $ CJ.record +-- | # CJ.recordProp (Proxy :: _ "name") CJ.string +-- | # CJ.recordProp (Proxy :: _ "age") CJ.int +-- | ``` +-- | +-- | See also `Data.Codec.JSON.Record.object` for a more commonly useful +-- | version of this function. +record ∷ PropCodec {} +record = Codec.Codec (const (pure {})) pure + +-- | Used with `record` to define codecs for record types that encode into JSON +-- | objects of the same shape. See the comment on `record` for an example. +recordProp + ∷ ∀ p a r r' + . IsSymbol p + ⇒ Row.Cons p a r r' + ⇒ Proxy p + → CJ.Codec a + → PropCodec (Record r) + → PropCodec (Record r') +recordProp p codecA codecR = Codec.codec dec enc + where + key = reflectSymbol p + liftError = Error.withPath (JP.AtKey key) + + dec ∷ JObject -> StateT _ (Except Error.DecodeError) (Record r') + dec obj = do + r <- Codec.decode codecR obj + a :: a <- case JO.lookup key obj of + Just val -> lift $ withExceptT liftError $ Codec.decode codecA val + Nothing -> throwError $ Error.noValueFound (JP.AtKey key JP.Tip) + modify_ $ Set.insert key + pure $ Record.unsafeSet key a r + + enc ∷ Record r' -> L.List (Tuple String JSON) + enc val = + Tuple key (Codec.encode codecA (Record.unsafeGet key val)) + : Codec.encode codecR ((unsafeCoerce ∷ Record r' -> Record r) val) + +-- | Used with `record` to define an optional field. +-- | +-- | This will only decode the property as `Nothing` if the field does not exist +-- | in the object - having a values such as `null` assigned will need handling +-- | separately. +-- | +-- | The property will be omitted when encoding and the value is `Nothing`. +recordPropOptional + ∷ ∀ p a r r' + . IsSymbol p + ⇒ Row.Cons p (Maybe a) r r' + ⇒ Proxy p + → CJ.Codec a + → PropCodec (Record r) + → PropCodec (Record r') +recordPropOptional p codecA codecR = Codec.codec dec enc + where + key = reflectSymbol p + liftError = Error.withPath (JP.AtKey key) + + dec ∷ JObject -> StateT _ (Except Error.DecodeError) (Record r') + dec obj = do + r <- Codec.decode codecR obj + a :: Maybe a <- case JO.lookup key obj of + Just val -> lift $ withExceptT liftError $ Just <$> Codec.decode codecA val + Nothing -> pure Nothing + modify_ $ Set.insert key + pure $ Record.unsafeSet key a r + + enc ∷ Record r' -> L.List (Tuple String JSON) + enc val = do + let r = Codec.encode codecR ((unsafeCoerce ∷ Record r' -> Record r) val) + case Record.unsafeGet key val of + Nothing -> r + Just val' -> Tuple key (Codec.encode codecA val') : r diff --git a/test/Test/Record.purs b/test/Test/Record.purs index 4d6bc5f..5ba7b35 100644 --- a/test/Test/Record.purs +++ b/test/Test/Record.purs @@ -2,14 +2,19 @@ module Test.Record where import Prelude +import Codec.JSON.DecodeError as Error import Control.Monad.Gen as Gen import Control.Monad.Gen.Common as GenC -import Data.Codec.JSON.Common as CJ +import Data.Bifunctor (lmap) +import Data.Codec.JSON.Common (Codec, boolean, decode, encode, int, maybe, object, string) as CJ import Data.Codec.JSON.Record as CJR +import Data.Codec.JSON.Strict as CJS +import Data.Either (Either(..)) import Data.Maybe (Maybe(..)) import Data.Newtype (class Newtype, unwrap, wrap) import Data.Profunctor (dimap) import Data.String.Gen (genAsciiString) +import Data.Tuple.Nested ((/\)) import Effect (Effect) import Effect.Console (log) import JSON as J @@ -62,6 +67,14 @@ innerCodec = , o: CJR.optional CJ.boolean } +innerCodecStrict ∷ CJ.Codec InnerR +innerCodecStrict = + CJS.objectStrict $ CJR.recordStrict + { n: CJ.int + , m: CJ.boolean + , o: CJR.optional CJ.boolean + } + genOuter ∷ Gen OuterR genOuter = do a ← genInt @@ -94,4 +107,28 @@ main = do let obj = J.toJObject $ CJ.encode innerCodec (v { o = Just b }) pure $ assertEquals (Just [ "m", "n", "o" ]) (JO.keys <$> obj) + log "Check ignoring unrecognized fields" + quickCheckGen do + b ← Gen.chooseBool + n ← genInt + let obj = J.fromJObject $ JO.fromEntries + [ "m" /\ J.fromBoolean b + , "n" /\ J.fromInt n + , "bogus" /\ J.fromInt 42 + ] + pure $ assertEquals (CJ.decode innerCodec obj) (Right { m: b, n, o: Nothing }) + + log "Check failing on unrecognized fields" + quickCheckGen do + b ← Gen.chooseBool + n ← genInt + let obj = J.fromJObject $ JO.fromEntries + [ "m" /\ J.fromBoolean b + , "n" /\ J.fromInt n + , "bogus" /\ J.fromInt 42 + ] + pure $ assertEquals + (lmap Error.print $ CJ.decode innerCodecStrict obj) + (Left "Unknown field(s): bogus") + pure unit