From 81bc30e2a41402b809a8d7ebe15d163f162ecb93 Mon Sep 17 00:00:00 2001 From: Ruben Bartelink Date: Thu, 5 Mar 2020 12:59:38 +0000 Subject: [PATCH] Add STJ Codec --- src/FsCodec.SystemTextJson/Codec.fs | 132 ++++++++++++++++++ .../FsCodec.SystemTextJson.fsproj | 4 +- .../JsonOptionConverter.fs | 2 +- .../JsonRecordConverter.fs | 3 +- ....fs => JsonSerializerElementExtensions.fs} | 4 +- src/FsCodec.SystemTextJson/Options.fs | 5 +- .../Utf8JsonReaderExtensions.fs | 13 +- .../CodecTests.fs | 62 ++++++++ .../FsCodec.SystemTextJson.Tests.fsproj | 5 +- .../SerdesTests.fs | 2 +- 10 files changed, 212 insertions(+), 20 deletions(-) create mode 100755 src/FsCodec.SystemTextJson/Codec.fs rename src/FsCodec.SystemTextJson/{JsonElementHelpers.fs => JsonSerializerElementExtensions.fs} (92%) create mode 100644 tests/FsCodec.SystemTextJson.Tests/CodecTests.fs diff --git a/src/FsCodec.SystemTextJson/Codec.fs b/src/FsCodec.SystemTextJson/Codec.fs new file mode 100755 index 00000000..42d96210 --- /dev/null +++ b/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 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 System.Text.Json and the conventions implied by using +/// TypeShape.UnionContract.UnionContractEncoder - if you need full control and/or have have your own codecs, see FsCodec.Codec.Create instead +/// See for example usage. +type Codec private () = + + static let defaultOptions = lazy Options.Create() + + /// Generate an IEventCodec using the supplied System.Text.Json options. + /// Uses up and down functions to facilitate upconversion/downconversion + /// and/or surfacing metadata to the Programming Model by including it in the emitted 'Event + /// The Event Type Names are inferred based on either explicit DataMember(Name= Attributes, or (if unspecified) the Discriminated Union Case Name + /// Contract must be tagged with interface TypeShape.UnionContract.IUnionContract to signify this scheme applies. + static member Create<'Event, 'Contract, 'Meta, 'Context when 'Contract :> TypeShape.UnionContract.IUnionContract> + ( /// Maps from the TypeShape UnionConverter 'Contract case the Event has been mapped to (with the raw event data as context) + /// to the 'Event representation (typically a Discriminated Union) that is to be presented to the programming model. + up : FsCodec.ITimelineEvent * 'Contract -> 'Event, + /// Maps a fresh Event resulting from a Decision in the Domain representation type down to the TypeShape UnionConverter 'Contract + /// The function is also expected to derive + /// a meta object that will be serialized with the same options (if it's not None) + /// and an Event Creation timestamp. + down : 'Context option * 'Event -> 'Contract * 'Meta option * Guid * string * string * DateTimeOffset option, + /// Configuration to be used by the underlying System.Text.Json Serializer when encoding/decoding. Defaults to same as Options.Create() + [] ?options, + /// Enables one to fail encoder generation if union contains nullary cases. Defaults to false, i.e. permitting them + [] ?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 IEventCodec using the supplied System.Text.Json options. + /// Uses up and down and mapCausation functions to facilitate upconversion/downconversion and correlation/causationId mapping + /// and/or surfacing metadata to the Programming Model by including it in the emitted 'Event + /// The Event Type Names are inferred based on either explicit DataMember(Name= Attributes, or (if unspecified) the Discriminated Union Case Name + /// Contract must be tagged with interface TypeShape.UnionContract.IUnionContract to signify this scheme applies. + static member Create<'Event, 'Contract, 'Meta, 'Context when 'Contract :> TypeShape.UnionContract.IUnionContract> + ( /// Maps from the TypeShape UnionConverter 'Contract 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 * 'Contract -> 'Event, + /// Maps a fresh Event resulting from a Decision in the Domain representation type down to the TypeShape UnionConverter 'Contract + /// The function is also expected to derive + /// a meta object that will be serialized with the same options (if it's not None) + /// and an Event Creation timestamp. + down : 'Event -> 'Contract * 'Meta option * DateTimeOffset option, + /// Uses the 'Context passed to the Encode call and the 'Meta emitted by down to a) the final metadata b) the correlationId and c) the correlationId + mapCausation : 'Context option * 'Meta option -> 'Meta option * Guid * string * string, + /// Configuration to be used by the underlying System.Text.Json Serializer when encoding/decoding. Defaults to same as Options.Create() + [] ?options, + /// Enables one to fail encoder generation if union contains nullary cases. Defaults to false, i.e. permitting them + [] ?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 IEventCodec using the supplied System.Text.Json options. + /// Uses up and down and mapCausation functions to facilitate upconversion/downconversion and correlation/causationId mapping + /// and/or surfacing metadata to the Programming Model by including it in the emitted 'Event + /// The Event Type Names are inferred based on either explicit DataMember(Name= Attributes, or (if unspecified) the Discriminated Union Case Name + /// Contract must be tagged with interface TypeShape.UnionContract.IUnionContract to signify this scheme applies. + static member Create<'Event, 'Contract, 'Meta when 'Contract :> TypeShape.UnionContract.IUnionContract> + ( /// Maps from the TypeShape UnionConverter 'Contract 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 * 'Contract -> 'Event, + /// Maps a fresh 'Event resulting from a Decision in the Domain representation type down to the TypeShape UnionConverter 'Contract + /// The function is also expected to derive + /// a meta object that will be serialized with the same options (if it's not None) + /// and an Event Creation timestamp. + down : 'Event -> 'Contract * 'Meta option * DateTimeOffset option, + /// Configuration to be used by the underlying System.Text.Json Serializer when encoding/decoding. Defaults to same as Options.Create() + [] ?options, + /// Enables one to fail encoder generation if union contains nullary cases. Defaults to false, i.e. permitting them + [] ?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 IEventCodec using the supplied System.Text.Json options. + /// The Event Type Names are inferred based on either explicit DataMember(Name= Attributes, or (if unspecified) the Discriminated Union Case Name + /// 'Union must be tagged with interface TypeShape.UnionContract.IUnionContract to signify this scheme applies. + static member Create<'Union when 'Union :> TypeShape.UnionContract.IUnionContract> + ( // Configuration to be used by the underlying System.Text.Json Serializer when encoding/decoding. Defaults to same as Options.Create() + [] ?options, + /// Enables one to fail encoder generation if union contains nullary cases. Defaults to false, i.e. permitting them + [] ?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) diff --git a/src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj b/src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj index a4c09a0b..8b319ea8 100644 --- a/src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj +++ b/src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj @@ -9,11 +9,12 @@ - + + @@ -24,6 +25,7 @@ + diff --git a/src/FsCodec.SystemTextJson/JsonOptionConverter.fs b/src/FsCodec.SystemTextJson/JsonOptionConverter.fs index 5dc9037b..8ac06070 100644 --- a/src/FsCodec.SystemTextJson/JsonOptionConverter.fs +++ b/src/FsCodec.SystemTextJson/JsonOptionConverter.fs @@ -1,4 +1,4 @@ -namespace FsCodec.SystemTextJson.Serialization +namespace FsCodec.SystemTextJson.Converters open System open System.Linq.Expressions diff --git a/src/FsCodec.SystemTextJson/JsonRecordConverter.fs b/src/FsCodec.SystemTextJson/JsonRecordConverter.fs index 0b67d39b..def10e7d 100644 --- a/src/FsCodec.SystemTextJson/JsonRecordConverter.fs +++ b/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 diff --git a/src/FsCodec.SystemTextJson/JsonElementHelpers.fs b/src/FsCodec.SystemTextJson/JsonSerializerElementExtensions.fs similarity index 92% rename from src/FsCodec.SystemTextJson/JsonElementHelpers.fs rename to src/FsCodec.SystemTextJson/JsonSerializerElementExtensions.fs index f753f73f..e0ba91e7 100644 --- a/src/FsCodec.SystemTextJson/JsonElementHelpers.fs +++ b/src/FsCodec.SystemTextJson/JsonSerializerElementExtensions.fs @@ -1,4 +1,4 @@ -namespace FsCodec.SystemTextJson +namespace FsCodec.SystemTextJson.Core open System open System.Buffers @@ -6,7 +6,7 @@ open System.Runtime.InteropServices open System.Text.Json [] -module JsonSerializerExtensions = +module internal JsonSerializerExtensions = type JsonSerializer with static member SerializeToElement(value: 'T, [] ?options: JsonSerializerOptions) = JsonSerializer.Deserialize(ReadOnlySpan.op_Implicit(JsonSerializer.SerializeToUtf8Bytes(value, defaultArg options null))) diff --git a/src/FsCodec.SystemTextJson/Options.fs b/src/FsCodec.SystemTextJson/Options.fs index 2c295acf..905cae34 100755 --- a/src/FsCodec.SystemTextJson/Options.fs +++ b/src/FsCodec.SystemTextJson/Options.fs @@ -1,6 +1,5 @@ namespace FsCodec.SystemTextJson -open FsCodec.SystemTextJson.Serialization open System open System.Runtime.InteropServices open System.Text.Json @@ -8,7 +7,9 @@ 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 diff --git a/src/FsCodec.SystemTextJson/Utf8JsonReaderExtensions.fs b/src/FsCodec.SystemTextJson/Utf8JsonReaderExtensions.fs index 4c5d9c87..b48096e5 100644 --- a/src/FsCodec.SystemTextJson/Utf8JsonReaderExtensions.fs +++ b/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 [] -type Utf8JsonReaderExtension = +type internal Utf8JsonReaderExtension = [] 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 - -// [] -// 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 diff --git a/tests/FsCodec.SystemTextJson.Tests/CodecTests.fs b/tests/FsCodec.SystemTextJson.Tests/CodecTests.fs new file mode 100644 index 00000000..28c07792 --- /dev/null +++ b/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 = + FsCodec.SystemTextJson.Core.JsonElementEncoder(defaultOptions) :> _ + +let eventCodec = FsCodec.SystemTextJson.Codec.Create() + +type Envelope = { d : JsonElement } + +[] +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 ser + let wrapped = FsCodec.Core.TimelineEvent.Create(-1L, eventType, des.d) + let decoded = eventCodec.TryDecode wrapped |> Option.get + test <@ value = decoded || ignoreSomeNull @> diff --git a/tests/FsCodec.SystemTextJson.Tests/FsCodec.SystemTextJson.Tests.fsproj b/tests/FsCodec.SystemTextJson.Tests/FsCodec.SystemTextJson.Tests.fsproj index dd154dfc..6f935ed6 100644 --- a/tests/FsCodec.SystemTextJson.Tests/FsCodec.SystemTextJson.Tests.fsproj +++ b/tests/FsCodec.SystemTextJson.Tests/FsCodec.SystemTextJson.Tests.fsproj @@ -8,6 +8,8 @@ + + @@ -19,6 +21,7 @@ + - + \ No newline at end of file diff --git a/tests/FsCodec.SystemTextJson.Tests/SerdesTests.fs b/tests/FsCodec.SystemTextJson.Tests/SerdesTests.fs index 6ce3dcab..8b551694 100644 --- a/tests/FsCodec.SystemTextJson.Tests/SerdesTests.fs +++ b/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 [] ``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"}}""" @>