Re-add compression to BwdServer

fsharp-backend/paket.dependencies

@@ -27,6 +27,7 @@ nuget FsCheck = 2.16.4
 nuget FSharp.Compiler.Service = 41.0.3
 nuget NReco.Logging.File = 1.1.3
 nuget SimpleBase = 3.1.0
+nuget ChunkDecoder = 1.0.4.1
 
 // Services
 nuget Lib.AspNetCore.ServerTiming = 4.3.0

fsharp-backend/paket.lock

@@ -8,6 +8,7 @@ NUGET
     AspNetCore.HealthChecks.NpgSql (6.0.1)
       Microsoft.Extensions.Diagnostics.HealthChecks (>= 6.0)
       Npgsql (>= 6.0)
+    ChunkDecoder (1.0.4.1)
     Expecto (9.0.4)
       FSharp.Core (>= 4.6)
       Mono.Cecil (>= 0.11.3)

fsharp-backend/src/BackendOnlyStdLib/HttpClient.fs

@@ -195,6 +195,7 @@ let httpCall'
           | "gzip" -> new GZipStream(responseStream, decompress)
           | "deflate" -> new DeflateStream(responseStream, decompress)
           | "" -> responseStream
+          // FSTODO: test other format such as zstd
           | _ -> raise (InvalidEncodingException(int response.StatusCode))
 
         use memoryStream = new MemoryStream()

fsharp-backend/src/BwdServer/BwdServer.fsproj

@@ -9,14 +9,15 @@
     <PublishReadyToRun>true</PublishReadyToRun>
     <SelfContained>true</SelfContained>
     <PublishSingleFile>true</PublishSingleFile>
-    <!-- We don't trim any of these, as if we do the JSON serializrts break. This is
+    <!-- We don't trim any of these, as if we do the JSON serializers break. This is
          because they use reflection which is a documented thing that's likely to
          break. When we get source generators going, this might improve. -->
     <PublishTrimmed>false</PublishTrimmed>
     <RuntimeIdentifier>linux-x64</RuntimeIdentifier>
   </PropertyGroup>
   <ItemGroup>
     <None Include="paket.references" />
+    <Compile Include="Compression.fs" />
     <Compile Include="Server.fs" />
   </ItemGroup>
   <ItemGroup>

fsharp-backend/src/BwdServer/Compression.fs

@@ -0,0 +1,51 @@
+module BwdServer.Compression
+
+open FSharp.Control.Tasks
+open System.Threading.Tasks
+
+open System
+open Microsoft.AspNetCore
+open Microsoft.AspNetCore.Builder
+open Microsoft.AspNetCore.Hosting
+open Microsoft.AspNetCore.Http
+open Microsoft.AspNetCore.Http.Extensions
+open Microsoft.AspNetCore.Http.Abstractions
+open Microsoft.Extensions.Logging
+open Microsoft.Extensions.Hosting
+open Microsoft.Extensions.DependencyInjection
+open Microsoft.AspNetCore.ResponseCompression
+open Microsoft.Extensions.DependencyInjection.Extensions
+
+type CustomCompressionProvider(services, options) =
+  inherit ResponseCompressionProvider(services, options)
+  override this.ShouldCompressResponse(ctx : HttpContext) : bool =
+    // Compress responses unless they're too small
+    let default_ = base.ShouldCompressResponse ctx
+    let tooSmall =
+      // This was the setting we had in the ocaml nginx
+      if ctx.Response.ContentLength.HasValue then
+        ctx.Response.ContentLength.Value < 1024
+      else
+        false
+    default_ && not tooSmall
+
+let configureServices (services : IServiceCollection) : IServiceCollection =
+  let configureOptions (options : ResponseCompressionOptions) : unit =
+    // CLEANUP: This is set to the same values as we used in nginx for the ocaml
+    // bwdserver. By default, .net also had a few others: text/javascript,
+    // application/xml, text/xml, text/json, application/wasm. They aren't that
+    // interesting to us right now.
+    options.MimeTypes <-
+      [ "text/html"
+        "text/plain"
+        "text/css"
+        "application/javascript"
+        "application/json" ]
+  services.Configure(configureOptions) |> ignore<IServiceCollection>
+  services.TryAddSingleton<IResponseCompressionProvider, CustomCompressionProvider>()
+  services
+
+let addToApp (app : IApplicationBuilder) : IApplicationBuilder =
+  // FSTODO do we need to do anything to use our custom provider with the default middleware?
+  // https://github.com/dotnet/aspnetcore/tree/c85baf8db0c72ae8e68643029d514b2e737c9fae/src/Middleware/ResponseCompression/src
+  app.UseResponseCompression()

