[suave] fixes #1

Author: haf

.semver

@@ -1,6 +1,6 @@
 ---
 :major: 0
 :minor: 4
-:patch: 1
+:patch: 2
 :special: ''
 :metadata: ''

src/logibit.hawk.suave.tests/Hawk.fs

@@ -46,6 +46,7 @@ let making_request =
   let sample_app =
     Hawk.authenticate
       settings
+      Hawk.bind_req
       (fun (attr, creds, user) -> OK (sprintf "authenticated user '%s'" user.real_name))
       (fun err -> UNAUTHORIZED (err.ToString()))
 

src/logibit.hawk.suave/Hawk.fs

@@ -9,7 +9,6 @@ type SHttpMethod = HttpMethod
 open logibit.hawk
 open logibit.hawk.Types
 open logibit.hawk.Server
-open logibit.hawk.Choice
 
 module private Impl =
   open Microsoft.FSharp.Reflection
@@ -46,47 +45,88 @@ module private Impl =
 [<Literal>]
 let HawkDataKey = "logibit.hawk.data"
 
-let auth_ctx (s : Settings<'a>) =
-  fun ({ request = s_req } as ctx) ->
-
-    let ub = UriBuilder (s_req.url)
-    ub.Host <- s_req.host.value
-
-    Binding.header "authorization" Choice1Of2 s_req
-    >>= (fun header ->
-      Binding.header "host" Choice1Of2 s_req
-      >>- fun host -> header, host)
+/// ReqFactory :: Settings<'a> -> HttpContext -> Choice<Req, string>
+///
+/// You can bind the last argument to a function
+/// that maps your request changing function into the choice. Or in code:
+///
+/// let plx_goto_8080_MR s =
+///   bind_req s
+///   // when you've bound the request, apply the following function to
+///   // the return value (the Choice of req or a string error)
+///   >> (fun mreq ->
+///        // map over the OK result (non error case), see
+///        // https://github.com/logibit/logibit.hawk#logibithawkchoice
+///        mreq >>- (fun req ->
+///                   // and change the port so we can find our way:
+///                   { req with port = Some 8080us }))
+type ReqFactory<'a> = Settings<'a> -> HttpContext -> Choice<Req, string>
+
+open logibit.hawk.Choice // Choice's binding of >>=
+
+let bind_req (s : Settings<'a>)
+             ({ request = s_req } as ctx)
+             : Choice<Req, string> =
+
+  let ub = UriBuilder (s_req.url)
+  ub.Host <- s_req.host.value
+
+  Binding.header "authorization" Choice1Of2 s_req
+  >>= (fun header ->
+    Binding.header "host" Choice1Of2 s_req
+    >>- fun host -> header, host)
+  >>- (fun (auth, host) ->
+    { ``method``    = Impl.from_suave_method s_req.``method``
+      uri           = ub.Uri
+      authorisation = auth
+      payload       = if s_req.raw_form.Length = 0 then None else Some ctx.request.raw_form
+      host          = None
+      port          = None
+      content_type  = "content-type" |> HttpRequest.header ctx.request })
+
+// Example functor of the bind_req function:
+//let bind_req' s =
+//  bind_req s >> (fun mreq -> mreq >>- (fun req -> { req with port = Some 8080us }))
+
+let auth_ctx (s : Settings<'a>) (f_req : ReqFactory<'a>) =
+  fun ctx ->
+    f_req s ctx
     >>@ AuthError.Other
-    >>= (fun (auth, host) ->
-      let req =
-        { ``method``    = Impl.from_suave_method s_req.``method``
-          uri           = ub.Uri
-          authorisation = auth
-          payload       = if s_req.raw_form.Length = 0 then None else Some ctx.request.raw_form
-          host          = None
-          port          = None
-          content_type  = "content-type" |> HttpRequest.header ctx.request }
-      Server.authenticate s req)
+    >>= Server.authenticate s
+
+let auth_ctx' s = auth_ctx s bind_req
 
 open Suave.Http // this changes binding of >>=
 
-/// Authenticate the request with the given settings and a
-/// continuation functor for both the successful case and the
-/// unauthorised case.
+/// Authenticate the request with the given settings, and a request
+/// getting function (ReqFactory) and then a continuation functor for
+/// both the successful case and the unauthorised case.
 ///
 /// This will also set `HawkDataKey` in the `user_state` dictionary.
-let authenticate (s : Settings<_>)
+///
+/// You might want to use authenticate' unless you're running behind
+/// a load balancer and need to replace your `bind_req` function (in this
+/// module) with something of your own.
+///
+/// Also see the comments on the ReqFactory type for docs on how to contruct
+/// your own Req value, or re-map the default one.
+let authenticate (s : Settings<'a>)
+                 (f_req : ReqFactory<'a>)
                  (f_cont : _ -> WebPart)
                  (f_err : AuthError -> WebPart)
                  : WebPart =
   fun ctx ->
-    match auth_ctx s ctx with
+    match auth_ctx s f_req ctx with
     | Choice1Of2 res ->
       (Writers.set_user_data HawkDataKey res
        >>= f_cont res) ctx
     | Choice2Of2 err ->
       f_err err ctx
 
+/// Like `authenticate` but with the default request factory function.
+let authenticate' s =
+  authenticate s bind_req
+
 module HttpContext =
 
   /// Find the Hawk auth data from the context.

src/logibit.hawk/Server.fs

@@ -102,6 +102,37 @@ type Req =
     /// URI to the `authenticate` function.
     port          : Port option }
 
+[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
+module Req =
+
+  let ``method``_ =
+    (fun x -> x.``method``),
+    fun v (x : Req) -> { x with ``method`` = v }
+
+  let uri_ =
+    (fun x -> x.uri),
+    fun v (x : Req) -> { x with uri = v }
+
+  let authorisation_ =
+    (fun x -> x.authorisation),
+    fun v (x : Req) -> { x with authorisation = v }
+
+  let payload_ =
+    (fun x -> x.payload),
+    fun v (x : Req) -> { x with payload = v }
+
+  let content_type_ =
+    (fun x -> x.content_type),
+    fun v (x : Req) -> { x with content_type = v }
+
+  let host_ =
+    (fun x -> x.host),
+    fun v (x : Req) -> { x with host = v }
+
+  let port_ =
+    (fun x -> x.port),
+    fun v (x : Req) -> { x with port = v }
+
 /// Authentication settings
 type Settings<'a> =
   { /// The clock to use for getting the time.