From f346b1abbfec69efa1c3d8a32a22a0f48cb55689 Mon Sep 17 00:00:00 2001 From: Ruben Bartelink Date: Fri, 1 Jul 2022 16:26:15 +0100 Subject: [PATCH 1/4] Wip --- src/FsCodec.SystemTextJson/Deflate.fs | 70 +++++++++++++++++++ .../FsCodec.SystemTextJson.fsproj | 1 + 2 files changed, 71 insertions(+) create mode 100644 src/FsCodec.SystemTextJson/Deflate.fs diff --git a/src/FsCodec.SystemTextJson/Deflate.fs b/src/FsCodec.SystemTextJson/Deflate.fs new file mode 100644 index 0000000..e67f448 --- /dev/null +++ b/src/FsCodec.SystemTextJson/Deflate.fs @@ -0,0 +1,70 @@ +namespace FsCodec + +open System +open System.Runtime.CompilerServices +open FsCodec + +module private MaybeDeflatedBody = + + type Encoded = (struct (int * ReadOnlyMemory)) + let empty : Encoded = 0, ReadOnlyMemory.Empty + + (* EncodedBody can potentially hold compressed content, that we'll inflate on demand *) + + let private inflate (data : ReadOnlyMemory) : byte array = + let s = new System.IO.MemoryStream(data.ToArray(), writable = false) + let decompressor = new System.IO.Compression.DeflateStream(s, System.IO.Compression.CompressionMode.Decompress, leaveOpen = true) + let output = new System.IO.MemoryStream() + decompressor.CopyTo(output) + output.ToArray() + let decode struct (encoding, data) : ReadOnlyMemory = + if encoding <> 0 then inflate data |> ReadOnlyMemory + else data + + (* Compression is conditional on the input meeting a minimum size, and the result meeting a required gain *) + + let private deflate (eventBody : ReadOnlyMemory) : System.IO.MemoryStream = + let output = new System.IO.MemoryStream() + let compressor = new System.IO.Compression.DeflateStream(output, System.IO.Compression.CompressionLevel.Optimal, leaveOpen = true) + compressor.Write(eventBody.Span) + compressor.Flush() + output + let private encodeUncompressed (raw : ReadOnlyMemory) : Encoded = 0, raw + let encode minSize minGain (raw : ReadOnlyMemory) : Encoded = + if raw.Length < minSize then encodeUncompressed raw + else match deflate raw with + | tmp when raw.Length > int tmp.Length + minGain -> 1, tmp.ToArray() |> ReadOnlyMemory + | _ -> encodeUncompressed raw + +type [] CompressionOptions = { minSize : int; minGain : int } with + /// Attempt to compress anything possible + // TL;DR in general it's worth compressing everything to minimize RU consumption both on insert and update + // For DynamoStore, every time we need to calve from the tip, the RU impact of using TransactWriteItems is significant, + // so preventing or delaying that is of critical significance + // Empirically not much JSON below 48 bytes actually compresses - while we don't assume that, it is what is guiding the derivation of the default + static member Default = { minSize = 48; minGain = 4 } + /// Encode the data without attempting to Deflate, regardless of size + static member NoCompression = { minSize = Int32.MaxValue; minGain = 0 } + +[] +type DeflateHelpers = + + static member Utf8ToMaybeDeflateEncoded options (x : ReadOnlyMemory) : struct (int * ReadOnlyMemory) = + MaybeDeflatedBody.encode options.minSize options.minGain x + + static member EncodedToUtf8(x) : ReadOnlyMemory = + MaybeDeflatedBody.decode x + + /// Adapts an IEventCodec that's rendering to ReadOnlyMemory Event Bodies to attempt to compress the UTF-8 data.
+ [] + static member EncodeWithTryDeflate<'Event, 'Context>(native : IEventCodec<'Event, ReadOnlyMemory, 'Context>, ?options) + : IEventCodec<'Event, struct (int * ReadOnlyMemory), 'Context> = + let opts = defaultArg options CompressionOptions.Default + FsCodec.Core.EventCodec.Map(native, DeflateHelpers.Utf8ToMaybeDeflateEncoded opts, DeflateHelpers.EncodedToUtf8) + + /// Adapts an IEventCodec that's rendering to ReadOnlyMemory Event Bodies to attempt to compress the UTF-8 data.
+ [] + static member EncodeWithoutCompression<'Event, 'Context>(native : IEventCodec<'Event, ReadOnlyMemory, 'Context>) + : IEventCodec<'Event, struct (int * ReadOnlyMemory), 'Context> = + let opts = CompressionOptions.NoCompression + FsCodec.Core.EventCodec.Map(native, DeflateHelpers.Utf8ToMaybeDeflateEncoded opts, DeflateHelpers.EncodedToUtf8) diff --git a/src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj b/src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj index 373e092..c68ec52 100644 --- a/src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj +++ b/src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj @@ -15,6 +15,7 @@ + From 61462344d2662c505abc2ae7f13e5d94a57352b2 Mon Sep 17 00:00:00 2001 From: Ruben Bartelink Date: Fri, 1 Jul 2022 16:31:40 +0100 Subject: [PATCH 2/4] Reorg --- src/{FsCodec.SystemTextJson => FsCodec.Box}/Deflate.fs | 1 - src/FsCodec.Box/FsCodec.Box.fsproj | 1 + src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj | 1 - 3 files changed, 1 insertion(+), 2 deletions(-) rename src/{FsCodec.SystemTextJson => FsCodec.Box}/Deflate.fs (99%) diff --git a/src/FsCodec.SystemTextJson/Deflate.fs b/src/FsCodec.Box/Deflate.fs similarity index 99% rename from src/FsCodec.SystemTextJson/Deflate.fs rename to src/FsCodec.Box/Deflate.fs index e67f448..359d31f 100644 --- a/src/FsCodec.SystemTextJson/Deflate.fs +++ b/src/FsCodec.Box/Deflate.fs @@ -2,7 +2,6 @@ namespace FsCodec open System open System.Runtime.CompilerServices -open FsCodec module private MaybeDeflatedBody = diff --git a/src/FsCodec.Box/FsCodec.Box.fsproj b/src/FsCodec.Box/FsCodec.Box.fsproj index 0971b8d..2f58e56 100644 --- a/src/FsCodec.Box/FsCodec.Box.fsproj +++ b/src/FsCodec.Box/FsCodec.Box.fsproj @@ -9,6 +9,7 @@ + diff --git a/src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj b/src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj index c68ec52..373e092 100644 --- a/src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj +++ b/src/FsCodec.SystemTextJson/FsCodec.SystemTextJson.fsproj @@ -15,7 +15,6 @@ - From 5cfd79977886ac16f5ad8263e996db97e76cf5af Mon Sep 17 00:00:00 2001 From: Ruben Bartelink Date: Mon, 4 Jul 2022 14:35:23 +0100 Subject: [PATCH 3/4] Add basic tests --- src/FsCodec.Box/FsCodec.Box.fsproj | 2 +- src/FsCodec.Box/{Deflate.fs => TryDeflate.fs} | 28 +++++--- src/FsCodec/Codec.fs | 24 +++---- tests/FsCodec.Tests/FsCodec.Tests.fsproj | 1 + tests/FsCodec.Tests/TryDeflateTests.fs | 68 +++++++++++++++++++ 5 files changed, 99 insertions(+), 24 deletions(-) rename src/FsCodec.Box/{Deflate.fs => TryDeflate.fs} (69%) create mode 100644 tests/FsCodec.Tests/TryDeflateTests.fs diff --git a/src/FsCodec.Box/FsCodec.Box.fsproj b/src/FsCodec.Box/FsCodec.Box.fsproj index 2f58e56..52abe8b 100644 --- a/src/FsCodec.Box/FsCodec.Box.fsproj +++ b/src/FsCodec.Box/FsCodec.Box.fsproj @@ -9,7 +9,7 @@ - + diff --git a/src/FsCodec.Box/Deflate.fs b/src/FsCodec.Box/TryDeflate.fs similarity index 69% rename from src/FsCodec.Box/Deflate.fs rename to src/FsCodec.Box/TryDeflate.fs index 359d31f..07da048 100644 --- a/src/FsCodec.Box/Deflate.fs +++ b/src/FsCodec.Box/TryDeflate.fs @@ -2,11 +2,15 @@ namespace FsCodec open System open System.Runtime.CompilerServices +open System.Runtime.InteropServices module private MaybeDeflatedBody = + type Encoding = + | Direct = 0 + | Deflate = 1 type Encoded = (struct (int * ReadOnlyMemory)) - let empty : Encoded = 0, ReadOnlyMemory.Empty + let empty : Encoded = int Encoding.Direct, ReadOnlyMemory.Empty (* EncodedBody can potentially hold compressed content, that we'll inflate on demand *) @@ -17,7 +21,7 @@ module private MaybeDeflatedBody = decompressor.CopyTo(output) output.ToArray() let decode struct (encoding, data) : ReadOnlyMemory = - if encoding <> 0 then inflate data |> ReadOnlyMemory + if encoding = int Encoding.Deflate then inflate data |> ReadOnlyMemory else data (* Compression is conditional on the input meeting a minimum size, and the result meeting a required gain *) @@ -32,7 +36,7 @@ module private MaybeDeflatedBody = let encode minSize minGain (raw : ReadOnlyMemory) : Encoded = if raw.Length < minSize then encodeUncompressed raw else match deflate raw with - | tmp when raw.Length > int tmp.Length + minGain -> 1, tmp.ToArray() |> ReadOnlyMemory + | tmp when raw.Length > int tmp.Length + minGain -> int Encoding.Deflate, tmp.ToArray() |> ReadOnlyMemory | _ -> encodeUncompressed raw type [] CompressionOptions = { minSize : int; minGain : int } with @@ -42,8 +46,8 @@ type [] CompressionOptions = { minSize : int; minGain : int } with // so preventing or delaying that is of critical significance // Empirically not much JSON below 48 bytes actually compresses - while we don't assume that, it is what is guiding the derivation of the default static member Default = { minSize = 48; minGain = 4 } - /// Encode the data without attempting to Deflate, regardless of size - static member NoCompression = { minSize = Int32.MaxValue; minGain = 0 } + /// Encode the data without attempting to compress, regardless of size + static member Uncompressed = { minSize = Int32.MaxValue; minGain = 0 } [] type DeflateHelpers = @@ -54,16 +58,18 @@ type DeflateHelpers = static member EncodedToUtf8(x) : ReadOnlyMemory = MaybeDeflatedBody.decode x - /// Adapts an IEventCodec that's rendering to ReadOnlyMemory Event Bodies to attempt to compress the UTF-8 data.
+ /// Adapts an IEventCodec rendering to ReadOnlyMemory Event Bodies to attempt to compress the UTF-8 data.
+ /// If sufficient compression, as defined by options is not achieved, the body is saved as-is.
+ /// The int conveys a flag indicating whether compression was applied. [] - static member EncodeWithTryDeflate<'Event, 'Context>(native : IEventCodec<'Event, ReadOnlyMemory, 'Context>, ?options) + static member EncodeWithTryDeflate<'Event, 'Context>(native : IEventCodec<'Event, ReadOnlyMemory, 'Context>, [] ?options) : IEventCodec<'Event, struct (int * ReadOnlyMemory), 'Context> = let opts = defaultArg options CompressionOptions.Default FsCodec.Core.EventCodec.Map(native, DeflateHelpers.Utf8ToMaybeDeflateEncoded opts, DeflateHelpers.EncodedToUtf8) - /// Adapts an IEventCodec that's rendering to ReadOnlyMemory Event Bodies to attempt to compress the UTF-8 data.
+ /// Adapts an IEventCodec rendering to ReadOnlyMemory Event Bodies to encode as per EncodeWithTryDeflate, but without attempting compression.
[] - static member EncodeWithoutCompression<'Event, 'Context>(native : IEventCodec<'Event, ReadOnlyMemory, 'Context>) + static member EncodeUncompressed<'Event, 'Context>(native : IEventCodec<'Event, ReadOnlyMemory, 'Context>) : IEventCodec<'Event, struct (int * ReadOnlyMemory), 'Context> = - let opts = CompressionOptions.NoCompression - FsCodec.Core.EventCodec.Map(native, DeflateHelpers.Utf8ToMaybeDeflateEncoded opts, DeflateHelpers.EncodedToUtf8) + let nullOpts = CompressionOptions.Uncompressed + DeflateHelpers.EncodeWithTryDeflate(native, nullOpts) diff --git a/src/FsCodec/Codec.fs b/src/FsCodec/Codec.fs index 2932929..59fff35 100755 --- a/src/FsCodec/Codec.fs +++ b/src/FsCodec/Codec.fs @@ -11,10 +11,10 @@ type Codec = // employed in the convention-based Codec // (IME, while many systems have some code touching the metadata, it's not something one typically wants to encourage) static member private Create<'Event, 'Format, 'Context> - ( /// Maps an 'Event to: an Event Type Name, a pair of 'Format's representing the Data and Meta together with the - /// eventId, correlationId, causationId and timestamp. + ( // Maps an 'Event to: an Event Type Name, a pair of 'Format's representing the Data and Meta together with the + // eventId, correlationId, causationId and timestamp. encode : 'Context option * 'Event -> string * 'Format * 'Format * Guid * string * string * DateTimeOffset option, - /// Attempts to map from an Event's stored data to Some 'Event, or None if not mappable. + // Attempts to map from an Event's stored data to Some 'Event, or None if not mappable. tryDecode : ITimelineEvent<'Format> -> 'Event option) : IEventCodec<'Event, 'Format, 'Context> = @@ -29,15 +29,15 @@ type Codec = /// Generate an IEventCodec suitable using the supplied encode and tryDecode functions to map to/from the stored form. /// mapCausation provides metadata generation and correlation/causationId mapping based on the context passed to the encoder static member Create<'Event, 'Format, 'Context> - ( /// 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 settings (if it's not None) - /// and an Event Creation timestamp. + ( // 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 settings (if it's not None) + // and an Event Creation timestamp. encode : 'Event -> string * 'Format * DateTimeOffset option, - /// 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. + // 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. tryDecode : ITimelineEvent<'Format> -> 'Event 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 + // 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 * 'Event -> 'Format * Guid * string * string) : IEventCodec<'Event, 'Format, 'Context> = @@ -49,9 +49,9 @@ type Codec = /// Generate an IEventCodec using the supplied pair of encode and tryDecode functions. static member Create<'Event, 'Format> - ( /// Maps a 'Event to an Event Type Name and a UTF-8 array representing the Data. + ( // Maps a 'Event to an Event Type Name and a UTF-8 array representing the Data. encode : 'Event -> string * 'Format, - /// Attempts to map an Event Type Name and a UTF-8 array Data to Some 'Event case, or None if not mappable. + // Attempts to map an Event Type Name and a UTF-8 array Data to Some 'Event case, or None if not mappable. tryDecode : string * 'Format -> 'Event option) : IEventCodec<'Event, 'Format, obj> = diff --git a/tests/FsCodec.Tests/FsCodec.Tests.fsproj b/tests/FsCodec.Tests/FsCodec.Tests.fsproj index 81c21c9..db5a8f9 100644 --- a/tests/FsCodec.Tests/FsCodec.Tests.fsproj +++ b/tests/FsCodec.Tests/FsCodec.Tests.fsproj @@ -7,6 +7,7 @@ + diff --git a/tests/FsCodec.Tests/TryDeflateTests.fs b/tests/FsCodec.Tests/TryDeflateTests.fs new file mode 100644 index 0000000..49e12ec --- /dev/null +++ b/tests/FsCodec.Tests/TryDeflateTests.fs @@ -0,0 +1,68 @@ +module FsCodec.Core.Tests.DeflateTests + +open System +open Swensen.Unquote +open Xunit + +let inline roundtrip (sut : FsCodec.IEventCodec<_, _, _>) value = + let encoded = sut.Encode(context = None, value = value) + let loaded = FsCodec.Core.TimelineEvent.Create(-1L, encoded.EventType, encoded.Data) + sut.TryDecode loaded + +(* Base Fixture Round-trips a String encoded as ReadOnlyMemory UTF-8 blob *) + +module StringUtf8 = + + let eventType = "n/a" + let enc (s : string) : ReadOnlyMemory = System.Text.Encoding.UTF8.GetBytes s |> ReadOnlyMemory + let dec (b : ReadOnlySpan) : string = System.Text.Encoding.UTF8.GetString b + let stringUtf8Encoder = + let encode e = eventType, enc e + let tryDecode (s, b : ReadOnlyMemory) = if s = eventType then Some (dec b.Span) else invalidOp "Invalid eventType value" + FsCodec.Codec.Create(encode, tryDecode) + + let sut = stringUtf8Encoder + + let [] roundtrips () = + let value = "TestValue" + let res' = roundtrip sut value + res' =! Some value + +module WithTryDeflate = + + let sut = FsCodec.DeflateHelpers.EncodeWithTryDeflate(StringUtf8.sut) + + let compressibleValue = String('x', 5000) + + let [] roundtrips () = + let res' = roundtrip sut compressibleValue + res' =! Some compressibleValue + + let [] ``compresses when possible`` () = + let encoded = sut.Encode(context = None, value = compressibleValue) + let struct (encoding, encodedValue) = encoded.Data + encodedValue.Length ] ``uses raw value where compression not possible`` () = + let value = "NotCompressible" + let directResult = StringUtf8.sut.Encode(None, value).Data + let encoded = sut.Encode(context = None, value = value) + let struct (_encoding, result) = encoded.Data + true =! directResult.Span.SequenceEqual(result.Span) + +module WithoutCompression = + + let sut = FsCodec.DeflateHelpers.EncodeUncompressed(StringUtf8.sut) + + // Borrow a demonstrably compressible value + let value = WithTryDeflate.compressibleValue + + let [] roundtrips () = + let res' = roundtrip sut value + res' =! Some value + + let [] ``does not compress, even if it was possible to`` () = + let directResult = StringUtf8.sut.Encode(None, value).Data + let encoded = sut.Encode(context = None, value = value) + let struct (_encoding, result) = encoded.Data + true =! directResult.Span.SequenceEqual(result.Span) From d2e2fd19b29bfd5c371f8616059dfffce107770f Mon Sep 17 00:00:00 2001 From: Ruben Bartelink Date: Mon, 4 Jul 2022 14:46:21 +0100 Subject: [PATCH 4/4] Changelog --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 102a66e..9a39626 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,7 +10,7 @@ The `Unreleased` section name is replaced by the expected version of next releas ### Added -- `EncodeWithTryDeflate/EncodeWithoutCompression`: Maps `ReadOnlyMemory` bodies to `int * ReadOnlyMemory` with a non-zero value indicating compression was applied [#78](https://github.com/jet/FsCodec/pull/78) +- `EncodeWithTryDeflate/EncodeUncompressed`: Maps `ReadOnlyMemory` bodies to `int * ReadOnlyMemory` (with a non-zero value indicating compression was applied) [#80](https://github.com/jet/FsCodec/pull/80) ### Changed