Verify Email middleware

config.ml

@@ -17,6 +17,7 @@ let mollymawk =
       package "mirage-crypto-rng";
       package "uuidm";
       package "emile";
+      package "sendmail";
       package "paf" ~sublibs:[ "mirage" ] ~min:"0.5.0";
       package "oneffs";
       package "duration";

middleware.ml

@@ -1,25 +1,53 @@
 type handler = Httpaf.Reqd.t -> unit Lwt.t
 type middleware = handler -> handler
 
-let has_session_cookie (reqd : Httpaf.Reqd.t) : bool =
+let has_session_cookie (reqd : Httpaf.Reqd.t) =
   let headers = (Httpaf.Reqd.request reqd).headers in
   match Httpaf.Headers.get headers "Cookie" with
   | Some cookies ->
       let cookie_list = String.split_on_char ';' cookies in
-      List.exists
+      List.find_opt
         (fun cookie ->
           let parts = String.trim cookie |> String.split_on_char '=' in
           match parts with
           | [ name; _ ] -> String.equal name "molly_session"
           | _ -> false)
         cookie_list
-  | _ -> false
+  | _ -> None
 
 let apply_middleware middlewares handler =
   List.fold_right (fun middleware acc -> middleware acc) middlewares handler
 
 let redirect_to_login reqd ?(msg = "") () =
-  let headers = Httpaf.Headers.of_list [ ("location", "/sign-in") ] in
+  let header_list =
+    [
+      ( "Set-Cookie",
+        "molly_session=;Path=/;HttpOnly=true;Expires=2023-10-27T11:00:00.778Z"
+      );
+      ("location", "/sign-in");
+    ]
+  in
+  let headers = Httpaf.Headers.of_list header_list in
+  let response = Httpaf.Response.create ~headers `Found in
+  Httpaf.Reqd.respond_with_string reqd response msg;
+  Lwt.return_unit
+
+let redirect_to_register reqd ?(msg = "") () =
+  let header_list =
+    [
+      ( "Set-Cookie",
+        "molly_session=;Path=/;HttpOnly=true;Expires=2023-10-27T11:00:00.778Z"
+      );
+      ("location", "/sign-up");
+    ]
+  in
+  let headers = Httpaf.Headers.of_list header_list in
+  let response = Httpaf.Response.create ~headers `Found in
+  Httpaf.Reqd.respond_with_string reqd response msg;
+  Lwt.return_unit
+
+let redirect_to_verify_email reqd ?(msg = "") () =
+  let headers = Httpaf.Headers.of_list [ ("location", "/verify-email") ] in
   let response = Httpaf.Response.create ~headers `Found in
   Httpaf.Reqd.respond_with_string reqd response msg;
   Lwt.return_unit
@@ -30,55 +58,68 @@ let redirect_to_dashboard reqd ?(msg = "") () =
   Httpaf.Reqd.respond_with_string reqd response msg;
   Lwt.return_unit
 
-let auth_middleware ~users handler reqd =
-  let headers = (Httpaf.Reqd.request reqd).headers in
-  match Httpaf.Headers.get headers "Cookie" with
-  | Some cookies -> (
-      let cookie_list = String.split_on_char ';' cookies in
-      let session_cookie =
-        List.find_opt
-          (fun cookie ->
-            let parts = String.trim cookie |> String.split_on_char '=' in
-            match parts with
-            | [ name; _ ] -> String.equal name "molly_session"
-            | _ -> false)
-          cookie_list
-      in
-      match session_cookie with
-      | Some cookie -> (
-          let parts = String.trim cookie |> String.split_on_char '=' in
-          let value = List.nth parts 1 in
-          match User_model.find_user_by_key value users with
-          | Some user -> (
-              let user_session =
-                List.find_opt
-                  (fun (cookie : User_model.cookie) ->
-                    String.equal cookie.name "molly_session")
-                  user.cookies
-              in
-              match user_session with
-              | Some cookie -> (
-                  match String.equal cookie.value value with
-                  | true -> handler reqd
-                  | false ->
-                      Logs.err (fun m ->
-                          m
-                            "auth-middleware: Session value doesn't match user \
-                             session %s\n"
-                            value);
-                      redirect_to_login reqd ())
-              | None ->
+let cookie_value_from_auth_cookie cookie =
+  match String.split_on_char '=' (String.trim cookie) with
+  | _ :: s :: _ -> Ok (String.trim s)
+  | _ -> Error (`Msg "Bad cookie")
+
+let user_from_auth_cookie cookie users =
+  match cookie_value_from_auth_cookie cookie with
+  | Ok cookie_value -> (
+      match User_model.find_user_by_key cookie_value users with
+      | Some user -> Ok user
+      | None -> Error (`Msg "User not found"))
+  | Error (`Msg s) ->
+      Logs.err (fun m -> m "Error: %s" s);
+      Error (`Msg s)
+
+let auth_middleware now users handler reqd =
+  match has_session_cookie reqd with
+  | Some auth_cookie -> (
+      match user_from_auth_cookie auth_cookie users with
+      | Ok user -> (
+          match User_model.user_auth_cookie_from_user user with
+          | Some cookie -> (
+              match User_model.is_valid_cookie cookie now with
+              | true -> handler reqd
+              | false ->
                   Logs.err (fun m ->
-                      m "auth-middleware: User doesn't have a session cookie.\n");
+                      m
+                        "auth-middleware: Session value doesn't match user \
+                         session %s\n"
+                        auth_cookie);
                   redirect_to_login reqd ())
           | None ->
               Logs.err (fun m ->
-                  m "auth-middleware: Failed to find user with key %s\n" value);
+                  m "auth-middleware: User doesn't have a session cookie.\n");
               redirect_to_login reqd ())
-      | None ->
+      | Error (`Msg s) ->
           Logs.err (fun m ->
-              m "auth-middleware: No molly-session in cookie header.");
-          redirect_to_login reqd ())
-  | _ ->
-      Logs.err (fun m -> m "auth-middleware: No Cookie in request headers.\n");
+              m "auth-middleware: Failed to find user with key %s: %s\n"
+                auth_cookie s);
+          redirect_to_register reqd ())
+  | None ->
+      Logs.err (fun m ->
+          m "auth-middleware: No molly-session in cookie header.");
       redirect_to_login reqd ()
