Add helpers for hosting static files

src/Saturn/Application.fs

@@ -87,6 +87,14 @@ module Application =
           AppConfigs = (fun (app : IApplicationBuilder)-> app.UseSession())::state.AppConfigs
       }
 
+    [<CustomOperation("use_static")>]
+    member __.UseStatic(state, path : string) =
+      {state with Pipelines = (Static.call path Static.defaultConfig)::state.Pipelines}
+
+    [<CustomOperation("use_static_config")>]
+    member __.UseStaticConfig(state, config : Static.StaticConfig, path : string ) =
+      {state with Pipelines = (Static.call path config)::state.Pipelines}
+
   let application = ApplicationBuilder()
 
   let run (app: IWebHost) = app.Run()

src/Saturn/Common.fs

@@ -1,12 +1,29 @@
 namespace Saturn
 
+open Microsoft.AspNetCore.Http
+open Microsoft.Extensions.Primitives
+
 [<AutoOpen>]
 module Common =
+  open Giraffe
 
   [<RequireQualifiedAccess>]
   type InclusiveOption<'T> =
   | None
   | Some of 'T
   | All
 
-  let inline internal succeed nxt cntx  = nxt cntx
+  let inline internal succeed nxt cntx  = nxt cntx
+
+  let inline internal halt _ ctx = task {return Some ctx }
+
+  let internal get<'a> v (ctx : HttpContext) =
+    match ctx.Items.TryGetValue v with
+    | true, l -> unbox<'a> l |> Some
+    | _ -> None
+
+  let internal setHttpHeaders (vals: (string * string) list ) : HttpHandler =
+    fun (next : HttpFunc) (ctx : HttpContext) ->
+        vals |> List.iter (fun (key, value) ->
+          ctx.Response.Headers.[key] <- StringValues(value))
+        next ctx

src/Saturn/Context.fs

@@ -3,6 +3,7 @@ namespace Saturn
 open Microsoft.AspNetCore.Http
 open Giraffe.HttpContextExtensions
 open Giraffe.Tasks
+open Giraffe.HttpHandlers
 module Context =
 
   [<RequireQualifiedAccess>]
@@ -94,7 +95,8 @@ module Context =
       | true, o -> Some (unbox<string> o)
       | _ -> None
 
-    //TODO: Add send download helpers - https://github.com/phoenixframework/phoenix/blob/v1.3.0/lib/phoenix/controller.ex#L851
-    let sendDownload (ctx: HttpContext) (path: string) = ()
+    let sendDownload (ctx: HttpContext) (path: string) =
+      Static.sendFile path (fun c -> task {return Some c}) ctx
 
-    let sendDownloadBinary (ctx: HttpContext) (content: byte []) = ()
+    let sendDownloadBinary (ctx: HttpContext) (content: byte []) =
+      setBody content (fun c -> task {return Some c}) ctx

src/Saturn/Pipelines.fs

@@ -199,4 +199,7 @@ module Pipeline =
   let ssl : HttpHandler = succeed
 
   ///TODO: Add pipeline for hosting static files - https://github.com/elixir-plug/plug/blob/v1.4.3/lib/plug/static.ex#L1
-  let useStatic path : HttpHandler = succeed
+  let useStatic path (nxt : HttpFunc) (ctx : HttpContext) : HttpFuncResult =
+    Static.call path Static.defaultConfig nxt ctx
+
+

src/Saturn/Saturn.fsproj

@@ -9,6 +9,7 @@
     <Compile Include="Utils.fs" />
     <Compile Include="Common.fs" />
     <Compile Include="CORS.fs" />
+    <Compile Include="Static.fs" />
     <Compile Include="Controler.fs" />
     <Compile Include="Pipelines.fs" />
     <Compile Include="Router.fs" />

src/Saturn/Static.fs

