SPA UI.Next Bootstrap

BootstrapUI.fs

[<JavaScript>]
module BootstrapUI =
    open WebSharper.UI.Next
    open WebSharper.UI.Next.Html
    open WebSharper.UI.Next.Client

    module Button =
        type private ButtonColor =
        | Default
        | Primary

        type private ButtonStyle =
        | FullWidth
        | Inline

        let private makeButton txt btnColor btnStyle action =
            let styles = [yield "btn"
                          yield match btnColor with
                                | Default -> "btn-default"
                                | Primary -> "btn-primary"
                          yield match btnStyle with
                                | FullWidth -> "full"
                                | Inline -> "inline"] 
                         |> String.concat (" ")
            Doc.Button
            <| txt
            <| [attr.``class`` styles
                attr.``type`` "submit"]
            <| action
    
        let bsBtnDefaultFull txt action = makeButton txt ButtonColor.Default ButtonStyle.FullWidth action

        let bsBtnPrimaryInline txt action = makeButton txt ButtonColor.Primary ButtonStyle.Inline action

        let bsBtnPrimaryFull txt action = makeButton txt ButtonColor.Primary ButtonStyle.FullWidth action


    let bsNav brand leftLinks rightLinks =
        let navHeader =
            divAttr [attr.``class`` "navbar-header"]
                    [buttonAttr [attr.``class`` "navbar-toggle collapsed"
                                 Attr.Create "data-toggle" "collapse"
                                 Attr.Create "data-target" "#menu"
                                 Attr.Create "aria-expanded" "false"]
                                [spanAttr [attr.``class`` "sr-only"] []
                                 spanAttr [attr.``class`` "icon-bar"] []
                                 spanAttr [attr.``class`` "icon-bar"] []
                                 spanAttr [attr.``class`` "icon-bar"] []]
                     aAttr [attr.``class`` "navbar-brand title"
                            attr.href "#"]
                           [text brand]]
        let navMenu =
            divAttr [attr.``class`` "collapse navbar-collapse"
                     attr.id "menu"]
                    [ulAttr [attr.``class`` "nav navbar-nav"] [leftLinks]
                     ulAttr [attr.``class`` "nav navbar-nav navbar-right"] [rightLinks]]
        
        Doc.Concat 
            [navAttr [attr.``class`` "navbar navbar-default"] 
                  [divAttr [attr.``class`` "container-fluid"] 
                           [navHeader
                            navMenu]]]

    let bsInput placeHolder rvTxt = 
        Doc.Input [attr.``class`` "form-control"
                   attr.placeholder placeHolder] rvTxt

    let bsPasswordInput placeHolder rvPwd = 
        Doc.PasswordBox [attr.``class`` "form-control"
                         attr.placeholder placeHolder] rvPwd

    let bsPanelDefault body =
        divAttr [attr.``class`` "panel panel-default"]
                 [divAttr [attr.``class`` "panel-body"] body]

    let bsPanelDefaultWithTitle title body =
        divAttr [attr.``class`` "panel panel-default"]
                [divAttr [attr.``class`` "panel-heading"]
                         [h3Attr [attr.``class`` "panel-title"] [text title]]
                 divAttr [attr.``class`` "panel-body"] body]
    
    let bsError message =
        divAttr [attr.``class`` "alert alert-danger"
                 Attr.Create "role" "alet"]
                [text message]
    
    let bsRow bsCol =
        divAttr [attr.``class`` "row"] bsCol

    let bsCol3 body =
        divAttr [attr.``class`` "col-md-3"] body
    
    let bsCol4 body =
        divAttr [attr.``class`` "col-md-4"] body

    let bsContainer body =
        divAttr [attr.``class`` "container"] body

    let bsJumbotron title body = 
         divAttr [attr.``class`` "jumbotron"] 
                 [divAttr [attr.``class`` "container"]
                          [h1 [text title]
                           body]]

Client.fs

[<JavaScript>]
module ClientRoutes =
    open WebSharper.UI.Next

    type Page = 
        | Home
        | Claims
        | Users
        | Login
        override this.ToString() = 
            match this with
            | Home -> "Home"
            | Claims -> "Claims"
            | Users -> "Users"
            | Login -> "Login"
        
        static member List = [ Home; Claims; Users ]

    let install () = 
        RouteMap.Create
        <| function
           | Home -> []
           | Claims -> ["claims"]
           | Users -> ["users"]
           | Login -> ["login"]
        <| function
           | [] -> Home
           | ["claims"] -> Claims
           | ["users"] -> Users
           | ["login"] -> Login
           | _ -> failwith "404"
        |> RouteMap.Install