fsharp-backend/src/BwdServer/Server.fs

@@ -19,6 +19,8 @@ open Microsoft.AspNetCore.Http.Abstractions
 open Microsoft.Extensions.Logging
 open Microsoft.Extensions.Hosting
 open Microsoft.Extensions.DependencyInjection
+open Microsoft.AspNetCore.ResponseCompression
+open Microsoft.Extensions.DependencyInjection.Extensions
 
 type StringValues = Microsoft.Extensions.Primitives.StringValues
 
@@ -470,13 +472,15 @@ let configureApp (healthCheckPort : int) (app : IApplicationBuilder) =
     (person, metadata)
 
   Rollbar.AspNet.addRollbarToApp app rollbarCtxToMetadata None
+  |> Compression.addToApp
   |> fun app -> app.UseRouting()
   // must go after UseRouting
   |> Kubernetes.configureApp healthCheckPort
   |> fun app -> app.Run(RequestDelegate handler)
 
 let configureServices (services : IServiceCollection) : unit =
   services
+  |> Compression.configureServices
   |> Kubernetes.configureServices [ LibBackend.Init.legacyServerCheck ]
   |> Rollbar.AspNet.addRollbarToServices
   |> Telemetry.AspNet.addTelemetryToServices "BwdServer" Telemetry.TraceDBQueries

fsharp-backend/tests/TestUtils/TestUtils.fs

@@ -5,6 +5,9 @@ open Expecto
 open System.Threading.Tasks
 open FSharp.Control.Tasks
 
+open System.IO
+open System.IO.Compression
+
 open Npgsql.FSharp
 open Npgsql
 open LibBackend.Db
@@ -1000,7 +1003,7 @@ let sampleDvals : List<string * Dval> =
 
 // Utilties shared among tests
 module Http =
-  type T = { status : string; headers : (string * string) list; body : byte array }
+  type T = { status : string; headers : List<string * string>; body : byte array }
 
   let setHeadersToCRLF (text : byte array) : byte array =
     // We keep our test files with an LF line ending, but the HTTP spec
@@ -1021,6 +1024,70 @@ module Http =
         [ b ])
     |> List.toArray
 
+  // Decompress
+  let decompressIfNeeded
+    (headers : List<string * string>)
+    (body : byte array)
+    : byte array =
+    let contentEncodingHeader =
+      headers
+      |> List.find (fun (k, v) -> String.toLowercase k = "content-encoding")
+      |> Option.map Tuple2.second
+      |> Option.map String.toLowercase
+
+    // If the transfer-encoding=chunked header is set, we need to process it before
+    // we have a gzip/brotli/etc output
+    let body =
+      // Only decode the transfer-encoding in order to decompress the stream. We have
+      // tests for the transfer-encoding format and we don't want to break them by
+      // transfer-encoding test bodies
+      if Option.isSome contentEncodingHeader then
+        let isTransferEncodingChunked =
+          headers
+          |> List.find (fun (k, v) ->
+            String.toLowercase k = "transfer-encoding"
+            && String.toLowercase v = "chunked")
+          |> Option.isSome
+        if isTransferEncodingChunked then
+          let decoder = new ChunkDecoder.Decoder()
+          let mutable (byteArray : byte array) = null
+          // asp.net doesn't add the final sequence required by
+          // `transfer-encoding:chunked`, relying instead on closing the connection
+          // to indicate that the data is complete. However, the ChunkDecoder library
+          // does not support this, and hangs while waiting on the final chunk. We
+          // add the final chunk ourselves to allow the library to finish its work.
+          let body =
+            match body with
+            | [||] -> body
+            | body ->
+              let bytesToAppend = UTF8.toBytes "0\r\n"
+              Array.append body bytesToAppend
+          let success = decoder.Decode(body, &byteArray)
+          if not success then Exception.raiseInternal "could not dechunk chunks" []
+          byteArray
+        else
+          body
+      else
+        body
+
+    match contentEncodingHeader with
+    | Some "gzip" ->
+      let inputStream = new MemoryStream(body)
+      use decompressionStream =
+        new GZipStream(inputStream, CompressionMode.Decompress)
+      use outputStream = new MemoryStream()
+      decompressionStream.CopyTo(outputStream)
+      outputStream.ToArray()
+    | Some "br" ->
+      let inputStream = new MemoryStream(body)
+      use decompressionStream =
+        new BrotliStream(inputStream, CompressionMode.Decompress)
+      use outputStream = new MemoryStream()
+      decompressionStream.CopyTo(outputStream)
+      outputStream.ToArray()
+    | Some ce -> Exception.raiseInternal $"unsupported content encoding {ce}" []
+    | None -> body
+
   let split (response : byte array) : T =
     // read a single line of bytes (a line ends with \r\n)
     let rec consume (existing : byte list) (l : byte list) : byte list * byte list =