@@ -0,0 +1,107 @@
+namespace Saturn
+
+module Static =
+
+  open System
+  open System.IO
+  open System.Text.RegularExpressions
+  open Giraffe.HttpHandlers
+  open Microsoft.AspNetCore.Http
+
+
+  type StaticConfig = {
+    // UseGZip: bool
+    // UseBrotli: bool
+    Match : string
+    CacheControlForVSN: string
+    CacheControlForEtag: string
+    EtagGeneration: string -> string
+    Headers: (string * string) list
+    ContentTyes: (string * string) list
+  }
+
+  type private FileStatus =
+    | Stale
+    | Fresh
+
+  // If we serve gzip or brotli at any moment, we need to set the proper vary header regardless of whether we are serving gzip content right now.
+  // See: http://www.fastly.com/blog/best-practices-for-using-the-vary-header/
+  let private maybeAddVary (config : StaticConfig) =
+  // if config.UseGZip || config.UseBrotli then
+  //   setHttpHeader "vary" "Accept-Encoding"
+  // else
+        succeed
+
+  let private putCacheHeader (path: string) (config : StaticConfig) (ctx : HttpContext) : (FileStatus * HttpHandler) =
+    if ctx.Request.QueryString.HasValue && ctx.Request.QueryString.Value.StartsWith "vsn=" then
+      Stale, (setHttpHeader "cache-control" config.CacheControlForVSN)
+    else
+      let etag = config.EtagGeneration path
+      let conn =
+        setHttpHeader "cache-control" config.CacheControlForEtag
+        >=> setHttpHeader "etag" etag
+      let ifNonMatchLst =
+        match ctx.Request.Headers.TryGetValue "if-none-match" with
+        | true, vals -> vals.ToArray()
+        | _ -> [||]
+
+      if ifNonMatchLst |> Array.contains etag || ifNonMatchLst |> Array.contains "*" then
+        Fresh, conn
+      else
+        Stale, conn
+
+  let sendFile path : HttpHandler =
+    let cnt = File.ReadAllBytes path
+    setBody cnt
+
+  let private serveStatic path config (ctx : HttpContext) : HttpHandler =
+    match putCacheHeader path config ctx with
+    | Fresh, conn ->
+      conn
+      >=> setStatusCode 304
+    | Stale, conn ->
+      let ext = Path.GetExtension path
+      let contentType =
+        match config.ContentTyes |> List.tryFind (fun (k,_) -> k = ext) |> Option.map snd with
+        | Some s -> s
+        | None ->
+          let mimes = get<(string * string) list> "MimeTypes" ctx
+          match mimes |> Option.bind (List.tryFind (fun (k,_) -> k = ext)) |> Option.map snd with
+          | Some s -> s
+          | None -> ""
+      conn
+      >=> setHttpHeader "content-type" contentType
+      >=> setHttpHeaders config.Headers
+      >=> maybeAddVary config
+      >=> setStatusCode 200
+      >=> sendFile path
+
+  let private defaultEtag path =
+    let info = FileInfo path
+    (info.LastWriteTimeUtc, info.Length).GetHashCode().ToString()
+
+  let defaultConfig = {
+    Match = "*"
+    CacheControlForVSN = "public, max-age=31536000"
+    CacheControlForEtag = "public"
+    EtagGeneration = defaultEtag
+    Headers = []
+    ContentTyes =
+      [
+        ".html", "text/html"
+      ]
+  }
+  let call (from : string) config (nxt : HttpFunc) (ctx : HttpContext) : HttpFuncResult=
+    let path = ctx.Request.Path.Value.TrimStart '/'
+    if ctx.Request.Method = "GET" || ctx.Request.Method = "HEAD" then
+        let m = Regex.Escape(config.Match).Replace( @"\*", ".*" ).Replace( @"\?", "." )
+        if Regex.IsMatch(path, m) then
+          let p = Path.Combine(Path.GetDirectoryName(Diagnostics.Process.GetCurrentProcess().MainModule.FileName), from, path)
+          if File.Exists p then
+            (serveStatic p config ctx) nxt ctx
+          else
+            nxt ctx
+        else
+          nxt ctx
+    else
+      nxt ctx