Skip to content

Commit e2b375b

Browse files
bartelinkbartelink
committed
Add STJ Codec
1 parent 080e207 commit e2b375b

File tree

9 files changed

+211
-19
lines changed

9 files changed

+211
-19
lines changed

‎src/FsCodec.SystemTextJson/Codec.fs‎

Lines changed: 132 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,132 @@
1+
namespace FsCodec.SystemTextJson.Core
2+
3+
open System.Text.Json
4+
5+
/// System.Text.Json implementation of TypeShape.UnionContractEncoder's IEncoder that encodes to a `JsonElement`
6+
type JsonElementEncoder(options : JsonSerializerOptions) =
7+
interface TypeShape.UnionContract.IEncoder<JsonElement> with
8+
member __.Empty = Unchecked.defaultof<_>
9+
10+
member __.Encode(value : 'T) =
11+
JsonSerializer.SerializeToElement(value, options)
12+
13+
member __.Decode(json : JsonElement) =
14+
JsonSerializer.DeserializeElement(json, options)
15+
16+
namespace FsCodec.SystemTextJson
17+
18+
open System
19+
open System.Runtime.InteropServices
20+
open System.Text.Json
21+
22+
/// 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
23+
/// <c>TypeShape.UnionContract.UnionContractEncoder</c> - if you need full control and/or have have your own codecs, see <c>FsCodec.Codec.Create</c> instead
24+
/// See <a href=""https://github.com/eiriktsarpalis/TypeShape/blob/master/tests/TypeShape.Tests/UnionContractTests.fs"></a> for example usage.
25+
type Codec private () =
26+
27+
static let defaultOptions = lazy Options.Create()
28+
29+
/// Generate an <code>IEventCodec</code> using the supplied <c>System.Text.Json<c/> <c>options</c>.
30+
/// Uses <c>up</c> and <c>down</c> functions to facilitate upconversion/downconversion
31+
/// and/or surfacing metadata to the Programming Model by including it in the emitted <c>'Event</c>
32+
/// The Event Type Names are inferred based on either explicit <c>DataMember(Name=</c> Attributes, or (if unspecified) the Discriminated Union Case Name
33+
/// <c>Contract</c> must be tagged with </c>interface TypeShape.UnionContract.IUnionContract</c> to signify this scheme applies.
34+
static member Create<'Event, 'Contract, 'Meta, 'Context when 'Contract :> TypeShape.UnionContract.IUnionContract>
35+
( /// Maps from the TypeShape <c>UnionConverter</c> <c>'Contract</c> case the Event has been mapped to (with the raw event data as context)
36+
/// to the <c>'Event</c> representation (typically a Discriminated Union) that is to be presented to the programming model.
37+
up : FsCodec.ITimelineEvent<JsonElement> * 'Contract -> 'Event,
38+
/// Maps a fresh Event resulting from a Decision in the Domain representation type down to the TypeShape <c>UnionConverter</c> <c>'Contract</c>
39+
/// The function is also expected to derive
40+
/// a <c>meta</c> object that will be serialized with the same options (if it's not <c>None</c>)
41+
/// and an Event Creation <c>timestamp</c>.
42+
down : 'Context option * 'Event -> 'Contract * 'Meta option * Guid * string * string * DateTimeOffset option,
43+
/// Configuration to be used by the underlying <c>System.Text.Json</c> Serializer when encoding/decoding. Defaults to same as <c>Options.Create()</c>
44+
[<Optional; DefaultParameterValue(null)>] ?options,
45+
/// Enables one to fail encoder generation if union contains nullary cases. Defaults to <c>false</c>, i.e. permitting them
46+
[<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases)
47+
: FsCodec.IEventCodec<'Event, JsonElement, 'Context> =
48+
49+
let options = match options with Some x -> x | None -> defaultOptions.Value
50+
let elementEncoder : TypeShape.UnionContract.IEncoder<_> = Core.JsonElementEncoder(options) :> _
51+
let dataCodec =
52+
TypeShape.UnionContract.UnionContractEncoder.Create<'Contract, JsonElement>(
53+
elementEncoder,
54+
requireRecordFields = true, // See JsonConverterTests - round-tripping UTF-8 correctly with Json.net is painful so for now we lock up the dragons
55+
allowNullaryCases = not (defaultArg rejectNullaryCases false))
56+
57+
{ new FsCodec.IEventCodec<'Event, JsonElement, 'Context> with
58+
member __.Encode(context, event) =
59+
let (c, meta : 'Meta option, eventId, correlationId, causationId, timestamp : DateTimeOffset option) = down (context, event)
60+
let enc = dataCodec.Encode c
61+
let metaUtf8 = meta |> Option.map elementEncoder.Encode<'Meta>
62+
FsCodec.Core.EventData.Create(enc.CaseName, enc.Payload, Unchecked.defaultof<_>, eventId, correlationId, causationId, ?timestamp = timestamp)
63+
64+
member __.TryDecode encoded =
65+
match dataCodec.TryDecode { CaseName = encoded.EventType; Payload = encoded.Data } with
66+
| None -> None
67+
| Some contract -> up (encoded, contract) |> Some }
68+
69+
/// Generate an <code>IEventCodec</code> using the supplied <c>System.Text.Json<c/> <c>options</c>.
70+
/// Uses <c>up</c> and <c>down</c> and <c>mapCausation</c> functions to facilitate upconversion/downconversion and correlation/causationId mapping
71+
/// and/or surfacing metadata to the Programming Model by including it in the emitted <c>'Event</c>
72+
/// The Event Type Names are inferred based on either explicit <c>DataMember(Name=</c> Attributes, or (if unspecified) the Discriminated Union Case Name
73+
/// <c>Contract</c> must be tagged with </c>interface TypeShape.UnionContract.IUnionContract</c> to signify this scheme applies.
74+
static member Create<'Event, 'Contract, 'Meta, 'Context when 'Contract :> TypeShape.UnionContract.IUnionContract>
75+
( /// Maps from the TypeShape <c>UnionConverter</c> <c>'Contract</c> case the Event has been mapped to (with the raw event data as context)
76+
/// to the representation (typically a Discriminated Union) that is to be presented to the programming model.
77+
up : FsCodec.ITimelineEvent<JsonElement> * 'Contract -> 'Event,
78+
/// Maps a fresh Event resulting from a Decision in the Domain representation type down to the TypeShape <c>UnionConverter</c> <c>'Contract</c>
79+
/// The function is also expected to derive
80+
/// a <c>meta</c> object that will be serialized with the same options (if it's not <c>None</c>)
81+
/// and an Event Creation <c>timestamp</c>.
82+
down : 'Event -> 'Contract * 'Meta option * DateTimeOffset option,
83+
/// 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
84+
mapCausation : 'Context option * 'Meta option -> 'Meta option * Guid * string * string,
85+
/// Configuration to be used by the underlying <c>System.Text.Json</c> Serializer when encoding/decoding. Defaults to same as <c>Options.Create()</c>
86+
[<Optional; DefaultParameterValue(null)>] ?options,
87+
/// Enables one to fail encoder generation if union contains nullary cases. Defaults to <c>false</c>, i.e. permitting them
88+
[<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases)
89+
: FsCodec.IEventCodec<'Event, JsonElement, 'Context> =
90+
91+
let down (context, union) =
92+
let c, m, t = down union
93+
let m', eventId, correlationId, causationId = mapCausation (context, m)
94+
c, m', eventId, correlationId, causationId, t
95+
Codec.Create(up = up, down = down, ?options = options, ?rejectNullaryCases = rejectNullaryCases)
96+
97+
/// Generate an <code>IEventCodec</code> using the supplied <c>System.Text.Json<c/> <c>options</c>.
98+
/// Uses <c>up</c> and <c>down</c> and <c>mapCausation</c> functions to facilitate upconversion/downconversion and correlation/causationId mapping
99+
/// and/or surfacing metadata to the Programming Model by including it in the emitted <c>'Event</c>
100+
/// The Event Type Names are inferred based on either explicit <c>DataMember(Name=</c> Attributes, or (if unspecified) the Discriminated Union Case Name
101+
/// <c>Contract</c> must be tagged with </c>interface TypeShape.UnionContract.IUnionContract</c> to signify this scheme applies.
102+
static member Create<'Event, 'Contract, 'Meta when 'Contract :> TypeShape.UnionContract.IUnionContract>
103+
( /// Maps from the TypeShape <c>UnionConverter</c> <c>'Contract</c> case the Event has been mapped to (with the raw event data as context)
104+
/// to the representation (typically a Discriminated Union) that is to be presented to the programming model.
105+
up : FsCodec.ITimelineEvent<JsonElement> * 'Contract -> 'Event,
106+
/// 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>
107+
/// The function is also expected to derive
108+
/// a <c>meta</c> object that will be serialized with the same options (if it's not <c>None</c>)
109+
/// and an Event Creation <c>timestamp</c>.
110+
down : 'Event -> 'Contract * 'Meta option * DateTimeOffset option,
111+
/// Configuration to be used by the underlying <c>System.Text.Json</c> Serializer when encoding/decoding. Defaults to same as <c>Options.Create()</c>
112+
[<Optional; DefaultParameterValue(null)>] ?options,
113+
/// Enables one to fail encoder generation if union contains nullary cases. Defaults to <c>false</c>, i.e. permitting them
114+
[<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases)
115+
: FsCodec.IEventCodec<'Event, JsonElement, obj> =
116+
117+
let mapCausation (_context : obj, m : 'Meta option) = m, Guid.NewGuid(), null, null
118+
Codec.Create(up = up, down = down, mapCausation = mapCausation, ?options = options, ?rejectNullaryCases = rejectNullaryCases)
119+
120+
/// Generate an <code>IEventCodec</code> using the supplied <c>System.Text.Json</c> <c>options</c>.
121+
/// The Event Type Names are inferred based on either explicit <c>DataMember(Name=</c> Attributes, or (if unspecified) the Discriminated Union Case Name
122+
/// <c>'Union</c> must be tagged with <c>interface TypeShape.UnionContract.IUnionContract</c> to signify this scheme applies.
123+
static member Create<'Union when 'Union :> TypeShape.UnionContract.IUnionContract>
124+
( // Configuration to be used by the underlying <c>System.Text.Json</c> Serializer when encoding/decoding. Defaults to same as <c>Options.Create()</c>
125+
[<Optional; DefaultParameterValue(null)>] ?options,
126+
/// Enables one to fail encoder generation if union contains nullary cases. Defaults to <c>false</c>, i.e. permitting them
127+
[<Optional; DefaultParameterValue(null)>] ?rejectNullaryCases)
128+
: FsCodec.IEventCodec<'Union, JsonElement, obj> =
129+
130+
let up : FsCodec.ITimelineEvent<_> * 'Union -> 'Union = snd
131+
let down (event : 'Union) = event, None, None
132+
Codec.Create(up = up, down = down, ?options = options, ?rejectNullaryCases = rejectNullaryCases)

‎src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,11 +9,12 @@
99
</PropertyGroup>
1010

1111
<ItemGroup>
12-
<Compile Include="JsonElementHelpers.fs" />
12+
<Compile Include="JsonSerializerElementExtensions.fs" />
1313
<Compile Include="Utf8JsonReaderExtensions.fs" />
1414
<Compile Include="JsonOptionConverter.fs" />
1515
<Compile Include="JsonRecordConverter.fs" />
1616
<Compile Include="Options.fs" />
17+
<Compile Include="Codec.fs" />
1718
<Compile Include="Serdes.fs" />
1819
</ItemGroup>
1920

@@ -24,6 +25,7 @@
2425
<PackageReference Include="FSharp.Core" Version="4.3.4" Condition=" '$(TargetFramework)' == 'netstandard2.1' " />
2526

2627
<PackageReference Include="System.Text.Json" Version="4.7.0" />
28+
<PackageReference Include="TypeShape" Version="8.0.0" />
2729
</ItemGroup>
2830

2931
<ItemGroup>

‎src/FsCodec.SystemTextJson/JsonOptionConverter.fs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
namespace FsCodec.SystemTextJson.Serialization
1+
namespace FsCodec.SystemTextJson.Converters
22

33
open System
44
open System.Linq.Expressions

‎src/FsCodec.SystemTextJson/JsonRecordConverter.fs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
1-
namespace FsCodec.SystemTextJson.Serialization
1+
namespace FsCodec.SystemTextJson.Converters
22

3+
open FsCodec.SystemTextJson.Core
34
open FSharp.Reflection
45
open System
56
open System.Collections.Generic

‎src/FsCodec.SystemTextJson/JsonElementHelpers.fs‎ renamed to ‎src/FsCodec.SystemTextJson/JsonSerializerElementExtensions.fs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,12 @@
1-
namespace FsCodec.SystemTextJson
1+
namespace FsCodec.SystemTextJson.Core
22

33
open System
44
open System.Buffers
55
open System.Runtime.InteropServices
66
open System.Text.Json
77

88
[<AutoOpen>]
9-
module JsonSerializerExtensions =
9+
module internal JsonSerializerExtensions =
1010
type JsonSerializer with
1111
static member SerializeToElement(value: 'T, [<Optional; DefaultParameterValue(null)>] ?options: JsonSerializerOptions) =
1212
JsonSerializer.Deserialize<JsonElement>(ReadOnlySpan.op_Implicit(JsonSerializer.SerializeToUtf8Bytes(value, defaultArg options null)))

‎src/FsCodec.SystemTextJson/Options.fs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,15 @@
11
namespace FsCodec.SystemTextJson
22

3-
open FsCodec.SystemTextJson.Serialization
43
open System
54
open System.Runtime.InteropServices
65
open System.Text.Json
76
open System.Text.Json.Serialization
87

98
type Options private () =
109

11-
static let defaultConverters : JsonConverterFactory[] = [| JsonOptionConverter(); JsonRecordConverter() |]
10+
static let defaultConverters : JsonConverterFactory[] =
11+
[| Converters.JsonOptionConverter()
12+
Converters.JsonRecordConverter() |]
1213

1314
/// Creates a default set of serializer options used by Json serialization. When used with no args, same as `JsonSerializerOptions()`
1415
static member CreateDefault

‎src/FsCodec.SystemTextJson/Utf8JsonReaderExtensions.fs‎

Lines changed: 2 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -1,22 +1,13 @@
1-
namespace FsCodec.SystemTextJson.Serialization
1+
namespace FsCodec.SystemTextJson.Core
22

33
open System.Runtime.CompilerServices
44
open System.Text.Json
55

66
[<Extension>]
7-
type Utf8JsonReaderExtension =
7+
type internal Utf8JsonReaderExtension =
88
[<Extension>]
99
static member ValidateTokenType(reader: Utf8JsonReader, expectedTokenType) =
1010
if reader.TokenType <> expectedTokenType then
1111
sprintf "Expected a %A token, but encountered a %A token when parsing JSON." expectedTokenType (reader.TokenType)
1212
|> JsonException
1313
|> raise
14-
15-
// [<Extension>]
16-
// static member ValidatePropertyName(reader: Utf8JsonReader, expectedPropertyName: string) =
17-
// reader.ValidateTokenType(JsonTokenType.PropertyName)
18-
//
19-
// if not <| reader.ValueTextEquals expectedPropertyName then
20-
// sprintf "Expected a property named '%s', but encountered property with name '%s'." expectedPropertyName (reader.GetString())
21-
// |> JsonException
22-
// |> raise

‎tests/FsCodec.SystemTextJson.Tests/CodecTests.fs‎

Lines changed: 62 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,62 @@
1+
module FsCodec.SystemTextJson.Tests.CodecTests
2+
3+
open System.Text.Json
4+
open FsCheck.Xunit
5+
open Swensen.Unquote
6+
7+
type Embedded = { embed : string }
8+
type EmbeddedWithOption = { embed : string; opt : string option }
9+
type Union =
10+
| A of Embedded
11+
| B of Embedded
12+
| AO of EmbeddedWithOption
13+
| BO of EmbeddedWithOption
14+
interface TypeShape.UnionContract.IUnionContract
15+
16+
let defaultOptions = FsCodec.SystemTextJson.Options.Create(ignoreNulls=true)
17+
let elementEncoder : TypeShape.UnionContract.IEncoder<System.Text.Json.JsonElement> =
18+
FsCodec.SystemTextJson.Core.JsonElementEncoder(defaultOptions) :> _
19+
20+
let eventCodec = FsCodec.SystemTextJson.Codec.Create<Union>()
21+
22+
type Envelope = { d : JsonElement }
23+
24+
[<Property>]
25+
let roundtrips value =
26+
let eventType, embedded =
27+
match value with
28+
| A e -> "A",Choice1Of2 e
29+
| AO e -> "AO",Choice2Of2 e
30+
| B e -> "B",Choice1Of2 e
31+
| BO e -> "BO",Choice2Of2 e
32+
33+
let encoded, ignoreSomeNull =
34+
match embedded with
35+
| Choice1Of2 e -> elementEncoder.Encode e, false
36+
| Choice2Of2 eo -> elementEncoder.Encode eo, eo.opt = Some null
37+
38+
let enveloped = { d = encoded }
39+
let ser = FsCodec.SystemTextJson.Serdes.Serialize enveloped
40+
41+
match embedded with
42+
| x when obj.ReferenceEquals(null, x) ->
43+
test <@ ser.StartsWith("""{"d":{""") @>
44+
| Choice1Of2 { embed = null }
45+
| Choice2Of2 { embed = null; opt = None } ->
46+
test <@ ser = """{"d":{}}""" @>
47+
| Choice2Of2 { embed = null; opt = Some null } ->
48+
// TOCONSIDER - should ideally treat Some null as equivalent to None
49+
test <@ ser.StartsWith("""{"d":{"opt":null}}""") @>
50+
| Choice2Of2 { embed = null } ->
51+
test <@ ser.StartsWith("""{"d":{"opt":""") @>
52+
| _ ->
53+
test <@ ser.StartsWith("""{"d":{"embed":""") @>
54+
55+
match embedded with
56+
| Choice2Of2 { opt = None } -> test <@ not (ser.Contains "opt") @>
57+
| _ -> ()
58+
59+
let des = FsCodec.SystemTextJson.Serdes.Deserialize<Envelope> ser
60+
let wrapped = FsCodec.Core.TimelineEvent<JsonElement>.Create(-1L, eventType, des.d)
61+
let decoded = eventCodec.TryDecode wrapped |> Option.get
62+
test <@ value = decoded || ignoreSomeNull @>

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

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,8 @@
88

99
<ItemGroup>
1010
<PackageReference Include="Microsoft.NET.Test.Sdk" Version="16.5.0" />
11+
12+
<PackageReference Include="FsCheck.Xunit" Version="2.14.1" />
1113
<PackageReference Include="Unquote" Version="5.0.0" />
1214
<PackageReference Include="xunit" Version="2.4.1" />
1315
<PackageReference Include="xunit.runner.visualstudio" Version="2.4.1" />
@@ -19,6 +21,7 @@
1921

2022
<ItemGroup>
2123
<Compile Include="SerdesTests.fs" />
24+
<Compile Include="CodecTests.fs" />
2225
</ItemGroup>
2326

24-
</Project>
27+
</Project>

0 commit comments

Comments
 (0)