[<JavaScript>]
module NavBarPage = 
    open WebSharper.UI.Next
    open WebSharper.UI.Next.Html
    open WebSharper.UI.Next.Client
    open BootstrapUI
    open ApiClient
    
    let private makeNavlinks router = 
        View.FromVar router
        |> View.Map(fun currentPage -> 
               [ ClientRoutes.Home; ClientRoutes.Claims; ClientRoutes.Users ]
               |> List.map 
                      (fun page -> 
                      liAttr [ if page = currentPage then yield attr.``class`` "active" ] 
                          [ Doc.Link (string page) [] (fun _ -> Var.Set router page) ] :> Doc)
               |> Doc.Concat)
        |> Doc.EmbedView
    
    let private logout router = 
        li [ Doc.Link "Log out" [] (fun () -> 
                 api.Logout()
                 Var.Set router ClientRoutes.Login) ] :> Doc
    
    let doc router = bsNav "admin portal" (makeNavlinks router) (logout router)


[<JavaScript>]
module LoginPage = 
    open BootstrapUI
    open WebSharper.UI.Next
    open WebSharper.UI.Next.Html
    open WebSharper.UI.Next.Client
    open ApiClient
    
    let private login rvUsername rvPassword rvLoginError go () = 
        async { 
            let! login = api.Login { UserName = Var.Get rvUsername
                                     Password = Var.Get rvPassword }
            match login with
            | AsyncApi.Failure err -> 
                Var.Set rvLoginError "You may have keyed in an invalid Username or Password. Please try again."
                api.Logout()
            | _ -> ()
            return login
        }
        |> AsyncApi.map (fun _ -> go ClientRoutes.Home)
        |> AsyncApi.start
    
    let doc go = 
        let rvLoginError = Var.Create ""
        let rvUsername = Var.Create ""
        let rvPassword = Var.Create ""
        
        let buttons = 
            bsPanelDefault 
                [ form [ rvLoginError.View
                         |> View.Map(function 
                                | "" -> Doc.Empty
                                | err -> bsError err :> Doc)
                         |> Doc.EmbedView
                         bsInput "Username" rvUsername
                         bsPasswordInput "Password" rvPassword
                         Button.bsBtnDefaultFull "Log in" <| login rvUsername rvPassword rvLoginError go ] ]
        bsRow [ bsCol4 [ Doc.Empty ]
                bsCol4 [ h1Attr [attr.``class`` "title"] [text "admin portal"]
                         buttons ]
                bsCol4 [ Doc.Empty ] ]


[<JavaScript>]
module HomePage =
    open WebSharper.UI.Next
    open WebSharper.UI.Next.Html
    open WebSharper.UI.Next.Client
    open BootstrapUI

    let doc go = 
        bsJumbotron "Hello," 
                    ([p [text "Welcome to the admin portal v1.0."] :> Doc
                      Button.bsBtnPrimaryInline "View claims" (fun () -> go ClientRoutes.Claims) :> Doc
                      Button.bsBtnPrimaryInline "View users" (fun () -> go ClientRoutes.Users) :> Doc]
                     |> Doc.Concat)
   
[<JavaScript>]
module ClaimsPage =
    open WebSharper.UI.Next
    open WebSharper.UI.Next.Html
    open WebSharper.UI.Next.Client
    open BootstrapUI

    let doc go =
        bsJumbotron "Claims" Doc.Empty 

[<JavaScript>]
module UsersPage =
    open WebSharper.UI.Next
    open WebSharper.UI.Next.Html
    open WebSharper.UI.Next.Client
    open BootstrapUI

    let doc go =
        bsJumbotron "Users" Doc.Empty 

[<JavaScript>]
module Client = 
    open WebSharper.UI.Next
    open WebSharper.UI.Next.Html
    open WebSharper.UI.Next.Client
    open BootstrapUI
    
    let Main = 
        let router = ClientRoutes.install()
        
        let renderMain router = 
            View.FromVar router
            |> View.Map(fun page -> 
                   let go = Var.Set router
                   
                   let addNavBar body = 
                       [ NavBarPage.doc router
                         body ]
                       |> Doc.Concat
                   
                   let embedInContainer body = bsContainer [ body ]

                   match page with
                   | ClientRoutes.Login -> 
                       LoginPage.doc go 
                       |> embedInContainer :> Doc
                   | ClientRoutes.Home -> 
                       HomePage.doc go
                       |> embedInContainer
                       |> addNavBar
                   | ClientRoutes.Claims -> 
                       ClaimsPage.doc go
                       |> embedInContainer
                       |> addNavBar
                   | ClientRoutes.Users -> 
                       UsersPage.doc go
                       |> embedInContainer
                       |> addNavBar)
            |> Doc.EmbedView
        Doc.RunById "main" (renderMain router)

