Fsharp giraffe fortunes

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,27 +38,28 @@
  "webserver": "Kestrel",
  "os": "Linux",
  "database_os": "Linux",
- "display_name": "Giraffe",
+ "display_name": "Giraffe, utf8json",
  "notes": "",
  "versus": "aspcore"
  }
  },
  {
- "utf8plaintext": {
+ "stripped": {
+ "fortune_url": "/fortunes",
  "plaintext_url": "/plaintext",
  "port": 8080,
- "approach": "Realistic",
- "classification": "fullstack",
- "database": "None",
+ "approach": "Stripped",
+ "classification": "Micro",
+ "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, Custom Rendering, Dapper",
  "notes": "",
  "versus": "aspcore"
  }

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,19 +9,26 @@
  </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>
 
  <ItemGroup>
  <PackageReference Update="FSharp.Core" Version="4.5.0" />
  </ItemGroup>
 
-</Project>
+</Project> 

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

@@ -0,0 +1,82 @@
+module Custom
+
+open App
+open Dapper
+open Giraffe
+open System
+open Models
+open Npgsql
+open FSharp.Control.Tasks
+
+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 = fortunes |> HtmlViews.fortunes |> StetefullRendering.renderHtml
+
+ ctx.Response.ContentType <- "text/html;charset=utf-8"
+ ctx.Response.ContentLength <- contentLength html.Length
+ ctx.Response.StatusCode <- 200
+ do! html.CopyToAsync ctx.Response.Body
+ 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