+
+let email_verified_middleware now users handler reqd =
+  match has_session_cookie reqd with
+  | Some cookie -> (
+      match user_from_auth_cookie cookie users with
+      | Ok user -> (
+          match User_model.user_auth_cookie_from_user user with
+          | Some cookie -> (
+              match
+                User_model.(
+                  is_valid_cookie cookie now && is_email_verified user)
+              with
+              | true -> handler reqd
+              | false -> redirect_to_verify_email reqd ())
+          | None -> redirect_to_login reqd ())
+      | Error (`Msg s) ->
+          Logs.err (fun m ->
+              m "auth-middleware: Failed to find user with key %s : %s\n" cookie
+                s);
+          redirect_to_register reqd ())
+  | None -> redirect_to_login reqd ()

unikernel.ml

@@ -431,14 +431,32 @@ struct
         | "/images/robur.png" ->
             Lwt.return (reply ~content_type:"image/png" imgs.robur_img)
         | "/style.css" -> Lwt.return (reply ~content_type:"text/css" css_file)
-        | "/sign-up" ->
-            Lwt.return
-              (reply ~content_type:"text/html"
-                 (Sign_up.register_page ~icon:"/images/robur.png" ()))
-        | "/sign-in" ->
-            Lwt.return
-              (reply ~content_type:"text/html"
-                 (Sign_in.login_page ~icon:"/images/robur.png" ()))
+        | "/sign-up" -> (
+            match Middleware.has_session_cookie reqd with
+            | Some cookie -> (
+                match Middleware.cookie_value_from_auth_cookie cookie with
+                | Ok "" ->
+                    Lwt.return
+                      (reply ~content_type:"text/html"
+                         (Sign_up.register_page ~icon:"/images/robur.png" ()))
+                | _ -> Middleware.redirect_to_dashboard reqd ())
+            | None ->
+                Lwt.return
+                  (reply ~content_type:"text/html"
+                     (Sign_up.register_page ~icon:"/images/robur.png" ())))
+        | "/sign-in" -> (
+            match Middleware.has_session_cookie reqd with
+            | Some cookie -> (
+                match Middleware.cookie_value_from_auth_cookie cookie with
+                | Ok "" ->
+                    Lwt.return
+                      (reply ~content_type:"text/html"
+                         (Sign_in.login_page ~icon:"/images/robur.png" ()))
+                | _ -> Middleware.redirect_to_dashboard reqd ())
+            | None ->
+                Lwt.return
+                  (reply ~content_type:"text/html"
+                     (Sign_in.login_page ~icon:"/images/robur.png" ())))
         | "/api/register" -> (
             let request = Httpaf.Reqd.request reqd in
             match request.meth with
@@ -493,7 +511,7 @@ struct
                         let _, (s : Storage.t) = !store in
                         let users = s.users in
                         let user =
-                          User_model.check_if_user_exists ~email users
+                          User_model.check_if_user_exists email users
                         in
                         match user with
                         | Some _ ->
@@ -601,7 +619,7 @@ struct
                         let _, (t : Storage.t) = !store in
                         let users = t.users in
                         let login =
-                          User_model.login_user ~email ~password users ~now
+                          User_model.login_user ~email ~password users now
                         in
                         match login with
                         | Error (`Msg s) ->
@@ -666,10 +684,93 @@ struct
                    request method\"}"
                 in
                 Lwt.return (reply ~content_type:"application/json" res))
