Added requireRecordFields option to Newtonsoft.Json

src/FsCodec.NewtonsoftJson/Codec.fs

@@ -44,10 +44,27 @@ module Core =
                 // TOCONSIDER as noted in the comments on RecyclableMemoryStream.ToArray, ideally we'd be continuing the rental and passing out a Span
                 ms.ToArray()
 
-            member __.Decode(json : byte[]) =
+            member __.Decode(json : byte[]) : 'a =
                 use ms = Utf8BytesEncoder.wrapAsStream json
                 use jsonReader = Utf8BytesEncoder.makeJsonReader ms
-                serializer.Deserialize<'T>(jsonReader)
+                let returnType = typeof<'a>
+                if returnType = typeof<Guid> then
+                    json
+                    |> System.Text.Encoding.ASCII.GetString
+                    |> Guid.Parse
+                    |> unbox
+                elif returnType = typeof<bool> then
+                    json
+                    |> System.Text.Encoding.ASCII.GetString
+                    |> Boolean.Parse
+                    |> unbox
+                elif returnType = typeof<char> then
+                    json
+                    |> System.Text.Encoding.UTF8.GetChars
+                    |> Seq.head
+                    |> unbox
+                else
+                    serializer.Deserialize<'a> jsonReader
 
 /// Provides Codecs that render to a UTF-8 array suitable for storage in Event Stores based using <c>Newtonsoft.Json</c> and the conventions implied by using
 /// <c>TypeShape.UnionContract.UnionContractEncoder</c> - if you need full control and/or have have your own codecs, see <c>FsCodec.Codec.Create</c> instead
@@ -73,19 +90,18 @@ type Codec private () =
             /// Configuration to be used by the underlying <c>Newtonsoft.Json</c> Serializer when encoding/decoding. Defaults to same as <c>Settings.Create()</c>
             [<Optional; DefaultParameterValue(null)>] ?settings,
             /// Enables one to fail encoder generation if union contains nullary cases. Defaults to <c>false</c>, i.e. permitting them
-            [<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases)
+            [<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases,
+            [<Optional; DefaultParameterValue(null)>] ?requireRecordFields)
         : FsCodec.IEventCodec<'Event, byte[], 'Context> =
 
         let settings = match settings with Some x -> x | None -> defaultSettings.Value
-        let bytesEncoder : TypeShape.UnionContract.IEncoder<_> = new Core.BytesEncoder(settings) :> _
+        let bytesEncoder : TypeShape.UnionContract.IEncoder<_> = Core.BytesEncoder(settings) :> _
+        let requireRecordFields = defaultArg requireRecordFields true
+        Internal.checkIfSupported<'Contract> requireRecordFields
         let dataCodec =
             TypeShape.UnionContract.UnionContractEncoder.Create<'Contract, byte[]>(
                 bytesEncoder,