gistfile1.txt

[<JavaScript>]
module Async = 
    let map f xAsync = async { let! x = xAsync
                               return f x }

    let retn x = async { return x }

    let apply fAsync xAsync = async { let! fChild = Async.StartChild fAsync
                                      let! xChild = Async.StartChild xAsync
                                      let! f = fChild
                                      let! x = xChild
                                      return f x }

[<JavaScript>]
module AsyncApi =
    open System
    
    type ApiResult<'a> = 
        | Success of 'a
        | Failure of ApiResponseException list
    
    and ApiResponseException = 
        | Unauthorized of string
        | NotFound of string
        | UnsupportedMediaType of string
        | BadRequest of string
        | JsonDeserializeError of string
        override this.ToString() = 
            match this with
            | ApiResponseException.Unauthorized err -> err
            | ApiResponseException.NotFound err -> err
            | ApiResponseException.UnsupportedMediaType err -> err
            | ApiResponseException.BadRequest err -> err
            | ApiResponseException.JsonDeserializeError err -> err
    
    let map f xAsyncApiResult = 
        async { 
            let! xApiResult = xAsyncApiResult
            match xApiResult with
            | Success x -> return Success(f x)
            | Failure err -> return Failure err
        }
    
    let retn x = async { return ApiResult.Success x }
    
    let apply fAsyncApiResult xAsyncApiResult = 
        async { 
            let! fApiResult = fAsyncApiResult
            let! xApiResult = xAsyncApiResult
            match fApiResult, xApiResult with
            | Success f, Success x -> return Success(f x)
            | Success f, Failure err -> return Failure err
            | Failure err, Success f -> return Failure err
            | Failure err1, Failure err2 -> return Failure(List.concat [ err1; err2 ])
        }
    
    let bind f xAsyncApiResult = 
        async { 
            let! xApiResult = xAsyncApiResult
            match xApiResult with
            | Success x -> return! f x
            | Failure err -> return (Failure err)
        }
    
    let start xAsyncApiRes = 
        xAsyncApiRes
        |> Async.map (fun x -> ())
        |> Async.Start
    
    type ApiCallBuilder() = 
        
        member this.Bind(x, f) = 
            async { 
                let! xApiResult = x
                match xApiResult with
                | Success x -> return! f x
                | Failure err -> return (Failure err)
            }
        
        member this.Return x = async { return ApiResult.Success x }

        member this.ReturnFrom x = x
    
    let apiCall = new ApiCallBuilder()

