Skip to content

Commit

Permalink
Fsharp giraffe fortunes (#3863)
Browse files Browse the repository at this point in the history
  • Loading branch information
dv00d00 authored and msmith-techempower committed Jun 19, 2018
1 parent a3328f6 commit 047245a
Show file tree
Hide file tree
Showing 13 changed files with 465 additions and 58 deletions.
11 changes: 8 additions & 3 deletions frameworks/FSharp/giraffe/README.md
Original file line number Diff line number Diff line change
Expand Up @@ -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.
37 changes: 29 additions & 8 deletions frameworks/FSharp/giraffe/benchmark_config.json
Original file line number Diff line number Diff line change
Expand Up @@ -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"
}
Expand All @@ -27,7 +28,7 @@
"json_url": "/json",
"port": 8080,
"approach": "Realistic",
"classification": "fullstack",
"classification": "Micro",
"database": "None",
"framework": "giraffe",
"language": "F#",
Expand All @@ -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#",
Expand All @@ -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"
}
Expand Down
12 changes: 12 additions & 0 deletions frameworks/FSharp/giraffe/giraffe-utf8direct.dockerfile
Original file line number Diff line number Diff line change
@@ -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"]
11 changes: 9 additions & 2 deletions frameworks/FSharp/giraffe/src/App/App.fsproj
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
<Project Sdk="Microsoft.NET.Sdk.Web">
<Project Sdk="Microsoft.NET.Sdk.Web">

<PropertyGroup>
<TargetFramework>netcoreapp2.1</TargetFramework>
Expand All @@ -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>
114 changes: 114 additions & 0 deletions frameworks/FSharp/giraffe/src/App/Custom.fs
Original file line number Diff line number Diff line change
@@ -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'
]

33 changes: 33 additions & 0 deletions frameworks/FSharp/giraffe/src/App/HtmlViews.fs
Original file line number Diff line number Diff line change
@@ -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
21 changes: 21 additions & 0 deletions frameworks/FSharp/giraffe/src/App/Models.fs
Original file line number Diff line number Diff line change
@@ -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)
}
56 changes: 11 additions & 45 deletions frameworks/FSharp/giraffe/src/App/Program.fs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Loading

0 comments on commit 047245a

Please sign in to comment.