Fsharp giraffe fortunes (#3863)

frameworks/FSharp/giraffe/README.md

@@ -22,6 +22,11 @@ This includes tests for plaintext and json serialization.
 
 ## Paths & Source for Tests
 
-* [Plaintext](src/App/Programs.fs): "/plaintext"
-* [JSON serialization](src/App/Programs.fs): "/json"
-* [JSON serialization via utf8json lib](src/App/Programs.fs): "/jsonutf8"
+* [Plaintext](src/App/Stock.fs): "/plaintext"
+* [Plaintext handwritten](src/App/Custom.fs): "/plaintext"
+* [JSON serialization](src/App/Stock.fs): "/json"
+* [JSON serialization via utf8json lib](src/App/Custom.fs): "/json"
+* [Fortunes using Dapper](src/App/Stock.fs): "/fortunes"
+* [Fortunes using Dapper and Custom renderer](src/App/Custom.fs): "/fortunes"
+
+App listents for command line arguments to pick specific implementation. If "stock" passed as command line argument it will use out of the box handlers, otherwise will use custom ones.

frameworks/FSharp/giraffe/benchmark_config.json

@@ -5,19 +5,20 @@
       "default": {
         "plaintext_url": "/plaintext",
         "json_url": "/json",
+        "fortune_url": "/fortunes",
         "port": 8080,
         "approach": "Realistic",
         "classification": "fullstack",
-        "database": "None",
+        "database": "Postgres",
         "framework": "giraffe",
         "language": "F#",
-        "orm": "Raw",
+        "orm": "micro",
         "platform": ".NET",
         "flavor": "CoreCLR",
         "webserver": "Kestrel",
         "os": "Linux",
         "database_os": "Linux",
-        "display_name": "Giraffe",
+        "display_name": "Giraffe, Dapper",
         "notes": "",
         "versus": "aspcore"
       }
@@ -27,7 +28,7 @@
         "json_url": "/json",
         "port": 8080,
         "approach": "Realistic",
-        "classification": "fullstack",
+        "classification": "Micro",
         "database": "None",
         "framework": "giraffe",
         "language": "F#",
@@ -37,17 +38,17 @@
         "webserver": "Kestrel",
         "os": "Linux",
         "database_os": "Linux",
-        "display_name": "Giraffe",
+        "display_name": "Giraffe, utf8json",
         "notes": "",
         "versus": "aspcore"
       }
     },
     {
-      "utf8plaintext": {
+      "utf8direct":{
         "plaintext_url": "/plaintext",
         "port": 8080,
         "approach": "Realistic",
-        "classification": "fullstack",
+        "classification": "Micro",
         "database": "None",
         "framework": "giraffe",
         "language": "F#",
@@ -57,7 +58,27 @@
         "webserver": "Kestrel",
         "os": "Linux",
         "database_os": "Linux",
-        "display_name": "Giraffe",
+        "display_name": "Giraffe, Direct utf8",
+        "notes": "",
+        "versus": "aspcore"
+      }
+    },
+    {
+      "stripped": {
+        "fortune_url": "/fortunes",
+        "port": 8080,
+        "approach": "Stripped",
+        "classification": "Micro",
+        "database": "Postgres",
+        "framework": "giraffe",
+        "language": "F#",
+        "orm": "micro",
+        "platform": ".NET",
+        "flavor": "CoreCLR",
+        "webserver": "Kestrel",
+        "os": "Linux",
+        "database_os": "Linux",
+        "display_name": "Giraffe, Custom Rendering, Dapper",
         "notes": "",
         "versus": "aspcore"
       }

frameworks/FSharp/giraffe/giraffe-utf8direct.dockerfile

@@ -0,0 +1,12 @@
+FROM microsoft/dotnet:2.1-sdk-stretch AS build
+WORKDIR /app
+COPY src/App .
+RUN dotnet publish -c Release -o out
+
+FROM microsoft/dotnet:2.1-aspnetcore-runtime AS runtime
+ENV ASPNETCORE_URLS http://+:8080
+ENV COMPlus_ReadyToRun 0
+WORKDIR /app
+COPY --from=build /app/out ./
+
+ENTRYPOINT ["dotnet", "App.dll"]

frameworks/FSharp/giraffe/src/App/App.fsproj

@@ -1,4 +1,4 @@
-<Project Sdk="Microsoft.NET.Sdk.Web">
+<Project Sdk="Microsoft.NET.Sdk.Web">
 
   <PropertyGroup>
     <TargetFramework>netcoreapp2.1</TargetFramework>
@@ -9,14 +9,21 @@
   </PropertyGroup>
 
   <ItemGroup>
+    <PackageReference Include="Dapper" Version="1.50.5" />
     <PackageReference Include="Microsoft.AspNetCore.Hosting" Version="2.1.0" />
     <PackageReference Include="Microsoft.AspNetCore.Server.Kestrel" Version="2.1.0" />
     <PackageReference Include="Microsoft.Extensions.DependencyInjection" Version="2.1.0" />
     <PackageReference Include="Giraffe" Version="1.1.0" />
+    <PackageReference Include="Npgsql" Version="4.0.0" />
     <PackageReference Include="Utf8Json" Version="1.3.7" />
   </ItemGroup>
 
   <ItemGroup>
+    <Compile Include="Models.fs" />
+    <Compile Include="HtmlViews.fs" />
+    <Compile Include="StatefullRendering.fs" />
+    <Compile Include="Custom.fs" />
+    <Compile Include="Stock.fs" />
     <Compile Include="Program.fs" />
   </ItemGroup>
 
@@ -24,4 +31,4 @@
     <PackageReference Update="FSharp.Core" Version="4.5.0" />
   </ItemGroup>
 
-</Project>
+</Project> 

frameworks/FSharp/giraffe/src/App/Custom.fs

@@ -0,0 +1,114 @@
+module Custom
+
+open App
+open Dapper
+open Giraffe
+open System
+open Models
+open Npgsql
+open FSharp.Control.Tasks
+open System.IO
+
+let private DefaultCapacity = 1386
+let private MaxBuilderSize = DefaultCapacity * 3
+
+type MemoryStreamCache = 
+    
+    [<ThreadStatic>]
+    [<DefaultValue>]
+    static val mutable private instance: MemoryStream
+
+    static member Get() = MemoryStreamCache.Get(DefaultCapacity)
+    static member Get(capacity:int) = 
+        
+        if capacity <= MaxBuilderSize then
+            let ms = MemoryStreamCache.instance;
+            let capacity = max capacity DefaultCapacity
+            
+            if ms <> null && capacity <= ms.Capacity then
+                MemoryStreamCache.instance <- null;
+                ms.SetLength 0L
+                ms
+            else
+                new MemoryStream(capacity)
+        else
+            new MemoryStream(capacity)
+
+    static member Release(ms:MemoryStream) = 
+        if ms.Capacity <= MaxBuilderSize then
+            MemoryStreamCache.instance <- ms
+
+let application : HttpHandler = 
+
+    let inline contentLength x = new Nullable<int64> ( int64 x )
+
+    let json' data : HttpHandler =
+        let bytes = Utf8Json.JsonSerializer.Serialize(data)
+        fun _ ctx -> 
+            ctx.Response.ContentLength <- contentLength bytes.Length
+            ctx.Response.ContentType <- "application/json"
+            ctx.Response.StatusCode <- 200
+            task {
+                do! ctx.Response.Body.WriteAsync(bytes, 0, bytes.Length)
+                return Some ctx
+            }
+
+    let text' (msg:string): HttpHandler = 
+        let bytes = System.Text.Encoding.UTF8.GetBytes(msg)
+        fun _ ctx ->
+            ctx.Response.ContentLength <- contentLength bytes.Length
+            ctx.Response.ContentType <- "text/plain"
+            ctx.Response.StatusCode <- 200
+            task {
+                do! ctx.Response.Body.WriteAsync(bytes, 0, bytes.Length)
+                return Some ctx
+            }
+  
+    let fortunes' : HttpHandler = 
+        let extra = { id = 0; message = "Additional fortune added at request time." }
+        fun _ ctx ->
+            let conn = new NpgsqlConnection(ConnectionString)
+            ctx.Response.RegisterForDispose conn
+            task {
+                let! data = conn.QueryAsync<Fortune>("SELECT id, message FROM fortune")
+
+                let fortunes = 
+                    let xs = data.AsList()
+                    xs.Add extra
+                    xs.Sort FortuneComparer
+                    xs
+
+                let html = MemoryStreamCache.Get()
+                let view = fortunes |> HtmlViews.fortunes 
+                StetefullRendering.renderHtmlToStream html view
+
+                ctx.Response.ContentType <- "text/html;charset=utf-8"
+                ctx.Response.ContentLength <- contentLength html.Length
+                ctx.Response.StatusCode <- 200
+                do! html.CopyToAsync ctx.Response.Body
+
+                MemoryStreamCache.Release html
+                return Some ctx
+            }
+
+    let routes' (routes: (string * HttpHandler) list) : HttpHandler = 
+        let table = Map.ofList routes
+        let notFound = setStatusCode 404
+
+        let go key = 
+            if table |> Map.containsKey key then
+                table.[key]
+            else
+                notFound
+
+        fun next ctx ->
+            let path = ctx.Request.Path.Value
+            let handler = go path
+            handler next ctx
+
+    routes' [
+        "/plaintext", text' "Hello, World!"
+        "/json", json' { JsonStructMessage.message = "Hello, World!" }
+        "/fortunes", fortunes'
+    ]
+

frameworks/FSharp/giraffe/src/App/HtmlViews.fs

@@ -0,0 +1,33 @@
+module HtmlViews
+
+open Giraffe.GiraffeViewEngine
+open Models
+
+let private fortunesHead = 
+    head [] [
+        title []  [ rawText "Fortunes" ]
+    ]
+
+let private layout (content: XmlNode list) =
+    html [] [
+        fortunesHead
+        body [] content
+    ]
+
+let private fortunesTableHeader = 
+    tr [] [
+        th [] [ rawText "id" ]
+        th [] [ rawText "message" ]
+    ]
+
+let fortunes (fortunes: Fortune seq) =
+    [
+        table [] [ 
+            yield fortunesTableHeader
+            for f in fortunes ->
+                tr [] [
+                    td [] [ rawText <| string f.id ]
+                    td [] [ encodedText <| f.message ]
+                ] 
+        ]
+    ] |> layout

frameworks/FSharp/giraffe/src/App/Models.fs

@@ -0,0 +1,21 @@
+module Models
+
+open System.Collections.Generic
+open System
+
+type JsonMessage = { message : string }
+
+[<Struct>]
+type JsonStructMessage = { message : string }
+
+ [<CLIMutable>]
+type Fortune = { id: int; message: string }
+
+[<Literal>]
+let ConnectionString = "Server=tfb-database;Database=hello_world;User Id=benchmarkdbuser;Password=benchmarkdbpass;Maximum Pool Size=1024;NoResetOnClose=true;Enlist=false;Max Auto Prepare=3"
+
+type Implementation = Stock | Custom
+
+let FortuneComparer = { new IComparer<Fortune> with 
+    member self.Compare(a,b) = String.CompareOrdinal(a.message, b.message)
+}

frameworks/FSharp/giraffe/src/App/Program.fs

@@ -2,61 +2,27 @@ module App.App
 
 open Microsoft.AspNetCore.Hosting
 open Giraffe
-
-[<CLIMutable>] 
-type JsonMessage = { message : string }
-
-[<CLIMutable>][<Struct>] 
-type JsonStructMessage = { message : string }
-
-type Implementation = Stock | Custom
-
-module Routes =
-
-    let stock : HttpHandler list = 
-        [ route "/plaintext" >=> text "Hello, World!"
-          route "/json" >=> json { JsonMessage.message = "Hello, World!" } ]
-
-    let custom : HttpHandler list = 
-        let inline contentLength (x:int32) = new System.Nullable<int64>( int64 x )
-
-        let json data : HttpHandler =
-            let bytes = Utf8Json.JsonSerializer.Serialize(data)
-            fun _ ctx ->
-                ctx.Response.ContentLength <- contentLength ( bytes.Length )
-                ctx.Response.ContentType <- "application/json"
-                ctx.Response.StatusCode <- 200
-                ctx.WriteBytesAsync bytes
-
-        let bytes = System.Text.Encoding.UTF8.GetBytes "Hello, World!"
-        let text : HttpHandler = 
-            fun _ ctx ->
-                ctx.Response.ContentLength <- contentLength ( bytes.Length )
-                ctx.Response.ContentType <- "text/plain"
-                ctx.Response.StatusCode <- 200
-                ctx.WriteBytesAsync bytes
-    
-        [ route "/plaintext" >=> text
-          route "/json" >=> json { JsonStructMessage.message = "Hello, World!" } ]
-
-let webApp implementation = 
-    match implementation with
-    | Stock -> GET >=> choose Routes.stock
-    | Custom -> GET >=> choose Routes.custom
+open Models
 
 [<EntryPoint>]
 let main args = 
     let implementation = 
         match args with
-        | [| "stock" |]  -> Stock
-        | _ -> Custom
+        | [| "stock" |] -> Implementation.Stock
+        | _ -> Implementation.Custom
 
     printfn "Running with %A implementation" implementation
 
+    let webApp = function
+    | Implementation.Custom -> Custom.application
+    | Implementation.Stock -> Stock.application
+
+    let app = webApp implementation
+
     WebHostBuilder()
         .UseKestrel()
-        .Configure(fun app -> app.UseGiraffe (webApp implementation))
-        .ConfigureServices(fun services -> services.AddGiraffe() |> ignore)
+        .Configure(fun b -> b.UseGiraffe app)
+        .ConfigureServices(fun s -> s.AddGiraffe() |> ignore)
         .Build()
         .Run()
     0

frameworks/FSharp/giraffe/src/App/StatefullRendering.fs

@@ -0,0 +1,79 @@
+namespace App
+open System.Text
+open Giraffe.GiraffeViewEngine
+open System.Net
+open System.IO
+
+module rec StetefullRendering =
+
+    let private UTF8WithoutBOM = new UTF8Encoding(false)
+
+    let inline private add (str:string) (target: StreamWriter) =
+        target.Write str
+        target
+
+    let inline private add' (str:string) (target: StreamWriter) =
+        target.Write str
+    
+    let private closingBracket = ">"
+
+    let private writeStartElement target elemName (attributes : XmlAttribute array) : unit =
+
+        match attributes with
+        | [||] -> 
+            target
+            |> add "<"
+            |> add elemName
+            |> add' closingBracket
+
+        | _  ->
+            target 
+            |> add "<" 
+            |> add' elemName
+
+            for attr in attributes do
+                match attr with
+                | KeyValue (k, v) -> 
+                    target 
+                    |> add " " 
+                    |> add k 
+                    |> add "=\"" 
+                    |> add' (WebUtility.HtmlEncode v)
+
+                | Boolean k -> 
+                    target 
+                    |> add " " 
+                    |> add' k
+
+            target 
+            |> add' closingBracket
+
+    let private writeEndElement target elemName = 
+        target 
+        |> add "</" 
+        |> add elemName 
+        |> add' ">"
+
+    let private writeParentNode target ((name, attrs) : XmlElement) (nodes : XmlNode list) =
+        writeStartElement target name attrs 
+        nodes |> List.iter (writeHtmlNode target)
+        name  |> writeEndElement target
+
+    let rec private writeHtmlNode (target: StreamWriter) (node : XmlNode)  =
+        match node with
+        | EncodedText text -> target |> add' (WebUtility.HtmlEncode text)
+        | RawText text -> target |> add' text
+        | ParentNode (e, nodes) -> writeParentNode target e nodes
+        | VoidElement (n, attrs) -> writeStartElement target n attrs
+    
+    let renderHtmlToStream (ms:MemoryStream) node = 
+        let sb = new StreamWriter(ms, UTF8WithoutBOM)
+        sb.WriteLine "<!DOCTYPE html>"
+        writeHtmlNode sb node
+        sb.Flush()
+        ms.Seek(0L, SeekOrigin.Begin) |> ignore
+
+    let renderHtml node =
+        let ms = new MemoryStream()
+        renderHtmlToStream ms node
+        ms

frameworks/FSharp/giraffe/src/App/Stock.fs

@@ -0,0 +1,39 @@
+module Stock
+
+open Giraffe
+open Dapper
+open Npgsql
+open Models
+open FSharp.Control.Tasks
+open System.Text
+
+let application : HttpHandler = 
+    
+    let fortunes : HttpHandler = 
+        let extra = {id = 0; message = "Additional fortune added at request time."}
+
+        fun _ ctx ->
+            task {
+                use conn = new NpgsqlConnection(ConnectionString)
+                let! data = conn.QueryAsync<Fortune>("SELECT id, message FROM fortune")
+
+                let view =
+                    let xs = data.AsList()
+                    xs.Add extra
+                    xs.Sort FortuneComparer
+                    HtmlViews.fortunes xs
+
+                let bytes = 
+                    view 
+                    |> GiraffeViewEngine.renderHtmlDocument 
+                    |> Encoding.UTF8.GetBytes
+
+                ctx.SetContentType "text/html;charset=utf-8"
+                return! ctx.WriteBytesAsync bytes
+            }
+
+    choose [
+        route "/plaintext" >=> text "Hello, World!" 
+        route "/json" >=> json { JsonMessage.message = "Hello, World!" }
+        route "/fortunes" >=> fortunes
+    ]

frameworks/FSharp/giraffe/src/Tests/BenchmarkTests.fsproj

@@ -0,0 +1,21 @@
+<Project Sdk="Microsoft.NET.Sdk">
+
+  <PropertyGroup>
+    <TargetFramework>netcoreapp2.1</TargetFramework>
+    <OutputType>Exe</OutputType>
+    <AssemblyName>BenchmarkTests</AssemblyName>
+  </PropertyGroup>
+
+  <ItemGroup>
+    <Compile Include="Program.fs" />
+  </ItemGroup>
+
+  <ItemGroup>
+    <PackageReference Include="BenchmarkDotNet" Version="0.10.14" />
+    <PackageReference Include="Microsoft.IO.RecyclableMemoryStream" Version="1.2.2" />
+    <ProjectReference Include="..\App\App.fsproj" />
+    <PackageReference Include="Giraffe" Version="1.1.0" /> 
+    <PackageReference Update="FSharp.Core" Version="4.5.0" />
+  </ItemGroup>
+
+</Project>

frameworks/FSharp/giraffe/src/Tests/Program.fs

@@ -0,0 +1,89 @@
+module Program
+
+open App
+open BenchmarkDotNet.Attributes
+open BenchmarkDotNet.Running
+open BenchmarkDotNet.Configs
+open BenchmarkDotNet.Jobs
+open BenchmarkDotNet.Diagnosers
+open System.Text
+open System.IO
+open Microsoft.IO
+open System
+open Custom
+
+type FastAndDirty() as self =
+    inherit ManualConfig()
+    do 
+        let job = new Job("", RunMode.Short, InfrastructureMode.InProcess)
+        self.Add(job)
+        self.Add(DefaultConfig.Instance.GetLoggers() |> Array.ofSeq)
+        self.Add(DefaultConfig.Instance.GetColumnProviders() |> Array.ofSeq)
+        self.Add(DefaultConfig.Instance.GetAnalysers() |> Array.ofSeq)
+        self.Add(DefaultConfig.Instance.GetDiagnosers() |> Array.ofSeq)
+        self.Add([|MemoryDiagnoser() :> IDiagnoser|])
+
+let node () = HtmlViews.fortunes (
+    [
+        { id = 1; message = "Hello world! Hello world! Hello world!" }
+        { id = 1; message = "Привет мир! Привет мир! Привет мир!" }
+        { id = 1; message = "Hello world! Hello world! Hello world!" }
+        { id = 1; message = "Привет мир! Привет мир! Привет мир!" }
+        { id = 1; message = "Hello world! Hello world! Hello world!" }
+        { id = 1; message = """<script>alert("This should not be displayed in a browser alert box.");</script>""" }
+        { id = 1; message = "Hello world! Hello world! Hello world!" }
+        { id = 1; message = "Привет мир! Привет мир! Привет мир!" }
+        { id = 1; message = "Hello world! Hello world! Hello world!" }
+        { id = 1; message = "Привет мир! Привет мир! Привет мир!" }
+        { id = 1; message = "Hello world! Hello world! Hello world!" }
+        { id = 1; message = """<script>alert("This should not be displayed in a browser alert box.");</script>""" }
+        { id = 1; message = "Hello world! Hello world! Hello world!" }
+        { id = 1; message = "Привет мир! Привет мир! Привет мир!" }
+        { id = 1; message = "Hello world! Hello world! Hello world!" }
+        { id = 1; message = "Привет мир! Привет мир! Привет мир!" }
+        { id = 1; message = "Hello world! Hello world! Hello world!" }
+        { id = 1; message = """<script>alert("This should not be displayed in a browser alert box.");</script>""" }
+    ]) 
+
+let node' = node()
+
+type MemoryPoolBench () =
+    let pool = new RecyclableMemoryStreamManager();    
+
+    [<Benchmark(Baseline = true)>]
+    member self.NewMemoryStream () = 
+        let start = new MemoryStream()
+        let stream = StetefullRendering.renderHtmlToStream start node'
+        ()
+
+    [<Benchmark>]
+    member self.CustomPool() = 
+        let stream = MemoryStreamCache.Get()
+        StetefullRendering.renderHtmlToStream stream node'
+        MemoryStreamCache.Release stream
+        ()
+
+    [<Benchmark>]
+    member self.MSPool () = 
+        use start = pool.GetStream()
+        let stream = StetefullRendering.renderHtmlToStream start node'
+        ()
+
+type HtmlBench () =
+
+    [<Benchmark(Baseline = true)>]
+    member self.Standard () = 
+        let bytes = Giraffe.GiraffeViewEngine.renderHtmlDocument (node()) |> Encoding.UTF8.GetBytes
+        ()
+
+    [<Benchmark>]
+    member self.Custom () = 
+        let stream = MemoryStreamCache.Get()
+        StetefullRendering.renderHtmlToStream stream (node())
+        MemoryStreamCache.Release stream
+        ()
+
+[<EntryPoint>]
+let Main args =
+    let _ = BenchmarkRunner.Run<HtmlBench>(FastAndDirty())
+    0