wires up login request handlers

Author: demystifyfp

src/FsTweet.Web/Auth.fs

@@ -3,6 +3,7 @@ namespace Auth
 module Domain = 
   open User
   open Chessie.ErrorHandling
+  open Chessie
 
   type LoginRequest = {
     Username : Username
@@ -26,6 +27,24 @@ module Domain =
 
   type Login = FindUser -> LoginRequest -> AsyncResult<User, LoginError>
 
+  let login (findUser : FindUser) (req : LoginRequest) = asyncTrial {
+    let! userToFind = 
+      findUser req.Username |> AR.mapFailure Error
+    match userToFind with
+    | None -> 
+      return! AR.fail UsernameNotFound
+    | Some user -> 
+      match user.Email with
+      | NotVerified _ -> 
+        return! AR.fail EmailNotVerified
+      | Verified _ ->
+        let isMatchingPassword =
+          PasswordHash.VerifyPassword req.Password user.PasswordHash
+        match isMatchingPassword with
+        | false -> return! AR.fail PasswordMisMatch 
+        | _ -> return user
+  }
+
 module Suave =
   open Suave
   open Suave.Filters
@@ -35,6 +54,7 @@ module Suave =
   open Domain
   open Chessie.ErrorHandling
   open Chessie
+  open User
 
   type LoginViewModel = {
     Username : string
@@ -48,14 +68,49 @@ module Suave =
     Error = None
   }
 
-  let handleUserLogin ctx = async {
+  let onLoginSuccess (user : User) = 
+    Successful.OK user.Username.Value
+
+  let onLoginFailure viewModel loginError =
+    match loginError with
+    | PasswordMisMatch ->
+       let vm = 
+        {viewModel with Error = Some "password didn't match"}
+       page "guest/login.liquid" vm
+    | EmailNotVerified -> 
+       let vm = 
+        {viewModel with Error = Some "email not verified"}
+       page "guest/login.liquid" vm
+    | UsernameNotFound -> 
+       let vm = 
+        {viewModel with Error = Some "invalid username"}
+       page "guest/login.liquid" vm
+    | Error ex -> 
+      printfn "%A" ex
+      let vm = 
+        {viewModel with Error = Some "something went wrong"}
+      page "guest/login.liquid" vm
+    
+  let handleLoginResult viewModel loginResult = 
+    either onLoginSuccess (onLoginFailure viewModel) loginResult
+
+  let handleLoginAsyncResult viewModel aLoginResult = 
+    aLoginResult
+    |> Async.ofAsyncResult
+    |> Async.map (handleLoginResult viewModel)
+
+
+  let handleUserLogin findUser ctx = async {
     match bindEmptyForm ctx.request with
     | Choice1Of2 (vm : LoginViewModel) ->
       let result = 
         LoginRequest.TryCreate (vm.Username, vm.Password)
       match result with
       | Success req -> 
-        return! Successful.OK "TODO" ctx
+        let aLoginResult = login findUser req 
+        let! webpart = 
+          handleLoginAsyncResult vm aLoginResult
+        return! webpart ctx
       | Failure err -> 
         let viewModel = {vm with Error = Some err}
         return! page "guest/login.liquid" viewModel ctx
@@ -67,8 +122,9 @@ module Suave =
 
   let renderLoginPage viewModel = 
     page "guest/login.liquid" viewModel
-  let webpart () =
+  let webpart getDataCtx =
+    let findUser = Persistence.findUser getDataCtx
     path "/login" >=> choose [
       GET >=> renderLoginPage emptyLoginViewModel
-      POST >=> handleUserLogin
+      POST >=> handleUserLogin findUser
     ]

src/FsTweet.Web/Chessie.fs

@@ -31,4 +31,10 @@ module AR =
     aComputation 
     |> Async.Catch
     |> Async.map ofChoice
-    |> AR 
+    |> AR 
+
+  let fail x =
+    x 
+    |> fail 
+    |> Async.singleton 
+    |> AR

src/FsTweet.Web/FsTweet.Web.fs

@@ -54,7 +54,7 @@ let main argv =
       serveAssets
       path "/" >=> page "guest/home.liquid" ""
       UserSignup.Suave.webPart getDataCtx sendEmail
-      Auth.Suave.webpart ()
+      Auth.Suave.webpart getDataCtx
     ]
 
   startWebServer defaultConfig app

src/FsTweet.Web/User.fs

@@ -51,6 +51,16 @@ type PasswordHash = private PasswordHash of string with
     BCrypt.HashPassword(password.Value)
     |> PasswordHash 
 
+  static member TryCreate passwordHash =
+    try 
+      BCrypt.InterrogateHash passwordHash |> ignore
+      PasswordHash passwordHash |> ok
+    with
+    | _ -> fail "Invalid Password Hash"
+
+  static member VerifyPassword (password : Password) (passwordHash : PasswordHash) =
+    BCrypt.Verify(password.Value, passwordHash.Value)
+
 type UserEmail = 
 | Verified of EmailAddress
 | NotVerified of EmailAddress
@@ -67,4 +77,39 @@ type FindUser = Username -> AsyncResult<User option, System.Exception>
 
 module Persistence =
   open Database
-  let findUser (getDataCtx : GetDataContext) (username : Username) = ()
+  open FSharp.Data.Sql
+  open Chessie
+  let mapUser (user : DataContext.``public.UsersEntity``) = 
+    let userResult = trial {
+      let! username = Username.TryCreate user.Username
+      let! passwordHash = PasswordHash.TryCreate user.PasswordHash
+      let! email = EmailAddress.TryCreate user.Email
+      let userEmail =
+        match user.IsEmailVerified with
+        | true -> Verified email
+        | _ -> NotVerified email
+      return {
+        UserId = UserId user.Id
+        Username = username
+        PasswordHash = passwordHash
+        Email = userEmail
+      } 
+    }
+    userResult
+    |> mapFailure (System.Exception)
+    |> Async.singleton
+    |> AR
+  let findUser (getDataCtx : GetDataContext) (username : Username) = asyncTrial {
+    let ctx = getDataCtx()
+    let! userToFind = 
+      query {
+        for u in ctx.Public.Users do
+          where (u.Username = username.Value)
+      } |> Seq.tryHeadAsync |> AR.catch
+    match userToFind with
+    | Some user -> 
+      let! user = mapUser user
+      return Some user
+    | None -> return None
+  }
+