[<JavaScript>]
module ApiClient = 
    open WebSharper.JavaScript
    open WebSharper.JQuery
    open AsyncApi
    open Claim
    open System
    open WebSharper.UI.Next
    
    type AuthToken = 
        { Token : string
          Expiry : DateTime }
        member this.IsExpired() = DateTime.UtcNow - this.Expiry < TimeSpan.FromMinutes(10.0)
        
        static member Make token = 
            { Token = token
              Expiry = DateTime.UtcNow }
        
        static member Default = 
            { Token = ""
              Expiry = DateTime.UtcNow }
    
    type ValidToken = 
        | ValidToken of string
    
    type Credentials = 
        { UserName : string
          Password : string }
        static member Default = 
            { UserName = "admin"
              Password = "admin" }
    
    type RequestSettings = 
        { RequestType : JQuery.RequestType
          Url : string
          ContentType : string option
          Headers : (string * string) list option
          Data : string option }
        member this.toAjaxSettings ok ko = 
            let settings = 
                JQuery.AjaxSettings
                    (Url = "http://localhost/api/" + this.Url, Type = this.RequestType, 
                     DataType = JQuery.DataType.Text, Success = (fun (result, _, _) -> ok (result :?> string)), 
                     Error = (fun (jqXHR, _, _) -> ko (System.Exception(string jqXHR.Status))))
            this.Headers |> Option.iter (fun h -> settings.Headers <- Object<string>(h |> Array.ofList))
            this.ContentType |> Option.iter (fun c -> settings.ContentType <- c)
            this.Data |> Option.iter (fun d -> settings.Data <- d)
            settings
    
    type Api = 
        { Login : Credentials -> Async<ApiResult<unit>>
          Logout : unit -> unit
          GetUsers : unit -> Async<ApiResult<User list>>
          GetPresentableClaims : unit -> Async<ApiResult<Claims>> }
    
    [<Literal>]
    let tokenStorageKey = "authtoken"
    
    let private ajaxCall (requestSettings : RequestSettings) = 
        Async.FromContinuations <| fun (ok, ko, _) -> 
            requestSettings.toAjaxSettings ok ko
            |> JQuery.Ajax
            |> ignore
    
    let private matchErrorStatusCode url code = 
        match code with
        | "401" -> 
            Failure 
                [ ApiResponseException.Unauthorized 
                  <| sprintf """"%s" - 401 The Authorization header did not pass security""" url ]
        | "404" -> Failure [ ApiResponseException.NotFound <| sprintf """"%s" - 404 Endpoint not found""" url ]
        | "415" -> 
            Failure 
                [ ApiResponseException.UnsupportedMediaType 
                  <| sprintf """"%s" - 415 The request Content-Type is not supported/invalid""" url ]
        | code -> Failure [ ApiResponseException.BadRequest <| sprintf """"%s" - %s Bad request""" url code ]
    
    let private tryDeserialize deserialization input = 
        try 
            deserialization input |> ApiResult.Success
        with _ -> 
            Failure [ ApiResponseException.JsonDeserializeError <| sprintf """"{%s}" cannot be deserialized""" input ]
        |> Async.retn
    
    let private getToken() = 
        try 
            JS.Window.LocalStorage.GetItem tokenStorageKey
            |> Json.Deserialize<AuthToken>
            |> ApiResult.Success
        with ex -> ApiResult.Failure [ Unauthorized "Unauthorized" ]
        |> Async.retn
    
    let private refreshToken (authToken : AuthToken) = 
        async { 
            let url = "token/refresh"
            if not (authToken.IsExpired()) then return ApiResult.Success authToken.Token
            else 
                try 
                    let! token = ajaxCall { RequestType = JQuery.RequestType.POST
                                            Url = url
                                            ContentType = None
                                            Headers = Some [ "Authorization", "Bearer " + authToken.Token ]
                                            Data = None }
                    return ApiResult.Success token
                with ex -> return matchErrorStatusCode url ex.Message
        }
        |> AsyncApi.bind (tryDeserialize Json.Deserialize<string>)
        |> AsyncApi.map (ValidToken)
    
    let private login credentials = 
        async { 
            let url = "auth/login/token"
            try 
                let! token = ajaxCall { RequestType = JQuery.RequestType.POST
                                        Url = url
                                        ContentType = Some "application/json"
                                        Headers = None
                                        Data = Some(Json.Serialize<Credentials>(credentials)) }
                return ApiResult.Success token
            with ex -> return matchErrorStatusCode url ex.Message
        }
        |> AsyncApi.bind (Json.Deserialize<string>
                          >> AuthToken.Make
                          |> tryDeserialize)
        |> AsyncApi.map (fun token -> 
               JS.Window.LocalStorage.SetItem(tokenStorageKey, Json.Serialize<AuthToken>(token)))
    
    let private logout() = JS.Window.LocalStorage.RemoveItem(tokenStorageKey)
    
    let private getClaims (ValidToken token) = 
        async { 
            let url = "claims"
            try 
                let! claims = ajaxCall { RequestType = JQuery.RequestType.GET
                                         Url = url
                                         ContentType = None
                                         Headers = Some [ "Authorization", "Bearer " + token ]
                                         Data = None }
                return ApiResult.Success(claims)
            with ex -> return matchErrorStatusCode url ex.Message
        }
        |> AsyncApi.bind (tryDeserialize Json.Deserialize<Claims>)
    
    let private getUsers (ValidToken token) = 
        async { 
            let url = "users"
            try 
                let! users = ajaxCall { RequestType = JQuery.RequestType.GET
                                        Url = url
                                        ContentType = None
                                        Headers = Some [ "Authorization", "Bearer " + token ]
                                        Data = None }
                return ApiResult.Success users
            with ex -> return matchErrorStatusCode url ex.Message
        }
        |> AsyncApi.bind (tryDeserialize Json.Deserialize<User list>)
    
    let api = 
        { Login = login
          Logout = logout
          GetUsers = fun () -> apiCall {
                                    let! token = getToken()
                                    let! validToken = refreshToken token
                                    return! getUsers validToken
                               }
          GetClaims = fun () ->  apiCall {
                                      let! token = getToken()
                                      let! validToken = refreshToken token
                                      return! getClaims validToken
                                  } }

    let bind f xAsync = async { let! x = xAsync
                                return! f x }