Giraffe Sample (#67)

* A sample Giraffe port (wip)

* add HTTP verbs and choose

* Add middleware handling

* Add routing functions

* Fix default handler

* Add readme

Author: dbrattli

.config/dotnet-tools.json

@@ -8,16 +8,16 @@
         "paket"
       ]
     },
-    "fantomas-tool": {
-      "version": "4.7.9",
+    "fable": {
+      "version": "4.0.0-snake-island-alpha-024",
       "commands": [
-        "fantomas"
+        "fable"
       ]
     },
-    "fable": {
-      "version": "4.0.0-snake-island-alpha-019",
+    "fantomas": {
+      "version": "5.0.0-beta-009",
       "commands": [
-        "fable"
+        "fantomas"
       ]
     }
   }

examples/giraffe/.gitignore

@@ -0,0 +1 @@
+*.py

examples/giraffe/Core.fs

@@ -0,0 +1,148 @@
+// Learn more about F# at http://docs.microsoft.com/dotnet/fsharp
+namespace Giraffe
+
+open System.Text
+open System.Threading.Tasks
+
+type HttpFuncResult = Task<HttpContext option>
+
+type HttpFunc = HttpContext -> HttpFuncResult
+
+type HttpHandler = HttpFunc -> HttpFunc
+
+
+[<AutoOpen>]
+module Core =
+    let earlyReturn: HttpFunc = Some >> Task.FromResult
+    let skipPipeline () : HttpFuncResult = Task.FromResult None
+
+    let compose (handler1: HttpHandler) (handler2: HttpHandler) : HttpHandler =
+        fun (final: HttpFunc) ->
+            let func = final |> handler2 |> handler1
+
+            fun (ctx: HttpContext) ->
+                match ctx.Response.HasStarted with
+                | true -> final ctx
+                | false -> func ctx
+
+    let (>=>) = compose
+
+    /// <summary>
+    /// The warbler function is a <see cref="HttpHandler"/> wrapper function which prevents a <see cref="HttpHandler"/> to be pre-evaluated at startup.
+    /// </summary>
+    /// <param name="f">A function which takes a HttpFunc * HttpContext tuple and returns a <see cref="HttpHandler"/> function.</param>
+    /// <param name="next"></param>
+    /// <param name="source"></param>
+    /// <example>
+    /// <code>
+    /// warbler(fun _ -> someHttpHandler)
+    /// </code>
+    /// </example>
+    /// <returns>Returns a <see cref="HttpHandler"/> function.</returns>
+    let inline warbler f (source: HttpHandler) (next: HttpFunc) =
+        fun (ctx: HttpContext) -> f (next, ctx) id next ctx
+        |> source
+
+    /// <summary>
+    /// Iterates through a list of `HttpFunc` functions and returns the result of the first `HttpFunc` of which the outcome is `Some HttpContext`.
+    /// </summary>
+    /// <param name="funcs"></param>
+    /// <param name="ctx"></param>
+    /// <returns>A <see cref="HttpFuncResult"/>.</returns>
+    let rec private chooseHttpFunc (funcs: HttpFunc list) : HttpFunc =
+        fun (ctx: HttpContext) ->
+            task {
+                match funcs with
+                | [] -> return None
+                | func :: tail ->
+                    let! result = func ctx
+
+                    match result with
+                    | Some c -> return Some c
+                    | None -> return! chooseHttpFunc tail ctx
+            }
+
+    /// <summary>
+    /// Iterates through a list of <see cref="HttpHandler"/> functions and returns the result of the first <see cref="HttpHandler"/> of which the outcome is Some HttpContext.
+    /// Please mind that all <see cref="HttpHandler"/> functions will get pre-evaluated at runtime by applying the next (HttpFunc) parameter to each handler.
+    /// </summary>
+    /// <param name="handlers"></param>
+    /// <param name="next"></param>
+    /// <returns>A <see cref="HttpFunc"/>.</returns>
+    let choose (handlers: HttpHandler list) : HttpHandler =
+        fun (next: HttpFunc) ->
+            let funcs = handlers |> List.map (fun h -> h next)
+            fun (ctx: HttpContext) -> chooseHttpFunc funcs ctx
+
+
+    let text (str: string) : HttpHandler =
+        let bytes = Encoding.UTF8.GetBytes str
+
+        fun (_: HttpFunc) (ctx: HttpContext) ->
+            ctx.SetContentType "text/plain; charset=utf-8"
+            ctx.WriteBytesAsync bytes
+
+
+    /// <summary>
+    /// Filters an incoming HTTP request based on the HTTP verb.
+    /// </summary>
+    /// <param name="validate">A validation function which checks for a single HTTP verb.</param>
+    /// <param name="next"></param>
+    /// <param name="ctx"></param>
+    /// <returns>A Giraffe <see cref="HttpHandler"/> function which can be composed into a bigger web application.</returns>
+    let private httpVerb (validate: string -> bool) : HttpHandler =
+        fun (next: HttpFunc) (ctx: HttpContext) ->
+            if validate ctx.Request.Method then
+                next ctx
+            else
+                skipPipeline ()
+
+    let GET: HttpHandler = httpVerb HttpMethods.IsGet
+    let POST: HttpHandler = httpVerb HttpMethods.IsPost
+    let PUT: HttpHandler = httpVerb HttpMethods.IsPut
+    let PATCH: HttpHandler = httpVerb HttpMethods.IsPatch
+    let DELETE: HttpHandler = httpVerb HttpMethods.IsDelete
+    let HEAD: HttpHandler = httpVerb HttpMethods.IsHead
+    let OPTIONS: HttpHandler = httpVerb HttpMethods.IsOptions
+    let TRACE: HttpHandler = httpVerb HttpMethods.IsTrace
+    let CONNECT: HttpHandler = httpVerb HttpMethods.IsConnect
+
+    let GET_HEAD: HttpHandler = choose [ GET; HEAD ]
+
+    /// <summary>
+    /// Sets the HTTP status code of the response.
+    /// </summary>
+    /// <param name="statusCode">The status code to be set in the response. For convenience you can use the static <see cref="Microsoft.AspNetCore.Http.StatusCodes"/> class for passing in named status codes instead of using pure int values.</param>
+    /// <param name="next"></param>
+    /// <param name="ctx"></param>
+    /// <returns>A Giraffe <see cref="HttpHandler"/> function which can be composed into a bigger web application.</returns>
+    let setStatusCode (statusCode: int) : HttpHandler =
+        fun (next: HttpFunc) (ctx: HttpContext) ->
+            ctx.SetStatusCode statusCode
+            next ctx
+
+
+    /// <summary>
+    /// Adds or sets a HTTP header in the response.
+    /// </summary>
+    /// <param name="key">The HTTP header name. For convenience you can use the static <see cref="Microsoft.Net.Http.Headers.HeaderNames"/> class for passing in strongly typed header names instead of using pure string values.</param>
+    /// <param name="value">The value to be set. Non string values will be converted to a string using the object's ToString() method.</param>
+    /// <param name="next"></param>
+    /// <param name="ctx"></param>
+    /// <returns>A Giraffe <see cref="HttpHandler"/> function which can be composed into a bigger web application.</returns>
+    let setHttpHeader (key: string) (value: obj) : HttpHandler =
+        fun (next: HttpFunc) (ctx: HttpContext) ->
+            ctx.SetHttpHeader(key, value)
+            next ctx
+
+    /// <summary>
+    /// Serializes an object to JSON and writes the output to the body of the HTTP response.
+    /// It also sets the HTTP Content-Type header to application/json and sets the Content-Length header accordingly.
+    /// The JSON serializer can be configured in the ASP.NET Core startup code by registering a custom class of type <see cref="Json.ISerializer"/>.
+    /// </summary>
+    /// <param name="dataObj">The object to be send back to the client.</param>
+    /// <param name="ctx"></param>
+    /// <typeparam name="'T"></typeparam>
+    /// <returns>A Giraffe <see cref="HttpHandler" /> function which can be composed into a bigger web application.</returns>
+    let json<'T> (dataObj: 'T) : HttpHandler =
+        fun (_: HttpFunc) (ctx: HttpContext) -> ctx.WriteJsonAsync dataObj