fsharp-backend/tests/TestUtils/paket.references

@@ -1,3 +1,4 @@
 Expecto
 FSharp.Compiler.Service
 NReco.Logging.File
+ChunkDecoder

fsharp-backend/tests/Tests/BwdServer.Tests.fs

@@ -21,6 +21,7 @@ module RT = LibExecution.RuntimeTypes
 module PT = LibExecution.ProgramTypes
 module Routing = LibBackend.Routing
 module Canvas = LibBackend.Canvas
+module DvalRepr = LibExecution.DvalReprExternal
 
 open TestUtils.TestUtils
 open System.Text.Json
@@ -304,54 +305,47 @@ let createClient (port : int) : Task<TcpClient> =
     return client
   }
 
-/// Makes the test request to one of the servers,
-/// testing the response matches expectations
-let runTestRequest
+let prepareRequest
+  (request : byte array)
+  (host : string)
   (canvasName : string)
-  (testRequest : byte array)
-  (testResponse : byte array)
-  (server : Server)
-  : Task<unit> =
-  task {
-    let port =
-      match server with
-      | OCaml -> TestConfig.ocamlServerNginxPort
-      | FSharp -> TestConfig.bwdServerBackendPort
-
-    let host = $"{canvasName}.builtwithdark.localhost:{port}"
-
-    let request =
-      testRequest
-      |> replaceByteStrings "HOST" host
-      |> replaceByteStrings "CANVAS" canvasName
-      |> Http.setHeadersToCRLF
+  : byte array =
+  let request =
+    request
+    |> replaceByteStrings "HOST" host
+    |> replaceByteStrings "CANVAS" canvasName
+    |> Http.setHeadersToCRLF
+
+  // Check body matches content-length
+  let incorrectContentTypeAllowed =
+    request
+    |> UTF8.ofBytesWithReplacement
+    |> String.includes "ALLOW-INCORRECT-CONTENT-LENGTH"
+
+  if not incorrectContentTypeAllowed then
+    let parsedTestRequest = Http.split request
+    let contentLength =
+      parsedTestRequest.headers
+      |> List.find (fun (k, v) -> String.toLowercase k = "content-length")
+    match contentLength with
+    | None -> ()
+    | Some (_, v) ->
+      if String.includes "ALLOW-INCORRECT-CONTENT-LENGTH" v then
+        ()
+      else
+        Expect.equal parsedTestRequest.body.Length (int v) ""
 
-    // Check body matches content-length
-    let incorrectContentTypeAllowed =
-      testRequest
-      |> UTF8.ofBytesWithReplacement
-      |> String.includes "ALLOW-INCORRECT-CONTENT-LENGTH"
-
-    if not incorrectContentTypeAllowed then
-      let parsedTestRequest = Http.split request
-      let contentLength =
-        parsedTestRequest.headers
-        |> List.find (fun (k, v) -> String.toLowercase k = "content-length")
-      match contentLength with
-      | None -> ()
-      | Some (_, v) ->
-        if String.includes "ALLOW-INCORRECT-CONTENT-LENGTH" v then
-          ()
-        else
-          Expect.equal parsedTestRequest.body.Length (int v) ""
+  // Check input LENGTH not set
+  if request |> UTF8.ofBytesWithReplacement |> String.includes "LENGTH"
+     && not incorrectContentTypeAllowed then // false alarm as also have LENGTH in it
+    Expect.isFalse true "LENGTH substitution not done on request"
 
-    // Check input LENGTH not set
-    if testRequest |> UTF8.ofBytesWithReplacement |> String.includes "LENGTH"
-       && not incorrectContentTypeAllowed then // false alarm as also have LENGTH in it
-      Expect.isFalse true "LENGTH substitution not done on request"
+  request
 
+let makeRequest (request : byte array) (port : int) : Task<Http.T> =
+  task {
     // Make the request
-    use! client = createClient (port)
+    use! client = createClient port
     use stream = client.GetStream()
     stream.ReadTimeout <- 1000 // responses should be instant, right?
 
@@ -365,9 +359,32 @@ let runTestRequest
     stream.Close()
     client.Close()
     let response = Array.take byteCount responseBuffer
+    return Http.split response
+  }
+
+
+
+/// Makes the test request to one of the servers,
+/// testing the response matches expectations
+let runTestRequest
+  (canvasName : string)
+  (testRequest : byte array)
+  (testResponse : byte array)
+  (server : Server)
+  : Task<unit> =
+  task {
+    let port =
+      match server with
+      | OCaml -> TestConfig.ocamlServerNginxPort
+      | FSharp -> TestConfig.bwdServerBackendPort
+
+    let host = $"{canvasName}.builtwithdark.localhost:{port}"
+
+    let request = prepareRequest testRequest host canvasName
+    let! actual = makeRequest request port
 
     // Prepare expected response
-    let expectedResponse =
+    let expected =
       testResponse
       |> splitAtNewlines
       |> List.filterMap (fun line ->
@@ -396,27 +413,31 @@ let runTestRequest
       |> replaceByteStrings "HOST" host
       |> replaceByteStrings "CANVAS" canvasName
       |> Http.setHeadersToCRLF
+      |> Http.split
 
-    // Parse and normalize the response
-    let actual = Http.split response
-    let expected = Http.split expectedResponse
+    // Normalize the responses
     let expectedHeaders = normalizeExpectedHeaders expected.headers actual.body
     let actualHeaders = normalizeActualHeaders actual.headers
 
+    // Decompress the body if returned with a content-encoding. Throws an exception
+    // if content-encoding is set and the body is not compressed. This lets us test
+    // that the server returns compressed content
+    let actual =
+      { actual with body = Http.decompressIfNeeded actual.headers actual.body }
+
     // Test as json or strings
     let asJson =
       try
         Some(
-          LibExecution.DvalReprExternal.parseJson (UTF8.ofBytesUnsafe actual.body),
-          LibExecution.DvalReprExternal.parseJson (UTF8.ofBytesUnsafe expected.body)
+          DvalRepr.parseJson (UTF8.ofBytesUnsafe actual.body),
+          DvalRepr.parseJson (UTF8.ofBytesUnsafe expected.body)
         )
       with
       | e -> None
 
     match asJson with
     | Some (aJson, eJson) ->
-      let serialize (json : JsonDocument) =
-        LibExecution.DvalReprExternal.writePrettyJson json.WriteTo
+      let serialize (json : JsonDocument) = DvalRepr.writePrettyJson json.WriteTo
       Expect.equal
         (actual.status, actualHeaders, serialize aJson)
         (expected.status, expectedHeaders, serialize eJson)
@@ -457,6 +478,7 @@ let t (filename : string) =
 
     if shouldSkip then
       skiptest $"underscore test - {testName}"
+
     else
       do! callServer OCaml // check OCaml to see if we got the right answer
       do! callServer FSharp // test F# impl

fsharp-backend/tests/httptestfiles/request-header-accept-encoding-gzip.test

@@ -23,4 +23,5 @@ Connection: keep-alive // OCAMLONLY
 Strict-Transport-Security: max-age=31536000; includeSubDomains; preload // FSHARPONLY
 Content-Length: LENGTH
 
+
 "2019-09-07T22:44:25Z"