Add STJ Codec

src/FsCodec.SystemTextJson/Codec.fs

@@ -0,0 +1,132 @@
+namespace FsCodec.SystemTextJson.Core
+
+open System.Text.Json
+
+/// System.Text.Json implementation of TypeShape.UnionContractEncoder's IEncoder that encodes to a `JsonElement`
+type JsonElementEncoder(options : JsonSerializerOptions) =
+    interface TypeShape.UnionContract.IEncoder<JsonElement> with
+        member __.Empty = Unchecked.defaultof<_>
+
+        member __.Encode(value : 'T) =
+            JsonSerializer.SerializeToElement(value, options)
+
+        member __.Decode(json : JsonElement) =
+            JsonSerializer.DeserializeElement(json, options)
+
+namespace FsCodec.SystemTextJson
+
+open System
+open System.Runtime.InteropServices
+open System.Text.Json
+
+/// Provides Codecs that render to a JsonElement suitable for storage in Event Stores based using <c>System.Text.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
+/// See <a href=""https://github.com/eiriktsarpalis/TypeShape/blob/master/tests/TypeShape.Tests/UnionContractTests.fs"></a> for example usage.
+type Codec private () =
+
+    static let defaultOptions = lazy Options.Create()
+
+    /// Generate an <code>IEventCodec</code> using the supplied <c>System.Text.Json<c/> <c>options</c>.
+    /// Uses <c>up</c> and <c>down</c> functions to facilitate upconversion/downconversion
+    ///   and/or surfacing metadata to the Programming Model by including it in the emitted <c>'Event</c>
+    /// The Event Type Names are inferred based on either explicit <c>DataMember(Name=</c> Attributes, or (if unspecified) the Discriminated Union Case Name
+    /// <c>Contract</c> must be tagged with </c>interface TypeShape.UnionContract.IUnionContract</c> to signify this scheme applies.
+    static member Create<'Event, 'Contract, 'Meta, 'Context when 'Contract :> TypeShape.UnionContract.IUnionContract>
+        (   /// Maps from the TypeShape <c>UnionConverter</c> <c>'Contract</c> case the Event has been mapped to (with the raw event data as context)
+            /// to the <c>'Event</c> representation (typically a Discriminated Union) that is to be presented to the programming model.
+            up : FsCodec.ITimelineEvent<JsonElement> * 'Contract -> 'Event,
+            /// Maps a fresh Event resulting from a Decision in the Domain representation type down to the TypeShape <c>UnionConverter</c> <c>'Contract</c>
+            /// The function is also expected to derive
+            ///   a <c>meta</c> object that will be serialized with the same options (if it's not <c>None</c>)
+            ///   and an Event Creation <c>timestamp</c>.
+            down : 'Context option * 'Event -> 'Contract * 'Meta option * Guid * string * string * DateTimeOffset option,
+            /// Configuration to be used by the underlying <c>System.Text.Json</c> Serializer when encoding/decoding. Defaults to same as <c>Options.Create()</c>
+            [<Optional; DefaultParameterValue(null)>] ?options,
+            /// Enables one to fail encoder generation if union contains nullary cases. Defaults to <c>false</c>, i.e. permitting them
+            [<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases)
+        : FsCodec.IEventCodec<'Event, JsonElement, 'Context> =
+
+        let options = match options with Some x -> x | None -> defaultOptions.Value
+        let elementEncoder : TypeShape.UnionContract.IEncoder<_> = Core.JsonElementEncoder(options) :> _
+        let dataCodec =
+            TypeShape.UnionContract.UnionContractEncoder.Create<'Contract, JsonElement>(
+                elementEncoder,
+                requireRecordFields = true, // See JsonConverterTests - round-tripping UTF-8 correctly with Json.net is painful so for now we lock up the dragons
+                allowNullaryCases = not (defaultArg rejectNullaryCases false))
+
+        { new FsCodec.IEventCodec<'Event, JsonElement, 'Context> with
+            member __.Encode(context, event) =
+                let (c, meta : 'Meta option, eventId, correlationId, causationId, timestamp : DateTimeOffset option) = down (context, event)
+                let enc = dataCodec.Encode c
+                let metaUtf8 = meta |> Option.map elementEncoder.Encode<'Meta>
+                FsCodec.Core.EventData.Create(enc.CaseName, enc.Payload, Unchecked.defaultof<_>, eventId, correlationId, causationId, ?timestamp = timestamp)
+
+            member __.TryDecode encoded =
+                match dataCodec.TryDecode { CaseName = encoded.EventType; Payload = encoded.Data } with
+                | None -> None
+                | Some contract -> up (encoded, contract) |> Some }
+
+    /// Generate an <code>IEventCodec</code> using the supplied <c>System.Text.Json<c/> <c>options</c>.
+    /// Uses <c>up</c> and <c>down</c> and <c>mapCausation</c> functions to facilitate upconversion/downconversion and correlation/causationId mapping
+    ///   and/or surfacing metadata to the Programming Model by including it in the emitted <c>'Event</c>
+    /// The Event Type Names are inferred based on either explicit <c>DataMember(Name=</c> Attributes, or (if unspecified) the Discriminated Union Case Name
+    /// <c>Contract</c> must be tagged with </c>interface TypeShape.UnionContract.IUnionContract</c> to signify this scheme applies.
+    static member Create<'Event, 'Contract, 'Meta, 'Context when 'Contract :> TypeShape.UnionContract.IUnionContract>
+        (   /// Maps from the TypeShape <c>UnionConverter</c> <c>'Contract</c> case the Event has been mapped to (with the raw event data as context)
+            /// to the representation (typically a Discriminated Union) that is to be presented to the programming model.
+            up : FsCodec.ITimelineEvent<JsonElement> * 'Contract -> 'Event,
+            /// Maps a fresh Event resulting from a Decision in the Domain representation type down to the TypeShape <c>UnionConverter</c> <c>'Contract</c>
+            /// The function is also expected to derive
+            ///   a <c>meta</c> object that will be serialized with the same options (if it's not <c>None</c>)
+            ///   and an Event Creation <c>timestamp</c>.
+            down : 'Event -> 'Contract * 'Meta option * DateTimeOffset option,
+            /// Uses the 'Context passed to the Encode call and the 'Meta emitted by <c>down</c> to a) the final metadata b) the <c>correlationId</c> and c) the correlationId
+            mapCausation : 'Context option * 'Meta option -> 'Meta option * Guid * string * string,
+            /// Configuration to be used by the underlying <c>System.Text.Json</c> Serializer when encoding/decoding. Defaults to same as <c>Options.Create()</c>
+            [<Optional; DefaultParameterValue(null)>] ?options,
+            /// Enables one to fail encoder generation if union contains nullary cases. Defaults to <c>false</c>, i.e. permitting them
+            [<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases)
+        : FsCodec.IEventCodec<'Event, JsonElement, '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, ?options = options, ?rejectNullaryCases = rejectNullaryCases)
+
+    /// Generate an <code>IEventCodec</code> using the supplied <c>System.Text.Json<c/> <c>options</c>.
+    /// Uses <c>up</c> and <c>down</c> and <c>mapCausation</c> functions to facilitate upconversion/downconversion and correlation/causationId mapping
+    ///   and/or surfacing metadata to the Programming Model by including it in the emitted <c>'Event</c>
+    /// The Event Type Names are inferred based on either explicit <c>DataMember(Name=</c> Attributes, or (if unspecified) the Discriminated Union Case Name
+    /// <c>Contract</c> must be tagged with </c>interface TypeShape.UnionContract.IUnionContract</c> to signify this scheme applies.
+    static member Create<'Event, 'Contract, 'Meta when 'Contract :> TypeShape.UnionContract.IUnionContract>
+        (   /// Maps from the TypeShape <c>UnionConverter</c> <c>'Contract</c> case the Event has been mapped to (with the raw event data as context)
+            /// to the representation (typically a Discriminated Union) that is to be presented to the programming model.
+            up : FsCodec.ITimelineEvent<JsonElement> * 'Contract -> 'Event,
+            /// Maps a fresh <c>'Event</c> resulting from a Decision in the Domain representation type down to the TypeShape <c>UnionConverter</c> <c>'Contract</c>
+            /// The function is also expected to derive
+            ///   a <c>meta</c> object that will be serialized with the same options (if it's not <c>None</c>)
+            ///   and an Event Creation <c>timestamp</c>.
+            down : 'Event -> 'Contract * 'Meta option * DateTimeOffset option,
+            /// Configuration to be used by the underlying <c>System.Text.Json</c> Serializer when encoding/decoding. Defaults to same as <c>Options.Create()</c>
+            [<Optional; DefaultParameterValue(null)>] ?options,
+            /// Enables one to fail encoder generation if union contains nullary cases. Defaults to <c>false</c>, i.e. permitting them
+            [<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases)
+        : FsCodec.IEventCodec<'Event, JsonElement, obj> =
+
+        let mapCausation (_context : obj, m : 'Meta option) = m, Guid.NewGuid(), null, null
+        Codec.Create(up = up, down = down, mapCausation = mapCausation, ?options = options, ?rejectNullaryCases = rejectNullaryCases)
+
+    /// Generate an <code>IEventCodec</code> using the supplied <c>System.Text.Json</c> <c>options</c>.
+    /// The Event Type Names are inferred based on either explicit <c>DataMember(Name=</c> Attributes, or (if unspecified) the Discriminated Union Case Name
+    /// <c>'Union</c> must be tagged with <c>interface TypeShape.UnionContract.IUnionContract</c> to signify this scheme applies.
+    static member Create<'Union when 'Union :> TypeShape.UnionContract.IUnionContract>
+        (   // Configuration to be used by the underlying <c>System.Text.Json</c> Serializer when encoding/decoding. Defaults to same as <c>Options.Create()</c>
+            [<Optional; DefaultParameterValue(null)>] ?options,
+            /// Enables one to fail encoder generation if union contains nullary cases. Defaults to <c>false</c>, i.e. permitting them
+            [<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases)
+        : FsCodec.IEventCodec<'Union, JsonElement, obj> =
+
+        let up : FsCodec.ITimelineEvent<_> * 'Union -> 'Union = snd
+        let down (event : 'Union) = event, None, None
+        Codec.Create(up = up, down = down, ?options = options, ?rejectNullaryCases = rejectNullaryCases)

src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj

@@ -9,11 +9,12 @@
   </PropertyGroup>
 
   <ItemGroup>
-    <Compile Include="JsonElementHelpers.fs" />
+    <Compile Include="JsonSerializerElementExtensions.fs" />
     <Compile Include="Utf8JsonReaderExtensions.fs" />
     <Compile Include="JsonOptionConverter.fs" />
     <Compile Include="JsonRecordConverter.fs" />
     <Compile Include="Options.fs" />
+    <Compile Include="Codec.fs" />
     <Compile Include="Serdes.fs" />
   </ItemGroup>
 
@@ -24,6 +25,7 @@
     <PackageReference Include="FSharp.Core" Version="4.3.4" Condition=" '$(TargetFramework)' == 'netstandard2.1' " />
 
     <PackageReference Include="System.Text.Json" Version="4.7.0" />
+    <PackageReference Include="TypeShape" Version="8.0.0" />
   </ItemGroup>
 
   <ItemGroup>

src/FsCodec.SystemTextJson/JsonOptionConverter.fs

@@ -1,4 +1,4 @@
-namespace FsCodec.SystemTextJson.Serialization
+namespace FsCodec.SystemTextJson.Converters
 
 open System
 open System.Linq.Expressions

src/FsCodec.SystemTextJson/JsonRecordConverter.fs

@@ -1,5 +1,6 @@
-namespace FsCodec.SystemTextJson.Serialization
+namespace FsCodec.SystemTextJson.Converters
 
+open FsCodec.SystemTextJson.Core
 open FSharp.Reflection
 open System
 open System.Collections.Generic

src/FsCodec.SystemTextJson/JsonElementHelpers.fs → src/FsCodec.SystemTextJson/JsonSerializerElementExtensions.fs

@@ -1,12 +1,12 @@
-namespace FsCodec.SystemTextJson
+namespace FsCodec.SystemTextJson.Core
 
 open System
 open System.Buffers
 open System.Runtime.InteropServices
 open System.Text.Json
 
 [<AutoOpen>]
-module JsonSerializerExtensions =
+module internal JsonSerializerExtensions =
     type JsonSerializer with
         static member SerializeToElement(value: 'T, [<Optional; DefaultParameterValue(null)>] ?options: JsonSerializerOptions) =
             JsonSerializer.Deserialize<JsonElement>(ReadOnlySpan.op_Implicit(JsonSerializer.SerializeToUtf8Bytes(value, defaultArg options null)))

src/FsCodec.SystemTextJson/Options.fs

@@ -1,14 +1,15 @@
 namespace FsCodec.SystemTextJson
 
-open FsCodec.SystemTextJson.Serialization
 open System
 open System.Runtime.InteropServices
 open System.Text.Json
 open System.Text.Json.Serialization
 
 type Options private () =
 
-    static let defaultConverters : JsonConverterFactory[] = [| JsonOptionConverter(); JsonRecordConverter() |]
+    static let defaultConverters : JsonConverterFactory[] =
+        [|  Converters.JsonOptionConverter()
+            Converters.JsonRecordConverter() |]
 
     /// Creates a default set of serializer options used by Json serialization. When used with no args, same as `JsonSerializerOptions()`
     static member CreateDefault

src/FsCodec.SystemTextJson/Utf8JsonReaderExtensions.fs

@@ -1,22 +1,13 @@
-namespace FsCodec.SystemTextJson.Serialization
+namespace FsCodec.SystemTextJson.Core
 
 open System.Runtime.CompilerServices
 open System.Text.Json
 
 [<Extension>]
-type Utf8JsonReaderExtension =
+type internal Utf8JsonReaderExtension =
     [<Extension>]
     static member ValidateTokenType(reader: Utf8JsonReader, expectedTokenType) =
         if reader.TokenType <> expectedTokenType then
             sprintf "Expected a %A token, but encountered a %A token when parsing JSON." expectedTokenType (reader.TokenType)
             |> JsonException
             |> raise
-
-//    [<Extension>]
-//    static member ValidatePropertyName(reader: Utf8JsonReader, expectedPropertyName: string) =
-//        reader.ValidateTokenType(JsonTokenType.PropertyName)
-//
-//        if not <| reader.ValueTextEquals expectedPropertyName then
-//            sprintf "Expected a property named '%s', but encountered property with name '%s'." expectedPropertyName (reader.GetString())
-//            |> JsonException
-//            |> raise

tests/FsCodec.SystemTextJson.Tests/CodecTests.fs

@@ -0,0 +1,62 @@
+module FsCodec.SystemTextJson.Tests.CodecTests
+
+open System.Text.Json
+open FsCheck.Xunit
+open Swensen.Unquote
+
+type Embedded = { embed : string }
+type EmbeddedWithOption = { embed : string; opt : string option }
+type Union =
+    | A of Embedded
+    | B of Embedded
+    | AO of EmbeddedWithOption
+    | BO of EmbeddedWithOption
+    interface TypeShape.UnionContract.IUnionContract
+
+let defaultOptions = FsCodec.SystemTextJson.Options.Create(ignoreNulls=true)
+let elementEncoder : TypeShape.UnionContract.IEncoder<System.Text.Json.JsonElement> =
+    FsCodec.SystemTextJson.Core.JsonElementEncoder(defaultOptions) :> _
+
+let eventCodec = FsCodec.SystemTextJson.Codec.Create<Union>()
+
+type Envelope = { d : JsonElement }
+
+[<Property>]
+let roundtrips value =
+    let eventType, embedded =
+        match value with
+        | A e -> "A",Choice1Of2 e
+        | AO e -> "AO",Choice2Of2 e
+        | B e -> "B",Choice1Of2 e
+        | BO e -> "BO",Choice2Of2 e
+
+    let encoded, ignoreSomeNull =
+        match embedded with
+        | Choice1Of2 e -> elementEncoder.Encode e, false
+        | Choice2Of2 eo -> elementEncoder.Encode eo, eo.opt = Some null
+
+    let enveloped = { d = encoded }
+    let ser = FsCodec.SystemTextJson.Serdes.Serialize enveloped
+
+    match embedded with
+    | x when obj.ReferenceEquals(null, x) ->
+        test <@ ser.StartsWith("""{"d":{""") @>
+    | Choice1Of2 { embed = null }
+    | Choice2Of2 { embed = null; opt = None } ->
+        test <@ ser = """{"d":{}}""" @>
+    | Choice2Of2 { embed = null; opt = Some null } ->
+        // TOCONSIDER - should ideally treat Some null as equivalent to None
+        test <@ ser.StartsWith("""{"d":{"opt":null}}""") @>
+    | Choice2Of2 { embed = null } ->
+        test <@ ser.StartsWith("""{"d":{"opt":""") @>
+    | _ ->
+        test <@ ser.StartsWith("""{"d":{"embed":""") @>
+
+    match embedded with
+    | Choice2Of2 { opt = None } -> test <@ not (ser.Contains "opt") @>
+    | _ -> ()
+
+    let des = FsCodec.SystemTextJson.Serdes.Deserialize<Envelope> ser
+    let wrapped = FsCodec.Core.TimelineEvent<JsonElement>.Create(-1L, eventType, des.d)
+    let decoded = eventCodec.TryDecode wrapped |> Option.get
+    test <@ value = decoded || ignoreSomeNull @>

tests/FsCodec.SystemTextJson.Tests/FsCodec.SystemTextJson.Tests.fsproj

@@ -8,6 +8,8 @@
 
   <ItemGroup>
     <PackageReference Include="Microsoft.NET.Test.Sdk" Version="16.5.0" />
+
+    <PackageReference Include="FsCheck.Xunit" Version="2.14.1" />
     <PackageReference Include="Unquote" Version="5.0.0" />
     <PackageReference Include="xunit" Version="2.4.1" />
     <PackageReference Include="xunit.runner.visualstudio" Version="2.4.1" />
@@ -19,6 +21,7 @@
 
   <ItemGroup>
     <Compile Include="SerdesTests.fs" />
+    <Compile Include="CodecTests.fs" />
   </ItemGroup>
 
-</Project>
+</Project>

tests/FsCodec.SystemTextJson.Tests/SerdesTests.fs

@@ -24,7 +24,7 @@ module StjCharacterization =
                 | Choice2Of2 m -> m.Contains "Deserialization of reference types without parameterless constructor is not supported. Type 'FsCodec.SystemTextJson.Tests.SerdesTests+Record'" @>
 
     let [<Fact>] ``OOTB STJ options`` () =
-        let ootbOptionsWithRecordConverter = Options.CreateDefault(converters = [|Serialization.JsonRecordConverter()|])
+        let ootbOptionsWithRecordConverter = Options.CreateDefault(converters = [|Converters.JsonRecordConverter()|])
         let value = { a = 1; b = Some "str" }
         let ser =  Serdes.Serialize(value, ootbOptions)
         test <@ ser = """{"a":1,"b":{"Value":"str"}}""" @>