-                // For now, we hard wire in disabling of non-record bodies as:
-                // a) it's extra yaks to shave
-                // b) it's questionable whether allowing one to define event contracts that preclude adding extra fields is a useful idea in the first instance
-                // See VerbatimUtf8EncoderTests.fs and InteropTests.fs - there are edge cases when `d` fields have null / zero-length / missing values
-                requireRecordFields = true,
+                requireRecordFields = requireRecordFields,
                 allowNullaryCases = not (defaultArg rejectNullaryCases false))
 
         { new FsCodec.IEventCodec<'Event, byte[], 'Context> with
@@ -119,14 +135,16 @@ type Codec private () =
             /// Configuration to be used by the underlying <c>Newtonsoft.Json</c> Serializer when encoding/decoding. Defaults to same as <c>Settings.Create()</c>
             [<Optional; DefaultParameterValue(null)>] ?settings,
             /// Enables one to fail encoder generation if union contains nullary cases. Defaults to <c>false</c>, i.e. permitting them
-            [<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases)
+            [<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases,
+            /// Enables unions to contain a Guid or most primitives. Defaults to <c>true</c>, i.e. preventing Guids and primitives
+            [<Optional; DefaultParameterValue(null)>] ?requireRecordFields)
         : FsCodec.IEventCodec<'Event, byte[], 'Context> =
 
         let down (context, union) =
             let c, m, t = down union
             let m', eventId, correlationId, causationId = mapCausation (context, m)
             c, m', eventId, correlationId, causationId, t
-        Codec.Create(up = up, down = down, ?settings = settings, ?rejectNullaryCases = rejectNullaryCases)
+        Codec.Create(up = up, down = down, ?settings = settings, ?rejectNullaryCases = rejectNullaryCases, ?requireRecordFields = requireRecordFields)
 
     /// Generate an <code>IEventCodec</code> using the supplied <c>Newtonsoft.Json<c/> <c>settings</c>.
     /// Uses <c>up</c> and <c>down</c> and <c>mapCausation</c> functions to facilitate upconversion/downconversion and correlation/causationId mapping
@@ -145,11 +163,13 @@ type Codec private () =
             /// Configuration to be used by the underlying <c>Newtonsoft.Json</c> Serializer when encoding/decoding. Defaults to same as <c>Settings.Create()</c>
             [<Optional; DefaultParameterValue(null)>] ?settings,
             /// Enables one to fail encoder generation if union contains nullary cases. Defaults to <c>false</c>, i.e. permitting them
-            [<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases)
+            [<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases,
+            /// Enables unions to contain a Guid or most primitives. Defaults to <c>true</c>, i.e. preventing Guids and primitives
+            [<Optional; DefaultParameterValue(null)>] ?requireRecordFields)
         : FsCodec.IEventCodec<'Event, byte[], obj> =
 
         let mapCausation (_context : obj, m : 'Meta option) = m, Guid.NewGuid(), null, null
-        Codec.Create(up = up, down = down, mapCausation = mapCausation, ?settings = settings, ?rejectNullaryCases = rejectNullaryCases)
+        Codec.Create(up = up, down = down, mapCausation = mapCausation, ?settings = settings, ?rejectNullaryCases = rejectNullaryCases, ?requireRecordFields = requireRecordFields)
 
     /// Generate an <code>IEventCodec</code> using the supplied <c>Newtonsoft.Json</c> <c>settings</c>.
     /// The Event Type Names are inferred based on either explicit <c>DataMember(Name=</c> Attributes, or (if unspecified) the Discriminated Union Case Name
@@ -158,9 +178,11 @@ type Codec private () =
         (   // Configuration to be used by the underlying <c>Newtonsoft.Json</c> Serializer when encoding/decoding. Defaults to same as <c>Settings.Create()</c>
             [<Optional; DefaultParameterValue(null)>] ?settings,
             /// Enables one to fail encoder generation if union contains nullary cases. Defaults to <c>false</c>, i.e. permitting them
-            [<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases)
+            [<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases,
+            /// Enables unions to contain a Guid or most primitives. Defaults to <c>true</c>, i.e. preventing Guids and primitives
+            [<Optional; DefaultParameterValue(null)>] ?requireRecordFields)
         : FsCodec.IEventCodec<'Union, byte[], obj> =
 
         let up : FsCodec.ITimelineEvent<_> * 'Union -> 'Union = snd
         let down (event : 'Union) = event, None, None
-        Codec.Create(up = up, down = down, ?settings = settings, ?rejectNullaryCases = rejectNullaryCases)
+        Codec.Create(up = up, down = down, ?settings = settings, ?rejectNullaryCases = rejectNullaryCases, ?requireRecordFields = requireRecordFields)

src/FsCodec.NewtonsoftJson/FsCodec.NewtonsoftJson.fsproj

@@ -29,7 +29,6 @@
     <PackageReference Include="Microsoft.IO.RecyclableMemoryStream" Version="1.2.2" />
     <PackageReference Include="Newtonsoft.Json" Version="11.0.2" />
     <PackageReference Include="System.Buffers" Version="4.5.0" />
-    <PackageReference Include="TypeShape" Version="8.0.0" />
   </ItemGroup>
 
   <ItemGroup>

src/FsCodec.NewtonsoftJson/VerbatimUtf8Converter.fs

@@ -20,5 +20,7 @@ type VerbatimUtf8JsonConverter() =
 
     override __.ReadJson(reader : JsonReader, _ : Type, _ : obj, _ : JsonSerializer) =
         let token = JToken.Load reader
-        if token.Type = JTokenType.Null then null
-        else token |> string |> enc.GetBytes |> box
+        match token.Type with
+        | JTokenType.Null -> null
+        | JTokenType.Float -> reader.Value :?> double |> fun x -> x.ToString "r" |> enc.GetBytes |> box
+        | _ -> token |> string |> enc.GetBytes |> box

src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj

@@ -27,7 +27,6 @@
     <PackageReference Include="FSharp.Core" Version="4.3.4" />
 
     <PackageReference Include="System.Text.Json" Version="5.0.0-preview.3.20214.6" />
-    <PackageReference Include="TypeShape" Version="8.0.0" />
   </ItemGroup>
 
   <ItemGroup>

src/FsCodec/FsCodec.fsproj

@@ -9,6 +9,7 @@
   </PropertyGroup>
 
   <ItemGroup>
+    <Compile Include="Internal.fs" />
     <Compile Include="FsCodec.fs" />
     <Compile Include="Codec.fs" />
     <Compile Include="StreamName.fs" />
@@ -21,6 +22,13 @@
     <PackageReference Include="FSharp.Core" Version="3.1.2.5" Condition=" '$(TargetFramework)' == 'net461' " />
     <PackageReference Include="FSharp.Core" Version="4.3.4" Condition=" '$(TargetFramework)' == 'netstandard2.0' " />
     <PackageReference Include="FSharp.UMX" Version="1.0.0" />
+    <PackageReference Include="TypeShape" Version="8.0.0" />
+  </ItemGroup>
+
+  <ItemGroup>
+    <AssemblyAttribute Include="System.Runtime.CompilerServices.InternalsVisibleTo">
+      <_Parameter1>FsCodec.NewtonsoftJson</_Parameter1>
+    </AssemblyAttribute>
   </ItemGroup>
 
 </Project>

src/FsCodec/Internal.fs

@@ -0,0 +1,43 @@
+module internal Internal
+
+open TypeShape.Core
+
+let checkIfSupported<'Contract> requireRecordFields =
+    if not requireRecordFields then
+        let shape =
+            match shapeof<'Contract> with
+            | Shape.FSharpUnion (:? ShapeFSharpUnion<'Contract> as s) -> s
+            | _ ->
+                sprintf "Type '%O' is not an F# union" typeof<'Contract>
+                |> invalidArg "Union"
+        let isAllowed (scase : ShapeFSharpUnionCase<_>) =
+            match scase.Fields with
+            | [| field |] ->
+                match field.Member with
+                // non-primitives
+                | Shape.FSharpRecord _
+                | Shape.Guid _
+
+                // primitives
+                | Shape.Bool _
+                | Shape.Byte _
+                | Shape.SByte _
+                | Shape.Int16 _
+                | Shape.Int32 _
+                | Shape.Int64 _
+                //| Shape.IntPtr _ // unsupported
+                | Shape.UInt16 _
+                | Shape.UInt32 _
+                | Shape.UInt64 _
+                //| Shape.UIntPtr _ // unsupported
+                | Shape.Single _
+                | Shape.Double _
+                | Shape.Char _ -> true
+                | _ -> false
+            | [||] -> true // allows all nullary cases, but a subsequent check is done by UnionContractEncoder.Create with `allowNullaryCases`
+            | _ -> false
+        shape.UnionCases
+        |> Array.tryFind (not << isAllowed)
+        |> function
+        | None -> ()
+        | Some x -> failwithf "The '%s' case has an unsupported type: '%s'" x.CaseInfo.Name x.Fields.[0].Member.Type.FullName

tests/FsCodec.NewtonsoftJson.Tests/VerbatimUtf8ConverterTests.fs

@@ -24,8 +24,24 @@ type U =
     //| DT of DateTime // Have not analyzed but seems to be same issue as DTO
     | EDto of EmbeddedDateTimeOffset
     | ES of EmbeddedString
-    //| I of int // works but removed as no other useful top level values work
+    | Guid of Guid
     | N
+
+    // primitives
+    | Boolean   of bool
+    | Byte      of byte
+    | SByte     of sbyte
+    | Int16     of int16
+    | UInt16    of uint16
+    | Int32     of int32
+    | UInt32    of uint32
+    | Int64     of int64
+    | UInt64    of uint64
+    //| IntPtr  of IntPtr  // unsupported
+    //| UIntPtr of UIntPtr // unsupported
+    | Char      of char
+    | Double    of double
+    | Single    of single
     interface TypeShape.UnionContract.IUnionContract
 
 type [<NoEquality; NoComparison; JsonObject(ItemRequired=Required.Always)>]
@@ -57,7 +73,7 @@ let mkBatch (encoded : FsCodec.IEventData<byte[]>) : Batch =
 
 module VerbatimUtf8Tests = // not a module or CI will fail for net461
 
-    let eventCodec = Codec.Create<Union>()
+    let eventCodec = Codec.Create<Union>(requireRecordFields=false)
 
     let [<Fact>] ``encodes correctly`` () =
         let input = Union.A { embed = "\"" }
@@ -71,7 +87,7 @@ module VerbatimUtf8Tests = // not a module or CI will fail for net461
         input =! decoded
 
     let defaultSettings = Settings.CreateDefault()
-    let defaultEventCodec = Codec.Create<U>(defaultSettings)
+    let defaultEventCodec = Codec.Create<U>(defaultSettings, requireRecordFields=false)
 
     let [<Property>] ``round-trips diverse bodies correctly`` (x: U) =
         let encoded = defaultEventCodec.Encode(None,x)
@@ -80,7 +96,12 @@ module VerbatimUtf8Tests = // not a module or CI will fail for net461
         let des = JsonConvert.DeserializeObject<Batch>(ser, defaultSettings)
         let loaded = FsCodec.Core.TimelineEvent.Create(-1L, des.e.[0].c, des.e.[0].d)
         let decoded = defaultEventCodec.TryDecode loaded |> Option.get
-        x =! decoded
+        match x, decoded with
+        | U.Double x, U.Double d when Double.IsNaN x && Double.IsNaN d -> ()
+        | U.Single x, U.Single d when Single.IsNaN x && Single.IsNaN d -> ()
+        | U.Double x, U.Double d -> Assert.Equal(       x,        d, 10)
+        | U.Single x, U.Single d -> Assert.Equal(double x, double d, 10)
+        | _ -> x =! decoded
 
     // https://github.com/JamesNK/Newtonsoft.Json/issues/862 // doesnt apply to this case
     let [<Fact>] ``Codec does not fall prey to Date-strings being mutilated`` () =