Authentication.fs

[<RequireQualifiedAccess>]
module Authentication

open System
open System.Collections.Generic
open Simple.Web
open Simple.Web.Http
open Simple.Web.Authentication

type Payload = { UserId: Guid; Name: string; Expires: int64 }

let bind f = function
    | Some s -> f s
    | None -> None

let (>>=) f1 f2 =
    f1 >> bind f2

let getAuthHeader (request:IRequest) =
    request.Headers.TryGetValue "Authorization" |> function
    | false, _ -> None
    | true, t -> Some t

let getToken (t:string array) =
    match t.Length with
    | 0 -> None
    | _ -> t.[0] |> Some

let getPayload (secretKey:string) token = 
    try
        let value = JWT.JsonWebToken.Decode(token, secretKey)
        Newtonsoft.Json.JsonConvert.DeserializeObject<Payload>(value) |> Some
    with _ -> None

let createUser = function
    | None -> null
    | Some { UserId = userId; Name = name; Expires = expires } ->
        try
            if DateTime.UtcNow > DateTime.FromBinary(expires) then null
            else User(userId, name) :> IUser
        with _ -> null

let getProvider secretKey =

    let loadUser = getAuthHeader >>= getToken >>= getPayload secretKey >> createUser
        
    { new IAuthenticationProvider with
        member __.GetLoggedInUser context =
            context.Request |> loadUser
                                    
        member __.SetLoggedInUser (context, user) =
            let writeToken token =
                // We need to use this extension method, instead, or get a NRE on Response.Headers
                context.Response.AddHeader("Authorization", token)

            let expires = DateTime.UtcNow.AddDays(1.).ToBinary()
            let payload = { UserId = user.Guid; Name = user.Name; Expires = expires }
            let token = JWT.JsonWebToken.Encode(payload, secretKey, JWT.JwtHashAlgorithm.HS512)
            token |> writeToken }

Bind.fs

let bind f = function
    | Some s -> f s
    | None -> None

GetToken1.fs

let getToken (t:string array option) =
    match t with
    | None -> None
    | Some t ->
        match t.Length with
        | 0 -> None
        | _ -> t.[0] |> Some

GetToken2.fs

let getToken (t:string array) =
    match t.Length with
    | 0 -> None
    | _ -> t.[0] |> Some

Infix1.fs

let (>>=) f1 f2 =
    f1 >> bind f2

Infix2.fs

let (>>=) f1 f2 =
    f1 >> Option.bind f2  // No need to define our own bind function for Options