+        | "/verify-email" -> (
+            let now = Ptime.v (P.now_d_ps ()) in
+            let _, (t : Storage.t) = !store in
+            let users = User_model.create_user_session_map t.users in
+            let middlewares = [ Middleware.auth_middleware now users ] in
+            match Middleware.has_session_cookie reqd with
+            | Some cookie -> (
+                match Middleware.user_from_auth_cookie cookie users with
+                | Ok user -> (
+                    let email_verification_uuid = User_model.generate_uuid () in
+                    let updated_user =
+                      User_model.update_user user ~updated_at:now
+                        ~email_verification_uuid:(Some email_verification_uuid)
+                        ()
+                    in
+                    Store.update_user !store updated_user >>= function
+                    | Ok store' ->
+                        store := store';
+                        let verification_link =
+                          Utils.Email.generate_verification_link
+                            email_verification_uuid
+                        in
+                        Logs.info (fun m ->
+                            m "Verification link is: %s" verification_link);
+                        Middleware.apply_middleware middlewares
+                          (fun _reqd ->
+                            Lwt.return
+                              (reply ~content_type:"text/html"
+                                 (Verify_email.verify_page ~user
+                                    ~icon:"/images/robur.png" ())))
+                          reqd
+                    | Error (`Msg _msg) ->
+                        let res =
+                          "{\"status\": 400, \"success\": false, \"message\": \
+                           \"Something went wrong. Wait a few seconds and try \
+                           again.\"}"
+                        in
+                        Lwt.return (reply ~content_type:"application/json" res))
+                | Error (`Msg s) ->
+                    Logs.err (fun m -> m "Error: verify email endpoint %s" s);
+                    Middleware.redirect_to_register reqd ())
+            | None -> Middleware.redirect_to_login reqd ())
+        | path
+          when String.(
+                 length path >= 19 && sub path 0 19 = "/auth/verify/token=")
+          -> (
+            let request = Httpaf.Reqd.request reqd in
+            match request.meth with
+            | `GET -> (
+                let _, (t : Storage.t) = !store in
+                let users = User_model.create_user_uuid_map t.users in
+                let now = Ptime.v (P.now_d_ps ()) in
+                let verification_token =
+                  String.sub path 19 (String.length path - 19)
+                in
+                match
+                  User_model.verify_email_token users verification_token now
+                with
+                | Ok user -> (
+                    Store.update_user !store user >>= function
+                    | Ok store' ->
+                        store := store';
+                        Middleware.redirect_to_dashboard reqd ()
+                    | Error (`Msg _msg) ->
+                        let res =
+                          "{\"status\": 400, \"success\": false, \"message\": \
+                           \"Something went wrong. Wait a few seconds and try \
+                           again.\"}"
+                        in
+                        Lwt.return (reply ~content_type:"application/json" res))
+                | Error (`Msg s) -> Middleware.redirect_to_login reqd ~msg:s ())
+            | _ ->
+                let res =
+                  "{\"status\": 400, \"success\": false, \"message\": \"Bad \
+                   request method\"}"
+                in
+                Lwt.return (reply ~content_type:"application/json" res))
         | "/dashboard" ->
+            let now = Ptime.v (P.now_d_ps ()) in
             let _, (t : Storage.t) = !store in
             let users = User_model.create_user_session_map t.users in
-            let middlewares = [ Middleware.auth_middleware ~users ] in
+            let middlewares =
+              [
+                Middleware.email_verified_middleware now users;
+                Middleware.auth_middleware now users;
+              ]
+            in
             Middleware.apply_middleware middlewares
               (fun _reqd ->
                 Lwt.return
@@ -684,9 +785,10 @@ struct
               (reply ~content_type:"application/json"
                  (Yojson.Basic.to_string (Storage.t_to_json t)))
         | "/unikernel/create" ->
+            let now = Ptime.v (P.now_d_ps ()) in
             let _, (t : Storage.t) = !store in
             let users = User_model.create_user_session_map t.users in
-            let middlewares = [ Middleware.auth_middleware ~users ] in
+            let middlewares = [ Middleware.auth_middleware now users ] in
             Middleware.apply_middleware middlewares
               (fun _reqd -> Lwt.return (reply ~content_type:"text/html" html))
               reqd