Strict versions of record codecs that fail on unknown properties

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'

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)

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

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