examples/giraffe/FormatExpressions.fs

@@ -0,0 +1,168 @@
+module Giraffe.Python.FormatExpressions
+
+open System
+open System.Text.RegularExpressions
+open Microsoft.FSharp.Reflection
+open FSharp.Core
+
+// ---------------------------
+// String matching functions
+// ---------------------------
+
+let private formatStringMap =
+    let decodeSlashes (str: string) =
+        // Kestrel has made the weird decision to
+        // partially decode a route argument, which
+        // means that a given route argument would get
+        // entirely URL decoded except for '%2F' (/).
+        // Hence decoding %2F must happen separately as
+        // part of the string parsing function.
+        //
+        // For more information please check:
+        // https://github.com/aspnet/Mvc/issues/4599
+        str.Replace("%2F", "/").Replace("%2f", "/")
+
+    let parseGuid (str: string) =
+        match str.Length with
+        | 22 -> ShortGuid.toGuid str
+        | _ -> Guid str
+
+    let guidPattern =
+        "([0-9A-Fa-f]{8}\-[0-9A-Fa-f]{4}\-[0-9A-Fa-f]{4}\-[0-9A-Fa-f]{4}\-[0-9A-Fa-f]{12}|[0-9A-Fa-f]{32}|[-_0-9A-Za-z]{22})"
+
+    let shortIdPattern = "([-_0-9A-Za-z]{10}[048AEIMQUYcgkosw])"
+
+    dict
+        [
+          // Char    Regex                    Parser
+          // -------------------------------------------------------------
+          'b', ("(?i:(true|false)){1}", (fun (s: string) -> bool.Parse s) >> box) // bool
+          'c', ("([^/]{1})", char >> box) // char
+          's', ("([^/]+)", decodeSlashes >> box) // string
+          'i', ("(-?\d+)", int32 >> box) // int
+          'd', ("(-?\d+)", int64 >> box) // int64
+          'f', ("(-?\d+\.{1}\d+)", float >> box) // float
+          'O', (guidPattern, parseGuid >> box) // Guid
+          'u', (shortIdPattern, ShortId.toUInt64 >> box) ] // uint64
+
+type MatchMode =
+    | Exact // Will try to match entire string from start to end.
+    | StartsWith // Will try to match a substring. Subject string should start with test case.
+    | EndsWith // Will try to match a substring. Subject string should end with test case.
+    | Contains // Will try to match a substring. Subject string should contain test case.
+
+type MatchOptions =
+    { IgnoreCase: bool
+      MatchMode: MatchMode }
+
+    static member Exact =
+        { IgnoreCase = false
+          MatchMode = Exact }
+
+    static member IgnoreCaseExact = { IgnoreCase = true; MatchMode = Exact }
+
+let private convertToRegexPatternAndFormatChars (mode: MatchMode) (formatString: string) =
+    let rec convert (chars: char list) =
+        match chars with
+        | '%' :: '%' :: tail ->
+            let pattern, formatChars = convert tail
+            "%" + pattern, formatChars
+        | '%' :: c :: tail ->
+            let pattern, formatChars = convert tail
+            let regex, _ = formatStringMap.[c]
+            regex + pattern, c :: formatChars
+        | c :: tail ->
+            let pattern, formatChars = convert tail
+            c.ToString() + pattern, formatChars
+        | [] -> "", []
+
+    let inline formatRegex mode pattern =
+        match mode with
+        | Exact -> "^" + pattern + "$"
+        | StartsWith -> "^" + pattern
+        | EndsWith -> pattern + "$"
+        | Contains -> pattern
+
+    formatString
+    |> List.ofSeq
+    |> convert
+    |> (fun (pattern, formatChars) -> formatRegex mode pattern, formatChars)
+
+/// <summary>
+/// Tries to parse an input string based on a given format string and return a tuple of all parsed arguments.
+/// </summary>
+/// <param name="format">The format string which shall be used for parsing.</param>
+/// <param name="options">The options record with specifications on how the matching should behave.</param>
+/// <param name="input">The input string from which the parsed arguments shall be extracted.</param>
+/// <returns>Matched value as an option of 'T</returns>
+let tryMatchInput (format: PrintfFormat<_, _, _, _, 'T>) (options: MatchOptions) (input: string) =
+    try
+        let pattern, formatChars =
+            format.Value
+            |> Regex.Escape
+            |> convertToRegexPatternAndFormatChars options.MatchMode
+
+        let options =
+            match options.IgnoreCase with
+            | true -> RegexOptions.IgnoreCase
+            | false -> RegexOptions.None
+
+        let result = Regex.Match(input, pattern, options)
+
+        if result.Groups.Count <= 1 then
+            None
+        else
+            let groups = result.Groups |> Seq.cast<Group> |> Seq.skip 1
+
+            let values =
+                (groups, formatChars)
+                ||> Seq.map2 (fun g c ->
+                    let _, parser = formatStringMap.[c]
+                    let value = parser g.Value
+                    value)
+                |> Seq.toArray
+
+            let result =
+                match values.Length with
+                | 1 -> values.[0]
+                | _ ->
+                    let types = values |> Array.map (fun v -> v.GetType())
+                    let tupleType = FSharpType.MakeTupleType types
+                    FSharpValue.MakeTuple(values, tupleType)
+
+            result :?> 'T |> Some
+    with _ ->
+        None
+
+/// <summary>
+/// Tries to parse an input string based on a given format string and return a tuple of all parsed arguments.
+/// </summary>
+/// <param name="format">The format string which shall be used for parsing.</param>
+/// <param name="ignoreCase">The flag to make matching case insensitive.</param>
+/// <param name="input">The input string from which the parsed arguments shall be extracted.</param>
+/// <returns>Matched value as an option of 'T</returns>
+let tryMatchInputExact (format: PrintfFormat<_, _, _, _, 'T>) (ignoreCase: bool) (input: string) =
+    let options =
+        match ignoreCase with
+        | true -> MatchOptions.IgnoreCaseExact
+        | false -> MatchOptions.Exact
+
+    tryMatchInput format options input
+
+
+// ---------------------------
+// Validation helper functions
+// ---------------------------
+
+/// **Description**
+///
+/// Validates if a given format string can be matched with a given tuple.
+///
+/// **Parameters**
+///
+/// `format`: The format string which shall be used for parsing.
+///
+/// **Output**
+///
+/// Returns `unit` if validation was successful otherwise will throw an `Exception`.
+/// Returns `unit` if validation was successful otherwise will throw an `Exception`.

examples/giraffe/Giraffe.Python.fsproj

@@ -0,0 +1,23 @@
+<?xml version="1.0" encoding="utf-8"?>
+<Project Sdk="Microsoft.NET.Sdk">
+  <PropertyGroup>
+    <OutputType>Exe</OutputType>
+    <TargetFramework>net6.0</TargetFramework>
+    <WarnOn>3390;$(WarnOn)</WarnOn>
+  </PropertyGroup>
+  <ItemGroup>
+    <Compile Include="Helpers.fs" />
+    <Compile Include="ShortGuid.fs" />
+    <Compile Include="FormatExpressions.fs" />
+    <Compile Include="HttpContext.fs" />
+    <Compile Include="Core.fs" />
+    <Compile Include="Routing.fs" />
+    <Compile Include="HttpHandler.fs" />
+    <Compile Include="Middleware.fs" />
+    <Compile Include="Program.fs" />
+  </ItemGroup>
+  <ItemGroup>
+    <PackageReference Include="Fable.Python" Version="0.17.0" />
+    <PackageReference Include="Fable.Core" Version="4.0.0-snake-island-alpha-007" />
+  </ItemGroup>
+</Project>