From dd30a0e264a0d193ffce2dc38ef0a7b6f5cb2c6f Mon Sep 17 00:00:00 2001 From: PizieDust Date: Fri, 11 Oct 2024 13:38:54 +0200 Subject: [PATCH 01/23] csrf middleware --- middleware.ml | 56 ++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 53 insertions(+), 3 deletions(-) diff --git a/middleware.ml b/middleware.ml index 004fac84..3ff004e0 100644 --- a/middleware.ml +++ b/middleware.ml @@ -1,7 +1,13 @@ type handler = Httpaf.Reqd.t -> unit Lwt.t type middleware = handler -> handler -let has_session_cookie (reqd : Httpaf.Reqd.t) = +let get_csrf now = + User_model.( + generate_cookie ~name:"molly_csrf" + ~uuid:(Uuidm.to_string (generate_uuid ())) + ~created_at:now ~expires_in:3600) + +let has_cookie cookie_name (reqd : Httpaf.Reqd.t) = let headers = (Httpaf.Reqd.request reqd).headers in match Httpaf.Headers.get headers "Cookie" with | Some cookies -> @@ -10,7 +16,7 @@ let has_session_cookie (reqd : Httpaf.Reqd.t) = (fun cookie -> let parts = String.trim cookie |> String.split_on_char '=' in match parts with - | [ name; _ ] -> String.equal name "molly_session" + | [ name; _ ] -> String.equal name cookie_name | _ -> false) cookie_list | _ -> None @@ -92,6 +98,14 @@ let redirect_to_dashboard reqd ?(msg = "") () = Httpaf.Reqd.respond_with_string reqd response msg; Lwt.return_unit +let redirect_to_same_page reqd ?(msg = "") () = + let request = Httpaf.Reqd.request reqd in + let current_path = request.target in + let headers = Httpaf.Headers.of_list [ ("location", current_path) ] in + let response = Httpaf.Response.create ~headers `Found in + Httpaf.Reqd.respond_with_string reqd response msg; + Lwt.return_unit + let cookie_value_from_auth_cookie cookie = match String.split_on_char '=' (String.trim cookie) with | _ :: s :: _ -> Ok (String.trim s) @@ -108,7 +122,7 @@ let user_from_auth_cookie cookie users = Error (`Msg s) let user_of_cookie users now reqd = - match has_session_cookie reqd with + match has_cookie "molly_session" reqd with | Some auth_cookie -> ( match user_from_auth_cookie auth_cookie users with | Ok user -> ( @@ -161,3 +175,39 @@ let is_user_admin_middleware api_meth now users handler reqd = "You don't have the necessary permissions to access this service." `Unauthorized user 401 api_meth reqd () | Error (`Msg msg) -> redirect_to_login ~msg reqd () + +let csrf_match ~input_csrf ~check_csrf = String.equal input_csrf check_csrf + +let csrf_cookie_verification form_csrf reqd = + match has_cookie "molly_csrf" reqd with + | Some cookie -> + csrf_match + ~input_csrf:(Utils.Json.clean_string form_csrf) + ~check_csrf:cookie + | None -> false + +let csrf_form_verification users now form_csrf handler reqd = + match user_of_cookie users now reqd with + | Ok user -> ( + let user_csrf_token = + List.find_opt + (fun (cookie : User_model.cookie) -> + String.equal cookie.name "molly_csrf") + user.User_model.cookies + in + match user_csrf_token with + | Some csrf_token -> + if + User_model.is_valid_cookie csrf_token now + && csrf_match ~check_csrf:csrf_token.value + ~input_csrf:(Utils.Json.clean_string form_csrf) + then handler reqd + else + redirect_to_same_page reqd + ~msg:"CSRF token mismatch error. Please referesh and try again." + () + | None -> + redirect_to_same_page + ~msg:"CSRF token mismatch error. Please referesh and try again." + reqd ()) + | Error (`Msg err) -> redirect_to_login ~msg:err reqd () From ba53ea80bb3095082a0b09fdfb7758b8b96ba3b6 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Fri, 11 Oct 2024 13:39:35 +0200 Subject: [PATCH 02/23] add hidden form input --- settings_page.ml | 3 ++- sign_up.ml | 8 +++++--- unikernel_create.ml | 3 ++- unikernel_single.ml | 3 ++- update_policy.ml | 3 ++- user_single.ml | 4 +++- verify_email.ml | 3 ++- 7 files changed, 18 insertions(+), 9 deletions(-) diff --git a/settings_page.ml b/settings_page.ml index 7f246984..a27f34a2 100644 --- a/settings_page.ml +++ b/settings_page.ml @@ -1,4 +1,4 @@ -let settings_layout (configuration : Configuration.t) = +let settings_layout (configuration : Configuration.t) csrf = let ip = Ipaddr.to_string configuration.server_ip in let port = string_of_int configuration.server_port in let certificate = X509.Certificate.encode_pem configuration.certificate in @@ -11,6 +11,7 @@ let settings_layout (configuration : Configuration.t) = div ~a:[ a_class [ "px-3 flex justify-between items-center" ] ] [ + Utils.csrf_form_input csrf; div [ p diff --git a/sign_up.ml b/sign_up.ml index 759e5736..462a4c67 100644 --- a/sign_up.ml +++ b/sign_up.ml @@ -1,6 +1,6 @@ open Tyxml -let register_page ~icon () = +let register_page csrf ~icon () = let page = Html.( html @@ -38,6 +38,7 @@ let register_page ~icon () = ]; ] [ + Utils.csrf_form_input csrf; div ~a:[ a_class [ "w-full max-w-lg mt-16 pb-16 mx-auto" ] ] [ @@ -255,7 +256,8 @@ let register_page ~icon () = document.getElementById('register-button')\n\ \ registerButton.addEventListener('click', async \ function() {\n\ - \ const name = \ + const form_csrf = document.getElementById('molly-csrf').value\n\ + \ const name = \ document.getElementById('name').value\n\ \ const email = \ document.getElementById('email').value\n\ @@ -304,7 +306,7 @@ let register_page ~icon () = 'application/json',\n\ \ },\n\ \ body: JSON.stringify({ name, \ - email, password })\n\ + email, password, form_csrf })\n\ \ })\n\ \ const data = await response.json();\n\ \ if (data.status === 200) {\n\ diff --git a/unikernel_create.ml b/unikernel_create.ml index a5c2d1a8..c378c4e4 100644 --- a/unikernel_create.ml +++ b/unikernel_create.ml @@ -1,4 +1,4 @@ -let unikernel_create_layout = +let unikernel_create_layout csrf = Tyxml_html.( section ~a:[ a_class [ "col-span-7 p-4 bg-gray-50 my-1" ] ] @@ -14,6 +14,7 @@ let unikernel_create_layout = div ~a:[ a_class [ "space-y-6 mt-8 p-6 max-w-5xl mx-auto" ] ] [ + Utils.csrf_form_input csrf; p ~a:[ a_id "form-alert"; a_class [ "my-4 hidden" ] ] []; div [ diff --git a/unikernel_single.ml b/unikernel_single.ml index 582c400a..604bcc0f 100644 --- a/unikernel_single.ml +++ b/unikernel_single.ml @@ -1,4 +1,4 @@ -let unikernel_single_layout unikernel now console_output = +let unikernel_single_layout unikernel now console_output csrf = let u_name, data = unikernel in Tyxml_html.( section @@ -40,6 +40,7 @@ let unikernel_single_layout unikernel now console_output = ]; div [ + Utils.csrf_form_input csrf; button ~a: [ diff --git a/update_policy.ml b/update_policy.ml index acf24902..0aaa005c 100644 --- a/update_policy.ml +++ b/update_policy.ml @@ -1,9 +1,10 @@ let update_policy_layout (user : User_model.user) ~user_policy - ~unallocated_resources = + ~unallocated_resources csrf = Tyxml_html.( section ~a:[ a_id "policy-form" ] [ + Utils.csrf_form_input csrf; h2 ~a:[ a_class [ "font-semibold text-2xl" ] ] [ txt ("Set Policy for " ^ user.name) ]; diff --git a/user_single.ml b/user_single.ml index 9bfa1a1b..024c96bb 100644 --- a/user_single.ml +++ b/user_single.ml @@ -1,4 +1,5 @@ -let user_single_layout (user : User_model.user) unikernels policy current_time = +let user_single_layout (user : User_model.user) unikernels policy current_time + csrf = Tyxml_html.( section ~a:[ a_class [ "p-4 bg-gray-50 my-1" ] ] @@ -9,6 +10,7 @@ let user_single_layout (user : User_model.user) unikernels policy current_time = section ~a:[ a_class [ "my-5" ] ] [ + Utils.csrf_form_input csrf; ul ~a: [ diff --git a/verify_email.ml b/verify_email.ml index 74378622..156a38e8 100644 --- a/verify_email.ml +++ b/verify_email.ml @@ -1,6 +1,6 @@ open Tyxml -let verify_page ~icon ~(user : User_model.user) () = +let verify_page ~icon (user : User_model.user) csrf () = let page = Html.( html @@ -51,6 +51,7 @@ let verify_page ~icon ~(user : User_model.user) () = div ~a:[ a_class [ "my-5" ] ] [ + Utils.csrf_form_input csrf; h1 ~a:[ a_class [ "text-3xl font-bold" ] ] [ txt "Please verify your email" ]; From 96267b12bafcf116c9b7c8f44d43951ca77ef27c Mon Sep 17 00:00:00 2001 From: PizieDust Date: Fri, 11 Oct 2024 13:39:54 +0200 Subject: [PATCH 03/23] pass form input to request --- assets/main.js | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/assets/main.js b/assets/main.js index 40ebad8f..4d5fc1c3 100644 --- a/assets/main.js +++ b/assets/main.js @@ -83,6 +83,7 @@ async function saveConfig() { const pkeyInput = document.getElementById("private-key").value; const formAlert = document.getElementById("form-alert"); const formButton = document.getElementById('config-button'); + const molly_csrf = document.getElementById("molly-csrf").value.trim(); formButton.classList.add("disabled"); formButton.innerHTML = `` if (ipInput === '' || portInput === '' || certificateInput === '' || pkeyInput === '') { @@ -96,7 +97,13 @@ async function saveConfig() { headers: { "Content-Type": "application/json", }, - body: JSON.stringify({ "server_ip": ipInput, "server_port": Number(portInput), "certificate": certificateInput, "private_key": pkeyInput }) + body: JSON.stringify({ + "server_ip": ipInput, + "server_port": Number(portInput), + "certificate": certificateInput, + "private_key": pkeyInput, + "molly_csrf": molly_csrf + }) }) const data = await response.json(); if (data.status === 200) { @@ -146,6 +153,7 @@ async function deployUnikernel() { const name = document.getElementById("unikernel-name").value.trim(); const arguments = document.getElementById("unikernel-arguments").value.trim(); const binary = document.getElementById("unikernel-binary").files[0]; + const molly_csrf = document.getElementById("molly-csrf").value.trim(); const formAlert = document.getElementById("form-alert"); if (!name || !binary) { formAlert.classList.remove("hidden", "text-primary-500"); @@ -158,6 +166,7 @@ async function deployUnikernel() { formData.append("name", name); formData.append("binary", binary) formData.append("arguments", arguments) + formData.append("molly_csrf", molly_csrf) try { const response = await fetch("/unikernel/create", { method: 'POST', @@ -191,10 +200,13 @@ async function deployUnikernel() { async function destroyUnikernel(name) { try { + const molly_csrf = document.getElementById("molly-csrf").value.trim(); const response = await fetch(`/unikernel/destroy/${name}`, { - method: 'GET', - mode: "no-cors" + method: 'POST', + body: JSON.stringify({ "name": name, "molly_csrf": molly_csrf }), + headers: { 'Content-Type': 'application/json' } }) + const data = await response.json(); if (data.status === 200) { postAlert("bg-primary-300", `Successful: ${data.data}`); @@ -225,9 +237,10 @@ function buttonLoading(btn, load, text) { async function toggleUserStatus(uuid, endpoint) { try { + const molly_csrf = document.getElementById("molly-csrf").value.trim(); const response = await fetch(endpoint, { method: 'POST', - body: JSON.stringify({ uuid: uuid }), + body: JSON.stringify({ uuid, molly_csrf }), headers: { 'Content-Type': 'application/json' } }); @@ -282,6 +295,7 @@ async function updatePolicy() { const formAlert = document.getElementById("form-alert"); const user_id = document.getElementById("user_id").innerText; const policyButton = document.getElementById("set-policy-btn"); + const molly_csrf = document.getElementById("molly-csrf").value.trim(); try { buttonLoading(policyButton, true, "Processing...") const response = await fetch("/api/admin/u/policy/update", { @@ -296,7 +310,8 @@ async function updatePolicy() { "block": Number(storage_size), "cpuids": cpuids, "bridges": bridges, - "user_uuid": user_id + "user_uuid": user_id, + "molly_csrf": molly_csrf }) }) const data = await response.json(); From 98a479e5c7b995624321983a8c3006cf6c769b00 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Fri, 11 Oct 2024 13:40:04 +0200 Subject: [PATCH 04/23] hidden form input html --- utils.ml | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/utils.ml b/utils.ml index fe85a954..505d2ba8 100644 --- a/utils.ml +++ b/utils.ml @@ -93,6 +93,18 @@ module Status = struct |> Yojson.Safe.to_string end +let csrf_form_input csrf = + Tyxml_html.( + input + ~a: + [ + a_input_type `Hidden; + a_id "molly-csrf"; + a_name "molly-csrf-input"; + a_value csrf; + ] + ()) + let display_banner = function | Some message -> Tyxml_html.( From c3b7fda131130585d6245f39077fa9d192e94fc3 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Fri, 11 Oct 2024 13:40:37 +0200 Subject: [PATCH 05/23] update endpoints --- unikernel.ml | 579 ++++++++++++++++++++++++++++++++++----------------- 1 file changed, 390 insertions(+), 189 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index 21575829..d7d67128 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -49,6 +49,41 @@ struct module Store = Storage.Make (BLOCK) module Map = Map.Make (String) + let generate_csrf_token ?(update_user = false) ?(user = None) store now = + if update_user then + match user with + | Some u -> ( + let csrf = Middleware.get_csrf now () in + let updated_user = + User_model.update_user u ~updated_at:now + ~cookies:(csrf :: u.cookies) () + in + Store.update_user !store updated_user >>= function + | Ok store' -> + store := store'; + Lwt.return (Ok csrf.value) + | Error (`Msg err) -> + let error = + { + Utils.Status.code = 500; + title = "CSRF Token Error"; + success = false; + data = err; + } + in + Lwt.return (Error error)) + | None -> + let error = + { + Utils.Status.code = 500; + title = "CSRF Token Error"; + success = false; + data = "Error generating csrf. No user"; + } + in + Lwt.return (Error error) + else Lwt.return (Ok (Middleware.get_csrf now ()).value) + let decode_request_body reqd = let request_body = Httpaf.Reqd.request_body reqd in let finished, notify_finished = Lwt.wait () in @@ -66,6 +101,21 @@ struct ~on_eof:(on_eof f_init); finished >>= fun data -> data + let extract_csrf_token reqd = + decode_request_body reqd >>= fun data -> + let json = + try Ok (Yojson.Basic.from_string data) + with Yojson.Json_error s -> Error (`Msg s) + in + match json with + | Error (`Msg err) -> + Logs.warn (fun m -> m "Failed to parse JSON: %s" err); + Lwt.return String.empty + | Ok json -> + json + |> Yojson.Basic.Util.member "csrf_token" + |> Yojson.Basic.to_string |> Lwt.return + module Albatross = Albatross.Make (T) (P) (S) let to_map ~assoc m = @@ -92,7 +142,7 @@ struct go (Map.empty, []) m let authenticate ?(email_verified = true) ?(check_admin = false) - ?(api_meth = false) store reqd f = + ?(api_meth = false) ?(check_csrf = false) ?(form_csrf = "") store reqd f = 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 @@ -103,6 +153,9 @@ struct @ (if email_verified && false (* TODO *) then [ Middleware.email_verified_middleware now users ] else []) + @ (if check_csrf then + [ Middleware.csrf_form_verification users now form_csrf ] + else []) @ [ Middleware.auth_middleware now users ] in Middleware.apply_middleware middlewares @@ -137,23 +190,30 @@ struct http_status) let sign_up reqd = - match Middleware.has_session_cookie reqd with + let now = Ptime.v (P.now_d_ps ()) in + let csrf = Middleware.get_csrf now () in + match Middleware.has_cookie "molly_session" reqd with | Some cookie -> ( match Middleware.cookie_value_from_auth_cookie cookie with | Ok "" -> + let csrf_cookie = + csrf.name ^ "=" ^ csrf.value ^ ";Path=/sign-up;HttpOnly=true" + in Lwt.return (reply reqd ~content_type:"text/html" - (Sign_up.register_page ~icon:"/images/robur.png" ()) + (Sign_up.register_page csrf.value ~icon:"/images/robur.png" ()) + ~header_list: + [ ("Set-Cookie", csrf_cookie); ("X-MOLLY-CSRF", csrf.value) ] `OK) | _ -> Middleware.redirect_to_dashboard reqd ()) | None -> Lwt.return (reply reqd ~content_type:"text/html" - (Sign_up.register_page ~icon:"/images/robur.png" ()) + (Sign_up.register_page csrf.value ~icon:"/images/robur.png" ()) `OK) let sign_in reqd = - match Middleware.has_session_cookie reqd with + match Middleware.has_cookie "molly_session" reqd with | Some cookie -> ( match Middleware.cookie_value_from_auth_cookie cookie with | Ok "" -> @@ -180,7 +240,7 @@ struct http_response reqd ~title:"Error" ~data:(String.escaped err) `Bad_request | Ok json -> ( - let validate_user_input ~name ~email ~password = + let validate_user_input ~name ~email ~password ~form_csrf = if name = "" || email = "" || password = "" then Error "All fields must be filled." else if String.length name < 4 then @@ -189,6 +249,8 @@ struct Error "Invalid email address." else if String.length password < 8 then Error "Password must be at least 8 characters long." + else if form_csrf = "" then + Error "CSRF token mismatch error. Please referesh and try again." else Ok "Validation passed." in let name = @@ -200,60 +262,76 @@ struct let password = json |> Yojson.Basic.Util.member "password" |> Yojson.Basic.to_string in - match validate_user_input ~name ~email ~password with + let form_csrf = + json + |> Yojson.Basic.Util.member "csrf_token" + |> Yojson.Basic.to_string + in + match validate_user_input ~name ~email ~password ~form_csrf with | Error err -> http_response reqd ~title:"Error" ~data:(String.escaped err) `Bad_request - | Ok _ -> ( - let _, (s : Storage.t) = !store in - let users = s.users in - let existing_email = User_model.check_if_email_exists email users in - let existing_name = User_model.check_if_name_exists name users in - match (existing_name, existing_email) with - | Some _, None -> - http_response reqd ~title:"Error" - ~data:"A user with this name already exist." `Bad_request - | None, Some _ -> - http_response reqd ~title:"Error" - ~data:"A user with this email already exist." `Bad_request - | None, None -> ( - let created_at = Ptime.v (P.now_d_ps ()) in - let user = - let active, super_user = - if List.length users = 0 then (true, true) - else (false, false) - in - User_model.create_user ~name ~email ~password ~created_at - ~active ~super_user - in - Store.add_user !store user >>= function - | Ok store' -> - store := store'; - let cookie = - List.find - (fun (c : User_model.cookie) -> - c.name = "molly_session") - user.cookies - in - let cookie_value = - cookie.name ^ "=" ^ cookie.value ^ ";Path=/;HttpOnly=true" - in - let header_list = - [ - ("Set-Cookie", cookie_value); ("location", "/dashboard"); - ] + | Ok _ -> + if Middleware.csrf_cookie_verification form_csrf reqd then + let _, (s : Storage.t) = !store in + let users = s.users in + let existing_email = + User_model.check_if_email_exists email users + in + let existing_name = User_model.check_if_name_exists name users in + match (existing_name, existing_email) with + | Some _, None -> + http_response reqd ~title:"Error" + ~data:"A user with this name already exist." `Bad_request + | None, Some _ -> + http_response reqd ~title:"Error" + ~data:"A user with this email already exist." `Bad_request + | None, None -> ( + let created_at = Ptime.v (P.now_d_ps ()) in + let user = + let active, super_user = + if List.length users = 0 then (true, true) + else (false, false) in - http_response reqd ~header_list ~title:"Success" - ~data: - (Yojson.Basic.to_string (User_model.user_to_json user)) - `OK - | Error (`Msg err) -> - http_response reqd ~title:"Error" ~data:(String.escaped err) - `Bad_request) - | _ -> - http_response reqd ~title:"Error" - ~data:"A user with this name or email already exist." - `Bad_request)) + User_model.create_user ~name ~email ~password ~created_at + ~active ~super_user + in + Store.add_user !store user >>= function + | Ok store' -> + store := store'; + let cookie = + List.find + (fun (c : User_model.cookie) -> + c.name = "molly_session") + user.cookies + in + let cookie_value = + cookie.name ^ "=" ^ cookie.value + ^ ";Path=/;HttpOnly=true" + in + let header_list = + [ + ("Set-Cookie", cookie_value); + ("location", "/dashboard"); + ] + in + http_response reqd ~header_list ~title:"Success" + ~data: + (Yojson.Basic.to_string + (User_model.user_to_json user)) + `OK + | Error (`Msg err) -> + http_response reqd ~title:"Error" + ~data:(String.escaped err) `Bad_request) + | _ -> + http_response reqd ~title:"Error" + ~data:"A user with this name or email already exist." + `Bad_request + else + http_response reqd ~title:"Error" + ~data: + "CSRF token mismatch error. Please referesh and try again." + `Bad_request) let login store reqd = decode_request_body reqd >>= fun data -> @@ -332,26 +410,30 @@ struct `Internal_server_error))) let verify_email store reqd user = - let email_verification_uuid = User_model.generate_uuid () in - let updated_user = - User_model.update_user user - ~updated_at:(Ptime.v (P.now_d_ps ())) - ~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); - Lwt.return - (reply reqd ~content_type:"text/html" - (Verify_email.verify_page ~user ~icon:"/images/robur.png" ()) - `OK) - | Error (`Msg err) -> - http_response reqd ~title:"Error" ~data:(String.escaped err) - `Internal_server_error + let now = Ptime.v (P.now_d_ps ()) in + generate_csrf_token ~update_user:true ~user:(Some user) store now + >>= function + | csrf -> ( + match csrf with + | Ok csrf -> + let email_verification_uuid = User_model.generate_uuid () in + let verification_link = + Utils.Email.generate_verification_link email_verification_uuid + in + Logs.info (fun m -> m "Verification link is: %s" verification_link); + Lwt.return + (reply reqd ~content_type:"text/html" + (Verify_email.verify_page user csrf ~icon:"/images/robur.png" + ()) + ~header_list:[ ("X-MOLLY-CSRF", csrf) ] + `OK) + | Error err -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user ~page_title:"500 | Mollymawk" + ~content:(Error_page.error_layout err) + ~icon:"/images/robur.png" ()) + `Internal_server_error)) let verify_email_token store reqd verification_token (user : User_model.user) = @@ -492,13 +574,29 @@ struct `OK) let settings store reqd user = - Lwt.return - (reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user ~page_title:"Settings | Mollymawk" - ~content: - (Settings_page.settings_layout (snd store).Storage.configuration) - ~icon:"/images/robur.png" ()) - `OK) + let now = Ptime.v (P.now_d_ps ()) in + generate_csrf_token ~update_user:true ~user:(Some user) store now + >>= function + | csrf -> ( + match csrf with + | Ok csrf -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user + ~page_title:"Settings | Mollymawk" + ~content: + (Settings_page.settings_layout + (snd !store).Storage.configuration csrf) + ~icon:"/images/robur.png" ()) + ~header_list:[ ("X-MOLLY-CSRF", csrf) ] + `OK) + | Error err -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user ~page_title:"500 | Mollymawk" + ~content:(Error_page.error_layout err) + ~icon:"/images/robur.png" ()) + `Internal_server_error)) let update_settings stack store albatross reqd _user = decode_request_body reqd >>= fun data -> @@ -535,14 +633,28 @@ struct http_response reqd ~title:"Error" ~data:(String.escaped err) `Bad_request) - let deploy_form reqd user = - Lwt.return - (reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user - ~page_title:"Deploy a Unikernel | Mollymawk" - ~content:Unikernel_create.unikernel_create_layout - ~icon:"/images/robur.png" ()) - `OK) + let deploy_form store reqd (user : User_model.user) = + let now = Ptime.v (P.now_d_ps ()) in + generate_csrf_token ~update_user:true ~user:(Some user) store now + >>= function + | csrf -> ( + match csrf with + | Ok csrf -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user + ~page_title:"Deploy a Unikernel | Mollymawk" + ~content:(Unikernel_create.unikernel_create_layout csrf) + ~icon:"/images/robur.png" ()) + ~header_list:[ ("X-MOLLY-CSRF", csrf) ] + `OK) + | Error err -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user ~page_title:"500 | Mollymawk" + ~content:(Error_page.error_layout err) + ~icon:"/images/robur.png" ()) + `Internal_server_error)) let unikernel_info albatross reqd (user : User_model.user) = (* TODO use uuid in the future *) @@ -565,7 +677,7 @@ struct ~data:(Yojson.Safe.to_string (`String res)) `Internal_server_error) - let unikernel_info_one albatross name reqd (user : User_model.user) = + let unikernel_info_one albatross store name reqd (user : User_model.user) = (* TODO use uuid in the future *) (Albatross.query albatross ~domain:user.name ~name (`Unikernel_cmd `Unikernel_info) @@ -588,15 +700,27 @@ struct Logs.warn (fun m -> m "error querying console of albatross: %s" err); [] | Ok (_, console_output) -> console_output) - >|= fun console_output -> - reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user - ~content: - (Unikernel_single.unikernel_single_layout (List.hd unikernels) - (Ptime.v (P.now_d_ps ())) - console_output) - ~icon:"/images/robur.png" ()) - `OK + >>= fun console_output -> + let now = Ptime.v (P.now_d_ps ()) in + generate_csrf_token ~update_user:true ~user:(Some user) store now + >|= function + | csrf -> ( + match csrf with + | Ok csrf -> + reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user + ~content: + (Unikernel_single.unikernel_single_layout + (List.hd unikernels) now console_output csrf) + ~icon:"/images/robur.png" ()) + ~header_list:[ ("X-MOLLY-CSRF", csrf) ] + `OK + | Error err -> + reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user ~page_title:"500 | Mollymawk" + ~content:(Error_page.error_layout err) + ~icon:"/images/robur.png" ()) + `Internal_server_error) else let error = { @@ -614,26 +738,40 @@ struct ~icon:"/images/robur.png" ()) `Internal_server_error) - let unikernel_destroy albatross name reqd (user : User_model.user) = + let unikernel_destroy albatross reqd (user : User_model.user) = (* TODO use uuid in the future *) - Albatross.query albatross ~domain:user.name ~name - (`Unikernel_cmd `Unikernel_destroy) - >>= function - | Error msg -> - Logs.err (fun m -> m "Error querying albatross: %s" msg); - http_response reqd ~title:"Error" - ~data:("Error querying albatross: " ^ msg) - `Internal_server_error - | Ok (_hdr, res) -> ( - match Albatross_json.res res with - | Ok res -> - http_response reqd ~title:"Success" - ~data:(Yojson.Safe.to_string res) - `OK - | Error (`String res) -> + decode_request_body reqd >>= fun data -> + let json = + try Ok (Yojson.Basic.from_string data) + with Yojson.Json_error s -> Error (`Msg s) + in + match json with + | Error (`Msg err) -> + Logs.err (fun m -> m "Failed to parse JSON: %s" err); + http_response reqd ~title:"Error" ~data:(String.escaped err) + `Bad_request + | Ok json -> ( + let unikernel_name = + Yojson.Basic.(to_string (json |> Util.member "name")) + in + Albatross.query albatross ~domain:user.name ~name:unikernel_name + (`Unikernel_cmd `Unikernel_destroy) + >>= function + | Error msg -> + Logs.err (fun m -> m "Error querying albatross: %s" msg); http_response reqd ~title:"Error" - ~data:(Yojson.Safe.to_string (`String res)) - `Internal_server_error) + ~data:("Error querying albatross: " ^ msg) + `Internal_server_error + | Ok (_hdr, res) -> ( + match Albatross_json.res res with + | Ok res -> + http_response reqd ~title:"Success" + ~data:(Yojson.Safe.to_string res) + `OK + | Error (`String res) -> + http_response reqd ~title:"Error" + ~data:(Yojson.Safe.to_string (`String res)) + `Internal_server_error)) let unikernel_create albatross reqd (user : User_model.user) = let response_body = Httpaf.Reqd.request_body reqd in @@ -675,37 +813,65 @@ struct match ( Map.find_opt "arguments" m, Map.find_opt "name" m, - Map.find_opt "binary" m ) + Map.find_opt "binary" m, + Map.find_opt "molly_csrf" m ) with - | Some (_, args), Some (_, name), Some (_, binary) -> ( + | ( Some (_, args), + Some (_, name), + Some (_, binary), + Some (_, form_csrf_token) ) -> ( Logs.info (fun m -> m "args %s" args); - match Albatross_json.config_of_json args with - | Ok cfg -> ( - let config = { cfg with image = binary } in - (* TODO use uuid in the future *) - Albatross.query albatross ~domain:user.name ~name - (`Unikernel_cmd (`Unikernel_create config)) - >>= function - | Error err -> - Logs.warn (fun m -> - m "Error querying albatross: %s" err); - http_response reqd ~title:"Error" - ~data:("Error while querying Albatross: " ^ err) - `Internal_server_error - | Ok (_hdr, res) -> ( - match Albatross_json.res res with - | Ok res -> - http_response reqd ~title:"Success" - ~data:(Yojson.Safe.to_string res) - `OK - | Error (`String res) -> - http_response reqd ~title:"Error" - ~data:(Yojson.Safe.to_string (`String res)) - `Internal_server_error)) - | Error (`Msg err) -> - Logs.warn (fun m -> m "couldn't decode data %s" err); + let user_csrf_token = + List.find_opt + (fun (cookie : User_model.cookie) -> + String.equal cookie.name "molly_csrf") + user.User_model.cookies + in + match user_csrf_token with + | Some csrf_token -> + if + Middleware.csrf_match ~input_csrf:form_csrf_token + ~check_csrf:csrf_token.value + then ( + match Albatross_json.config_of_json args with + | Ok cfg -> ( + let config = { cfg with image = binary } in + (* TODO use uuid in the future *) + Albatross.query albatross ~domain:user.name ~name + (`Unikernel_cmd (`Unikernel_create config)) + >>= function + | Error err -> + Logs.warn (fun m -> + m "Error querying albatross: %s" err); + http_response reqd ~title:"Error" + ~data:("Error while querying Albatross: " ^ err) + `Internal_server_error + | Ok (_hdr, res) -> ( + match Albatross_json.res res with + | Ok res -> + http_response reqd ~title:"Success" + ~data:(Yojson.Safe.to_string res) + `OK + | Error (`String res) -> + http_response reqd ~title:"Error" + ~data:(Yojson.Safe.to_string (`String res)) + `Internal_server_error)) + | Error (`Msg err) -> + Logs.warn (fun m -> m "couldn't decode data %s" err); - http_response reqd ~title:"Error" ~data:err + http_response reqd ~title:"Error" ~data:err + `Internal_server_error) + else + http_response reqd ~title:"Error" + ~data: + "CSRF token mismatch error. Please referesh and try \ + again." + `Internal_server_error + | None -> + http_response reqd ~title:"Error" + ~data: + "CSRF token mismatch error. Please referesh and try \ + again." `Internal_server_error) | _ -> Logs.warn (fun m -> m "couldn't find fields"); @@ -731,9 +897,9 @@ struct `OK) let view_user albatross store uuid reqd (user : User_model.user) = - let users = User_model.create_user_uuid_map (snd store).Storage.users in + let users = User_model.create_user_uuid_map (snd !store).Storage.users in match User_model.find_user_by_key uuid users with - | Some u -> + | Some u -> ( (Albatross.query albatross ~domain:u.name (`Unikernel_cmd `Unikernel_info) >|= function @@ -754,15 +920,31 @@ struct | Ok p -> p | Error _ -> None in - Lwt.return - (reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user - ~page_title:(String.capitalize_ascii u.name ^ " | Mollymawk") - ~content: - (User_single.user_single_layout u unikernels policy - (Ptime.v (P.now_d_ps ()))) - ~icon:"/images/robur.png" ()) - `OK) + let now = Ptime.v (P.now_d_ps ()) in + generate_csrf_token ~update_user:true ~user:(Some user) store now + >>= function + | csrf -> ( + match csrf with + | Ok csrf -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user + ~page_title: + (String.capitalize_ascii u.name ^ " | Mollymawk") + ~content: + (User_single.user_single_layout u unikernels policy + now csrf) + ~icon:"/images/robur.png" ()) + ~header_list:[ ("X-MOLLY-CSRF", csrf) ] + `OK) + | Error err -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user + ~page_title:"500 | Mollymawk" + ~content:(Error_page.error_layout err) + ~icon:"/images/robur.png" ()) + `Internal_server_error))) | None -> let status = { @@ -774,13 +956,13 @@ struct in Lwt.return (reply reqd ~content_type:"text/html" - (Guest_layout.guest_layout ~page_title:"404 | Mollymawk" + (Dashboard.dashboard_layout user ~page_title:"404 | Mollymawk" ~content:(Error_page.error_layout status) ~icon:"/images/robur.png" ()) `Not_found) let edit_policy albatross store uuid reqd (user : User_model.user) = - let users = User_model.create_user_uuid_map (snd store).Storage.users in + let users = User_model.create_user_uuid_map (snd !store).Storage.users in match User_model.find_user_by_key uuid users with | Some u -> ( let user_policy = @@ -790,16 +972,32 @@ struct | Error _ -> Albatross.empty_policy in match Albatross.policy_resource_avalaible albatross with - | Ok unallocated_resources -> - Lwt.return - (reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user - ~page_title:(String.capitalize_ascii u.name ^ " | Mollymawk") - ~content: - (Update_policy.update_policy_layout u ~user_policy - ~unallocated_resources) - ~icon:"/images/robur.png" ()) - `OK) + | Ok unallocated_resources -> ( + let now = Ptime.v (P.now_d_ps ()) in + generate_csrf_token ~update_user:true ~user:(Some user) store now + >>= function + | csrf -> ( + match csrf with + | Ok csrf -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user + ~page_title: + (String.capitalize_ascii u.name ^ " | Mollymawk") + ~content: + (Update_policy.update_policy_layout u ~user_policy + ~unallocated_resources csrf) + ~icon:"/images/robur.png" ()) + ~header_list:[ ("X-MOLLY-CSRF", csrf) ] + `OK) + | Error err -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user + ~page_title:"500 | Mollymawk" + ~content:(Error_page.error_layout err) + ~icon:"/images/robur.png" ()) + `Internal_server_error))) | Error err -> let status = { @@ -976,7 +1174,7 @@ struct check_meth `GET (fun () -> let uuid = String.sub path 12 (String.length path - 12) in authenticate ~check_admin:true !store reqd - (view_user !albatross !store uuid reqd)) + (view_user !albatross store uuid reqd)) | path when String.( length path >= 21 && sub path 0 21 = "/admin/u/policy/edit/") @@ -984,26 +1182,33 @@ struct check_meth `GET (fun () -> let uuid = String.sub path 21 (String.length path - 21) in authenticate ~check_admin:true !store reqd - (edit_policy !albatross !store uuid reqd)) + (edit_policy !albatross store uuid reqd)) | "/admin/settings" -> check_meth `GET (fun () -> - authenticate ~check_admin:true !store reqd - (settings !store reqd)) + authenticate ~check_admin:true !store reqd (settings store reqd)) | "/api/admin/settings/update" -> check_meth `POST (fun () -> - authenticate ~check_admin:true ~api_meth:true !store reqd + extract_csrf_token reqd >>= fun form_csrf -> + authenticate ~check_admin:true ~check_csrf:true ~form_csrf + ~api_meth:true !store reqd (update_settings stack store albatross reqd)) | "/api/admin/u/policy/update" -> check_meth `POST (fun () -> - authenticate ~check_admin:true ~api_meth:true !store reqd + extract_csrf_token reqd >>= fun form_csrf -> + authenticate ~check_admin:true ~check_csrf:true ~form_csrf + ~api_meth:true !store reqd (update_policy !store !albatross reqd)) | "/api/admin/user/activate/toggle" -> check_meth `POST (fun () -> - authenticate ~check_admin:true ~api_meth:true !store reqd + extract_csrf_token reqd >>= fun form_csrf -> + authenticate ~check_admin:true ~check_csrf:true ~form_csrf + ~api_meth:true !store reqd (toggle_account_activation store reqd)) | "/api/admin/user/admin/toggle" -> check_meth `POST (fun () -> - authenticate ~check_admin:true ~api_meth:true !store reqd + extract_csrf_token reqd >>= fun form_csrf -> + authenticate ~check_admin:true ~check_csrf:true ~form_csrf + ~api_meth:true !store reqd (toggle_admin_activation store reqd)) | "/api/unikernels" -> check_meth `GET (fun () -> @@ -1017,19 +1222,15 @@ struct String.sub path 16 (String.length path - 16) in authenticate !store reqd - (unikernel_info_one !albatross unikernel_name reqd)) + (unikernel_info_one !albatross store unikernel_name reqd)) | "/unikernel/deploy" -> check_meth `GET (fun () -> - authenticate !store reqd (deploy_form reqd)) - | path - when String.( - length path >= 19 && sub path 0 19 = "/unikernel/destroy/") -> - check_meth `GET (fun () -> - let unikernel_name = - String.sub path 19 (String.length path - 19) - in - authenticate !store reqd - (unikernel_destroy !albatross unikernel_name reqd)) + authenticate !store reqd (deploy_form store reqd)) + | "/unikernel/destory" -> + check_meth `POST (fun () -> + extract_csrf_token reqd >>= fun form_csrf -> + authenticate !store reqd ~check_csrf:true ~form_csrf + (unikernel_destroy !albatross reqd)) | path when String.( length path >= 19 && sub path 0 19 = "/unikernel/console/") -> From 1b5de31a1dd6544d0f986633b24923eaa698cb99 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Fri, 11 Oct 2024 13:58:52 +0200 Subject: [PATCH 06/23] rename csrf method --- middleware.ml | 2 +- unikernel.ml | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/middleware.ml b/middleware.ml index 3ff004e0..78dc603a 100644 --- a/middleware.ml +++ b/middleware.ml @@ -186,7 +186,7 @@ let csrf_cookie_verification form_csrf reqd = ~check_csrf:cookie | None -> false -let csrf_form_verification users now form_csrf handler reqd = +let csrf_verification users now form_csrf handler reqd = match user_of_cookie users now reqd with | Ok user -> ( let user_csrf_token = diff --git a/unikernel.ml b/unikernel.ml index d7d67128..5a207d91 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -153,8 +153,7 @@ struct @ (if email_verified && false (* TODO *) then [ Middleware.email_verified_middleware now users ] else []) - @ (if check_csrf then - [ Middleware.csrf_form_verification users now form_csrf ] + @ (if check_csrf then [ Middleware.csrf_verification users now form_csrf ] else []) @ [ Middleware.auth_middleware now users ] in From d36049f0b3036eb1cce4f856d9cd2f5c0a7267b4 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Fri, 11 Oct 2024 19:12:36 +0200 Subject: [PATCH 07/23] better redirect --- assets/main.js | 4 +++- middleware.ml | 30 ++++++++++++++++++++++-------- 2 files changed, 25 insertions(+), 9 deletions(-) diff --git a/assets/main.js b/assets/main.js index 4d5fc1c3..d1aec851 100644 --- a/assets/main.js +++ b/assets/main.js @@ -85,7 +85,8 @@ async function saveConfig() { const formButton = document.getElementById('config-button'); const molly_csrf = document.getElementById("molly-csrf").value.trim(); formButton.classList.add("disabled"); - formButton.innerHTML = `` + formButton.innerHTML = `Processing ` + formButton.disabled = true; if (ipInput === '' || portInput === '' || certificateInput === '' || pkeyInput === '') { formAlert.classList.remove("hidden"); formAlert.classList.add("text-secondary-500"); @@ -126,6 +127,7 @@ async function saveConfig() { } } formButton.innerHTML = "Update" + formButton.disabled = false; } function closeBanner() { diff --git a/middleware.ml b/middleware.ml index 78dc603a..95ebb5cd 100644 --- a/middleware.ml +++ b/middleware.ml @@ -98,12 +98,26 @@ let redirect_to_dashboard reqd ?(msg = "") () = Httpaf.Reqd.respond_with_string reqd response msg; Lwt.return_unit -let redirect_to_same_page reqd ?(msg = "") () = +let redirect_to_same_page reqd ~title http_status ?(msg = "") () = + let code = Httpaf.Status.to_code http_status + and success = Httpaf.Status.is_successful http_status in + let status = { Utils.Status.code; title; data = msg; success } in + let data = Utils.Status.to_json status in let request = Httpaf.Reqd.request reqd in - let current_path = request.target in - let headers = Httpaf.Headers.of_list [ ("location", current_path) ] in - let response = Httpaf.Response.create ~headers `Found in - Httpaf.Reqd.respond_with_string reqd response msg; + let _current_path = + match Httpaf.Headers.get request.headers "Referer" with + | Some path -> path + | None -> request.target + in + let headers = + Httpaf.Headers.of_list + [ + ("Content-Type", "application/json"); + ("Content-length", string_of_int (String.length data)); + ] + in + let response = Httpaf.Response.create ~headers http_status in + Httpaf.Reqd.respond_with_string reqd response data; Lwt.return_unit let cookie_value_from_auth_cookie cookie = @@ -203,11 +217,11 @@ let csrf_verification users now form_csrf handler reqd = ~input_csrf:(Utils.Json.clean_string form_csrf) then handler reqd else - redirect_to_same_page reqd + redirect_to_same_page reqd ~title:"CSRF Token Mismatch" ~msg:"CSRF token mismatch error. Please referesh and try again." - () + `Bad_request () | None -> redirect_to_same_page ~msg:"CSRF token mismatch error. Please referesh and try again." - reqd ()) + ~title:"CSRF Token Mismatch" reqd `Bad_request ()) | Error (`Msg err) -> redirect_to_login ~msg:err reqd () From 17c977fc1eeb8c14c0d43ec825169112ebd80bbd Mon Sep 17 00:00:00 2001 From: PizieDust Date: Fri, 11 Oct 2024 19:41:51 +0200 Subject: [PATCH 08/23] move http_response to middleware --- middleware.ml | 35 ++++++------- unikernel.ml | 141 ++++++++++++++++++++++++-------------------------- 2 files changed, 84 insertions(+), 92 deletions(-) diff --git a/middleware.ml b/middleware.ml index 95ebb5cd..456d9324 100644 --- a/middleware.ml +++ b/middleware.ml @@ -98,23 +98,20 @@ let redirect_to_dashboard reqd ?(msg = "") () = Httpaf.Reqd.respond_with_string reqd response msg; Lwt.return_unit -let redirect_to_same_page reqd ~title http_status ?(msg = "") () = +let http_response ~title ?(header_list = []) ?(data = "") reqd http_status = let code = Httpaf.Status.to_code http_status and success = Httpaf.Status.is_successful http_status in - let status = { Utils.Status.code; title; data = msg; success } in + let status = { Utils.Status.code; title; data; success } in let data = Utils.Status.to_json status in - let request = Httpaf.Reqd.request reqd in - let _current_path = - match Httpaf.Headers.get request.headers "Referer" with - | Some path -> path - | None -> request.target - in let headers = - Httpaf.Headers.of_list - [ - ("Content-Type", "application/json"); - ("Content-length", string_of_int (String.length data)); - ] + Httpaf.Headers.( + add_list + (of_list + [ + ("Content-Type", "application/json"); + ("Content-length", string_of_int (String.length data)); + ]) + header_list) in let response = Httpaf.Response.create ~headers http_status in Httpaf.Reqd.respond_with_string reqd response data; @@ -217,11 +214,11 @@ let csrf_verification users now form_csrf handler reqd = ~input_csrf:(Utils.Json.clean_string form_csrf) then handler reqd else - redirect_to_same_page reqd ~title:"CSRF Token Mismatch" - ~msg:"CSRF token mismatch error. Please referesh and try again." - `Bad_request () + http_response ~title:"CSRF Token Mismatch" + ~data:"CSRF token mismatch error. Please referesh and try again." + reqd `Bad_request | None -> - redirect_to_same_page - ~msg:"CSRF token mismatch error. Please referesh and try again." - ~title:"CSRF Token Mismatch" reqd `Bad_request ()) + http_response + ~data:"CSRF token mismatch error. Please referesh and try again." + ~title:"CSRF Token Mismatch" reqd `Bad_request) | Error (`Msg err) -> redirect_to_login ~msg:err reqd () diff --git a/unikernel.ml b/unikernel.ml index 5a207d91..e240e097 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -179,15 +179,6 @@ struct let resp = Httpaf.Response.create ~headers status in Httpaf.Reqd.respond_with_string reqd resp data - let http_response reqd ?(header_list = []) ~title ~data http_status = - let code = Httpaf.Status.to_code http_status - and success = Httpaf.Status.is_successful http_status in - let status = { Utils.Status.code; title; data; success } in - Lwt.return - (reply reqd ~content_type:"application/json" ~header_list - (Utils.Status.to_json status) - http_status) - let sign_up reqd = let now = Ptime.v (P.now_d_ps ()) in let csrf = Middleware.get_csrf now () in @@ -236,7 +227,7 @@ struct match json with | Error (`Msg err) -> Logs.warn (fun m -> m "Failed to parse JSON: %s" err); - http_response reqd ~title:"Error" ~data:(String.escaped err) + Middleware.http_response reqd ~title:"Error" ~data:(String.escaped err) `Bad_request | Ok json -> ( let validate_user_input ~name ~email ~password ~form_csrf = @@ -268,8 +259,8 @@ struct in match validate_user_input ~name ~email ~password ~form_csrf with | Error err -> - http_response reqd ~title:"Error" ~data:(String.escaped err) - `Bad_request + Middleware.http_response reqd ~title:"Error" + ~data:(String.escaped err) `Bad_request | Ok _ -> if Middleware.csrf_cookie_verification form_csrf reqd then let _, (s : Storage.t) = !store in @@ -280,10 +271,10 @@ struct let existing_name = User_model.check_if_name_exists name users in match (existing_name, existing_email) with | Some _, None -> - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:"A user with this name already exist." `Bad_request | None, Some _ -> - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:"A user with this email already exist." `Bad_request | None, None -> ( let created_at = Ptime.v (P.now_d_ps ()) in @@ -314,20 +305,21 @@ struct ("location", "/dashboard"); ] in - http_response reqd ~header_list ~title:"Success" + Middleware.http_response reqd ~header_list + ~title:"Success" ~data: (Yojson.Basic.to_string (User_model.user_to_json user)) `OK | Error (`Msg err) -> - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:(String.escaped err) `Bad_request) | _ -> - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:"A user with this name or email already exist." `Bad_request else - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data: "CSRF token mismatch error. Please referesh and try again." `Bad_request) @@ -341,7 +333,7 @@ struct match json with | Error (`Msg err) -> Logs.warn (fun m -> m "Failed to parse JSON: %s" err); - http_response reqd ~title:"Error" ~data:(String.escaped err) + Middleware.http_response reqd ~title:"Error" ~data:(String.escaped err) `Bad_request | Ok json -> ( let validate_user_input ~email ~password = @@ -360,8 +352,8 @@ struct in match validate_user_input ~email ~password with | Error err -> - http_response reqd ~title:"Error" ~data:(String.escaped err) - `Bad_request + Middleware.http_response reqd ~title:"Error" + ~data:(String.escaped err) `Bad_request | Ok _ -> ( let now = Ptime.v (P.now_d_ps ()) in let _, (t : Storage.t) = !store in @@ -369,8 +361,8 @@ struct let login = User_model.login_user ~email ~password users now in match login with | Error (`Msg err) -> - http_response reqd ~title:"Error" ~data:(String.escaped err) - `Bad_request + Middleware.http_response reqd ~title:"Error" + ~data:(String.escaped err) `Bad_request | Ok user -> ( Store.update_user !store user >>= function | Ok store' -> ( @@ -393,20 +385,21 @@ struct ("location", "/dashboard"); ] in - http_response reqd ~header_list ~title:"Success" + Middleware.http_response reqd ~header_list + ~title:"Success" ~data: (Yojson.Basic.to_string (User_model.user_to_json user)) `OK | None -> - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data: "Something went wrong. Wait a few seconds and try \ again." `Internal_server_error) | Error (`Msg err) -> - http_response reqd ~title:"Error" ~data:(String.escaped err) - `Internal_server_error))) + Middleware.http_response reqd ~title:"Error" + ~data:(String.escaped err) `Internal_server_error))) let verify_email store reqd user = let now = Ptime.v (P.now_d_ps ()) in @@ -450,10 +443,10 @@ struct store := store'; Middleware.redirect_to_dashboard reqd () | Error (`Msg msg) -> - http_response reqd ~title:"Error" ~data:(String.escaped msg) - `Internal_server_error + Middleware.http_response reqd ~title:"Error" + ~data:(String.escaped msg) `Internal_server_error else - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:"Logged in user is not the to-be-verified one" `Bad_request | Error (`Msg s) -> Middleware.redirect_to_login reqd ~msg:s () @@ -467,7 +460,7 @@ struct match json with | Error (`Msg err) -> Logs.warn (fun m -> m "Failed to parse JSON: %s - %s" key err); - http_response reqd ~title:"Error" ~data:err `Bad_request + Middleware.http_response reqd ~title:"Error" ~data:err `Bad_request | Ok (`Assoc json) -> ( match Utils.Json.get "uuid" json with | Some (`String uuid) -> ( @@ -477,33 +470,33 @@ struct match List.assoc_opt uuid users with | None -> Logs.warn (fun m -> m "%s : Account not found" key); - http_response reqd ~title:"Error" ~data:"Account not found" - `Not_found + Middleware.http_response reqd ~title:"Error" + ~data:"Account not found" `Not_found | Some user -> ( if error_on_last user then ( Logs.warn (fun m -> m "%s : Can't perform action on last user" key); - http_response reqd ~title:"Error" ~data:error_message - `Forbidden) + Middleware.http_response reqd ~title:"Error" + ~data:error_message `Forbidden) else let updated_user = update_fn user in Store.update_user !store updated_user >>= function | Ok store' -> store := store'; - http_response reqd ~title:"OK" + Middleware.http_response reqd ~title:"OK" ~data:"Updated user successfully" `OK | Error (`Msg msg) -> Logs.warn (fun m -> m "%s : Storage error with %s" key msg); - http_response reqd ~title:"Error" ~data:msg + Middleware.http_response reqd ~title:"Error" ~data:msg `Internal_server_error)) | _ -> Logs.warn (fun m -> m "%s: Failed to parse JSON - no UUID found" key); - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:"Couldn't find a UUID in the JSON." `Not_found) | Ok _ -> - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:"Provided JSON is not a dictionary" `Bad_request let toggle_account_activation store reqd _user = @@ -606,7 +599,7 @@ struct match json with | Error (`Msg err) -> Logs.warn (fun m -> m "Failed to parse JSON: %s" err); - http_response reqd ~title:"Error" ~data:(String.escaped err) + Middleware.http_response reqd ~title:"Error" ~data:(String.escaped err) `Bad_request | Ok json -> ( match @@ -623,14 +616,14 @@ struct configuration_settings.private_key >>= fun new_albatross -> albatross := new_albatross; - http_response reqd ~title:"Success" + Middleware.http_response reqd ~title:"Success" ~data:"Configuration updated successfully" `OK | Error (`Msg err) -> - http_response reqd ~title:"Error" ~data:(String.escaped err) - `Internal_server_error) + Middleware.http_response reqd ~title:"Error" + ~data:(String.escaped err) `Internal_server_error) | Error (`Msg err) -> - http_response reqd ~title:"Error" ~data:(String.escaped err) - `Bad_request) + Middleware.http_response ~title:"Error" ~data:(String.escaped err) + reqd `Bad_request) let deploy_form store reqd (user : User_model.user) = let now = Ptime.v (P.now_d_ps ()) in @@ -660,7 +653,7 @@ struct Albatross.query albatross ~domain:user.name (`Unikernel_cmd `Unikernel_info) >>= function | Error msg -> - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data: (Yojson.Safe.to_string (`String ("Error while querying albatross: " ^ msg))) @@ -668,11 +661,11 @@ struct | Ok (_hdr, res) -> ( match Albatross_json.res res with | Ok res -> - http_response reqd ~title:"Success" + Middleware.http_response reqd ~title:"Success" ~data:(Yojson.Safe.to_string res) `OK | Error (`String res) -> - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:(Yojson.Safe.to_string (`String res)) `Internal_server_error) @@ -747,7 +740,7 @@ struct match json with | Error (`Msg err) -> Logs.err (fun m -> m "Failed to parse JSON: %s" err); - http_response reqd ~title:"Error" ~data:(String.escaped err) + Middleware.http_response reqd ~title:"Error" ~data:(String.escaped err) `Bad_request | Ok json -> ( let unikernel_name = @@ -758,17 +751,17 @@ struct >>= function | Error msg -> Logs.err (fun m -> m "Error querying albatross: %s" msg); - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:("Error querying albatross: " ^ msg) `Internal_server_error | Ok (_hdr, res) -> ( match Albatross_json.res res with | Ok res -> - http_response reqd ~title:"Success" + Middleware.http_response reqd ~title:"Success" ~data:(Yojson.Safe.to_string res) `OK | Error (`String res) -> - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:(Yojson.Safe.to_string (`String res)) `Internal_server_error)) @@ -797,14 +790,14 @@ struct match ct with | Error (`Msg msg) -> Logs.warn (fun m -> m "couldn't content-type: %S" msg); - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:("Couldn't content-type: " ^ msg) `Bad_request | Ok ct -> ( match Multipart_form.of_string_to_list data ct with | Error (`Msg msg) -> Logs.warn (fun m -> m "couldn't multipart: %s" msg); - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:("Couldn't multipart: " ^ msg) `Bad_request | Ok (m, assoc) -> ( @@ -842,47 +835,47 @@ struct | Error err -> Logs.warn (fun m -> m "Error querying albatross: %s" err); - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:("Error while querying Albatross: " ^ err) `Internal_server_error | Ok (_hdr, res) -> ( match Albatross_json.res res with | Ok res -> - http_response reqd ~title:"Success" + Middleware.http_response reqd ~title:"Success" ~data:(Yojson.Safe.to_string res) `OK | Error (`String res) -> - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:(Yojson.Safe.to_string (`String res)) `Internal_server_error)) | Error (`Msg err) -> Logs.warn (fun m -> m "couldn't decode data %s" err); - http_response reqd ~title:"Error" ~data:err + Middleware.http_response reqd ~title:"Error" ~data:err `Internal_server_error) else - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data: "CSRF token mismatch error. Please referesh and try \ again." `Internal_server_error | None -> - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data: "CSRF token mismatch error. Please referesh and try \ again." `Internal_server_error) | _ -> Logs.warn (fun m -> m "couldn't find fields"); - http_response reqd ~title:"Error" ~data:"Couldn't find fields" - `Bad_request)) + Middleware.http_response reqd ~title:"Error" + ~data:"Couldn't find fields" `Bad_request)) let unikernel_console albatross name reqd (user : User_model.user) = (* TODO use uuid in the future *) Albatross.query_console ~domain:user.name albatross ~name >>= function | Error err -> Logs.warn (fun m -> m "error querying albatross: %s" err); - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:("Error while querying Albatross: " ^ err) `Internal_server_error | Ok (_, console_output) -> @@ -1037,7 +1030,7 @@ struct match json with | Error (`Msg err) -> Logs.err (fun m -> m "Failed to parse JSON: %s" err); - http_response reqd ~title:"Error" ~data:(String.escaped err) + Middleware.http_response reqd ~title:"Error" ~data:(String.escaped err) `Bad_request | Ok json -> ( let user_uuid = @@ -1060,7 +1053,7 @@ struct m "policy %a is not smaller than root policy %a: %s" Vmm_core.Policy.pp policy Vmm_core.Policy.pp root_policy err); - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data: ("policy is not smaller than root policy: " ^ err) `Internal_server_error @@ -1071,18 +1064,18 @@ struct Logs.err (fun m -> m "error setting policy %a for %s: %s" Vmm_core.Policy.pp policy u.name err); - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:("error setting policy: " ^ err) `Internal_server_error | Ok policy -> - http_response reqd ~title:"Success" + Middleware.http_response reqd ~title:"Success" ~data: (Yojson.Basic.to_string (Albatross_json.policy_info policy)) `OK)) | Ok None -> Logs.err (fun m -> m "policy: root policy can't be null "); - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:"root policy is null" `Internal_server_error | Error err -> Logs.err (fun m -> @@ -1090,20 +1083,22 @@ struct "policy: an error occured while fetching root \ policy: %s" err); - http_response reqd ~title:"Error" + Middleware.http_response reqd ~title:"Error" ~data:("error with root policy: " ^ err) `Internal_server_error) | Error (`Msg err) -> - http_response reqd ~title:"Error" ~data:err `Bad_request) + Middleware.http_response reqd ~title:"Error" ~data:err + `Bad_request) | None -> - http_response reqd ~title:"Error" ~data:"User not found" `Not_found) + Middleware.http_response reqd ~title:"Error" ~data:"User not found" + `Not_found) let request_handler stack albatross js_file css_file imgs store (_ipaddr, _port) reqd = Lwt.async (fun () -> let bad_request () = - http_response reqd ~title:"Error" ~data:"Bad HTTP request method." - `Bad_request + Middleware.http_response reqd ~title:"Error" + ~data:"Bad HTTP request method." `Bad_request in let req = Httpaf.Reqd.request reqd in let path = From 57703ffac104598e5abfcc7ac8c328e4142f4125 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Fri, 11 Oct 2024 20:04:49 +0200 Subject: [PATCH 09/23] fix bug pass json to methods --- middleware.ml | 11 +-- unikernel.ml | 247 +++++++++++++++++++++----------------------------- 2 files changed, 109 insertions(+), 149 deletions(-) diff --git a/middleware.ml b/middleware.ml index 456d9324..2ab09ea6 100644 --- a/middleware.ml +++ b/middleware.ml @@ -187,14 +187,12 @@ let is_user_admin_middleware api_meth now users handler reqd = `Unauthorized user 401 api_meth reqd () | Error (`Msg msg) -> redirect_to_login ~msg reqd () -let csrf_match ~input_csrf ~check_csrf = String.equal input_csrf check_csrf +let csrf_match ~input_csrf ~check_csrf = + String.equal (Utils.Json.clean_string input_csrf) check_csrf let csrf_cookie_verification form_csrf reqd = match has_cookie "molly_csrf" reqd with - | Some cookie -> - csrf_match - ~input_csrf:(Utils.Json.clean_string form_csrf) - ~check_csrf:cookie + | Some cookie -> csrf_match ~input_csrf:form_csrf ~check_csrf:cookie | None -> false let csrf_verification users now form_csrf handler reqd = @@ -210,8 +208,7 @@ let csrf_verification users now form_csrf handler reqd = | Some csrf_token -> if User_model.is_valid_cookie csrf_token now - && csrf_match ~check_csrf:csrf_token.value - ~input_csrf:(Utils.Json.clean_string form_csrf) + && csrf_match ~check_csrf:csrf_token.value ~input_csrf:form_csrf then handler reqd else http_response ~title:"CSRF Token Mismatch" diff --git a/unikernel.ml b/unikernel.ml index e240e097..765f3755 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -110,11 +110,14 @@ struct match json with | Error (`Msg err) -> Logs.warn (fun m -> m "Failed to parse JSON: %s" err); - Lwt.return String.empty + Lwt.return (String.empty, `Null) | Ok json -> - json - |> Yojson.Basic.Util.member "csrf_token" - |> Yojson.Basic.to_string |> Lwt.return + let csrf_token = + match Yojson.Basic.Util.member "molly_csrf" json with + | `String token -> token + | _ -> String.empty + in + Lwt.return (csrf_token, json) module Albatross = Albatross.Make (T) (P) (S) @@ -590,40 +593,26 @@ struct ~icon:"/images/robur.png" ()) `Internal_server_error)) - let update_settings stack store albatross reqd _user = - decode_request_body reqd >>= fun data -> - let json = - try Ok (Yojson.Basic.from_string data) - with Yojson.Json_error s -> Error (`Msg s) - in - match json with + let update_settings json stack store albatross reqd _user = + match Configuration.of_json_from_http json (Ptime.v (P.now_d_ps ())) with + | Ok configuration_settings -> ( + Store.update_configuration !store configuration_settings >>= function + | Ok store' -> + store := store'; + Albatross.init stack configuration_settings.server_ip + ~port:configuration_settings.server_port + configuration_settings.certificate + configuration_settings.private_key + >>= fun new_albatross -> + albatross := new_albatross; + Middleware.http_response reqd ~title:"Success" + ~data:"Configuration updated successfully" `OK + | Error (`Msg err) -> + Middleware.http_response reqd ~title:"Error" + ~data:(String.escaped err) `Internal_server_error) | Error (`Msg err) -> - Logs.warn (fun m -> m "Failed to parse JSON: %s" err); - Middleware.http_response reqd ~title:"Error" ~data:(String.escaped err) + Middleware.http_response ~title:"Error" ~data:(String.escaped err) reqd `Bad_request - | Ok json -> ( - match - Configuration.of_json_from_http json (Ptime.v (P.now_d_ps ())) - with - | Ok configuration_settings -> ( - Store.update_configuration !store configuration_settings - >>= function - | Ok store' -> - store := store'; - Albatross.init stack configuration_settings.server_ip - ~port:configuration_settings.server_port - configuration_settings.certificate - configuration_settings.private_key - >>= fun new_albatross -> - albatross := new_albatross; - Middleware.http_response reqd ~title:"Success" - ~data:"Configuration updated successfully" `OK - | Error (`Msg err) -> - Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped err) `Internal_server_error) - | Error (`Msg err) -> - Middleware.http_response ~title:"Error" ~data:(String.escaped err) - reqd `Bad_request) let deploy_form store reqd (user : User_model.user) = let now = Ptime.v (P.now_d_ps ()) in @@ -730,40 +719,29 @@ struct ~icon:"/images/robur.png" ()) `Internal_server_error) - let unikernel_destroy albatross reqd (user : User_model.user) = + let unikernel_destroy json albatross reqd (user : User_model.user) = (* TODO use uuid in the future *) - decode_request_body reqd >>= fun data -> - let json = - try Ok (Yojson.Basic.from_string data) - with Yojson.Json_error s -> Error (`Msg s) + let unikernel_name = + Yojson.Basic.(to_string (json |> Util.member "name")) in - match json with - | Error (`Msg err) -> - Logs.err (fun m -> m "Failed to parse JSON: %s" err); - Middleware.http_response reqd ~title:"Error" ~data:(String.escaped err) - `Bad_request - | Ok json -> ( - let unikernel_name = - Yojson.Basic.(to_string (json |> Util.member "name")) - in - Albatross.query albatross ~domain:user.name ~name:unikernel_name - (`Unikernel_cmd `Unikernel_destroy) - >>= function - | Error msg -> - Logs.err (fun m -> m "Error querying albatross: %s" msg); + Albatross.query albatross ~domain:user.name ~name:unikernel_name + (`Unikernel_cmd `Unikernel_destroy) + >>= function + | Error msg -> + Logs.err (fun m -> m "Error querying albatross: %s" msg); + Middleware.http_response reqd ~title:"Error" + ~data:("Error querying albatross: " ^ msg) + `Internal_server_error + | Ok (_hdr, res) -> ( + match Albatross_json.res res with + | Ok res -> + Middleware.http_response reqd ~title:"Success" + ~data:(Yojson.Safe.to_string res) + `OK + | Error (`String res) -> Middleware.http_response reqd ~title:"Error" - ~data:("Error querying albatross: " ^ msg) - `Internal_server_error - | Ok (_hdr, res) -> ( - match Albatross_json.res res with - | Ok res -> - Middleware.http_response reqd ~title:"Success" - ~data:(Yojson.Safe.to_string res) - `OK - | Error (`String res) -> - Middleware.http_response reqd ~title:"Error" - ~data:(Yojson.Safe.to_string (`String res)) - `Internal_server_error)) + ~data:(Yojson.Safe.to_string (`String res)) + `Internal_server_error) let unikernel_create albatross reqd (user : User_model.user) = let response_body = Httpaf.Reqd.request_body reqd in @@ -1021,77 +999,62 @@ struct ~icon:"/images/robur.png" ()) `Not_found) - let update_policy store albatross reqd _user = - decode_request_body reqd >>= fun data -> - let json = - try Ok (Yojson.Basic.from_string data) - with Yojson.Json_error s -> Error (`Msg s) + let update_policy json store albatross reqd _user = + let user_uuid = + Yojson.Basic.(to_string (json |> Util.member "user_uuid")) in - match json with - | Error (`Msg err) -> - Logs.err (fun m -> m "Failed to parse JSON: %s" err); - Middleware.http_response reqd ~title:"Error" ~data:(String.escaped err) - `Bad_request - | Ok json -> ( - let user_uuid = - Yojson.Basic.(to_string (json |> Util.member "user_uuid")) - in - let users = User_model.create_user_uuid_map (snd store).Storage.users in - match - User_model.find_user_by_key (Utils.Json.clean_string user_uuid) users - with - | Some u -> ( - match Albatross_json.policy_of_json json with - | Ok policy -> ( - match Albatross.policy albatross with - | Ok (Some root_policy) -> ( - match - Vmm_core.Policy.is_smaller ~super:root_policy ~sub:policy - with - | Error (`Msg err) -> + let users = User_model.create_user_uuid_map (snd store).Storage.users in + match + User_model.find_user_by_key (Utils.Json.clean_string user_uuid) users + with + | Some u -> ( + match Albatross_json.policy_of_json json with + | Ok policy -> ( + match Albatross.policy albatross with + | Ok (Some root_policy) -> ( + match + Vmm_core.Policy.is_smaller ~super:root_policy ~sub:policy + with + | Error (`Msg err) -> + Logs.err (fun m -> + m "policy %a is not smaller than root policy %a: %s" + Vmm_core.Policy.pp policy Vmm_core.Policy.pp + root_policy err); + Middleware.http_response reqd ~title:"Error" + ~data:("policy is not smaller than root policy: " ^ err) + `Internal_server_error + | Ok () -> ( + Albatross.set_policy albatross ~domain:u.name policy + >>= function + | Error err -> Logs.err (fun m -> - m "policy %a is not smaller than root policy %a: %s" - Vmm_core.Policy.pp policy Vmm_core.Policy.pp - root_policy err); + m "error setting policy %a for %s: %s" + Vmm_core.Policy.pp policy u.name err); Middleware.http_response reqd ~title:"Error" - ~data: - ("policy is not smaller than root policy: " ^ err) + ~data:("error setting policy: " ^ err) `Internal_server_error - | Ok () -> ( - Albatross.set_policy albatross ~domain:u.name policy - >>= function - | Error err -> - Logs.err (fun m -> - m "error setting policy %a for %s: %s" - Vmm_core.Policy.pp policy u.name err); - Middleware.http_response reqd ~title:"Error" - ~data:("error setting policy: " ^ err) - `Internal_server_error - | Ok policy -> - Middleware.http_response reqd ~title:"Success" - ~data: - (Yojson.Basic.to_string - (Albatross_json.policy_info policy)) - `OK)) - | Ok None -> - Logs.err (fun m -> m "policy: root policy can't be null "); - Middleware.http_response reqd ~title:"Error" - ~data:"root policy is null" `Internal_server_error - | Error err -> - Logs.err (fun m -> - m - "policy: an error occured while fetching root \ - policy: %s" - err); - Middleware.http_response reqd ~title:"Error" - ~data:("error with root policy: " ^ err) - `Internal_server_error) - | Error (`Msg err) -> - Middleware.http_response reqd ~title:"Error" ~data:err - `Bad_request) - | None -> - Middleware.http_response reqd ~title:"Error" ~data:"User not found" - `Not_found) + | Ok policy -> + Middleware.http_response reqd ~title:"Success" + ~data: + (Yojson.Basic.to_string + (Albatross_json.policy_info policy)) + `OK)) + | Ok None -> + Logs.err (fun m -> m "policy: root policy can't be null "); + Middleware.http_response reqd ~title:"Error" + ~data:"root policy is null" `Internal_server_error + | Error err -> + Logs.err (fun m -> + m "policy: an error occured while fetching root policy: %s" + err); + Middleware.http_response reqd ~title:"Error" + ~data:("error with root policy: " ^ err) + `Internal_server_error) + | Error (`Msg err) -> + Middleware.http_response reqd ~title:"Error" ~data:err `Bad_request) + | None -> + Middleware.http_response reqd ~title:"Error" ~data:"User not found" + `Not_found let request_handler stack albatross js_file css_file imgs store (_ipaddr, _port) reqd = @@ -1182,25 +1145,25 @@ struct authenticate ~check_admin:true !store reqd (settings store reqd)) | "/api/admin/settings/update" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= fun form_csrf -> + extract_csrf_token reqd >>= fun (form_csrf, json) -> authenticate ~check_admin:true ~check_csrf:true ~form_csrf ~api_meth:true !store reqd - (update_settings stack store albatross reqd)) + (update_settings json stack store albatross reqd)) | "/api/admin/u/policy/update" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= fun form_csrf -> + extract_csrf_token reqd >>= fun (form_csrf, json) -> authenticate ~check_admin:true ~check_csrf:true ~form_csrf ~api_meth:true !store reqd - (update_policy !store !albatross reqd)) + (update_policy json !store !albatross reqd)) | "/api/admin/user/activate/toggle" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= fun form_csrf -> + extract_csrf_token reqd >>= fun (form_csrf, _json) -> authenticate ~check_admin:true ~check_csrf:true ~form_csrf ~api_meth:true !store reqd (toggle_account_activation store reqd)) | "/api/admin/user/admin/toggle" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= fun form_csrf -> + extract_csrf_token reqd >>= fun (form_csrf, _json) -> authenticate ~check_admin:true ~check_csrf:true ~form_csrf ~api_meth:true !store reqd (toggle_admin_activation store reqd)) @@ -1222,9 +1185,9 @@ struct authenticate !store reqd (deploy_form store reqd)) | "/unikernel/destory" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= fun form_csrf -> + extract_csrf_token reqd >>= fun (form_csrf, json) -> authenticate !store reqd ~check_csrf:true ~form_csrf - (unikernel_destroy !albatross reqd)) + (unikernel_destroy json !albatross reqd)) | path when String.( length path >= 19 && sub path 0 19 = "/unikernel/console/") -> From 1bd032f884a78e73ebef8c2c0dba142e20ea79c3 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Tue, 15 Oct 2024 09:44:09 +0200 Subject: [PATCH 10/23] fix cookie token bug --- middleware.ml | 15 +++++++++++---- unikernel.ml | 14 ++++++-------- 2 files changed, 17 insertions(+), 12 deletions(-) diff --git a/middleware.ml b/middleware.ml index 2ab09ea6..8deb7476 100644 --- a/middleware.ml +++ b/middleware.ml @@ -15,8 +15,10 @@ let has_cookie cookie_name (reqd : Httpaf.Reqd.t) = List.find_opt (fun cookie -> let parts = String.trim cookie |> String.split_on_char '=' in + match parts with - | [ name; _ ] -> String.equal name cookie_name + | [ name; _ ] -> + String.equal name cookie_name | _ -> false) cookie_list | _ -> None @@ -117,13 +119,13 @@ let http_response ~title ?(header_list = []) ?(data = "") reqd http_status = Httpaf.Reqd.respond_with_string reqd response data; Lwt.return_unit -let cookie_value_from_auth_cookie cookie = +let cookie_value_from_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 + match cookie_value_from_cookie cookie with | Ok cookie_value -> ( match User_model.find_user_by_key cookie_value users with | Some user -> Ok user @@ -192,7 +194,12 @@ let csrf_match ~input_csrf ~check_csrf = let csrf_cookie_verification form_csrf reqd = match has_cookie "molly_csrf" reqd with - | Some cookie -> csrf_match ~input_csrf:form_csrf ~check_csrf:cookie + | Some cookie -> ( + match cookie_value_from_cookie cookie with + | Ok token -> csrf_match ~input_csrf:form_csrf ~check_csrf:token + | Error (`Msg err) -> + Logs.err (fun m -> m "Error with csrf cookie %s" err); + false) | None -> false let csrf_verification users now form_csrf handler reqd = diff --git a/unikernel.ml b/unikernel.ml index 765f3755..24e80fe6 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -185,13 +185,11 @@ struct let sign_up reqd = let now = Ptime.v (P.now_d_ps ()) in let csrf = Middleware.get_csrf now () in + let csrf_cookie = csrf.name ^ "=" ^ csrf.value ^ ";Path=/;HttpOnly=true" in match Middleware.has_cookie "molly_session" reqd with | Some cookie -> ( - match Middleware.cookie_value_from_auth_cookie cookie with + match Middleware.cookie_value_from_cookie cookie with | Ok "" -> - let csrf_cookie = - csrf.name ^ "=" ^ csrf.value ^ ";Path=/sign-up;HttpOnly=true" - in Lwt.return (reply reqd ~content_type:"text/html" (Sign_up.register_page csrf.value ~icon:"/images/robur.png" ()) @@ -203,12 +201,14 @@ struct Lwt.return (reply reqd ~content_type:"text/html" (Sign_up.register_page csrf.value ~icon:"/images/robur.png" ()) + ~header_list: + [ ("Set-Cookie", csrf_cookie); ("X-MOLLY-CSRF", csrf.value) ] `OK) let sign_in reqd = match Middleware.has_cookie "molly_session" reqd with | Some cookie -> ( - match Middleware.cookie_value_from_auth_cookie cookie with + match Middleware.cookie_value_from_cookie cookie with | Ok "" -> Lwt.return (reply reqd ~content_type:"text/html" @@ -256,9 +256,7 @@ struct json |> Yojson.Basic.Util.member "password" |> Yojson.Basic.to_string in let form_csrf = - json - |> Yojson.Basic.Util.member "csrf_token" - |> Yojson.Basic.to_string + json |> Yojson.Basic.Util.member "form_csrf" |> Yojson.Basic.to_string in match validate_user_input ~name ~email ~password ~form_csrf with | Error err -> From 7c1dd9af73386b2731d9c6379a795ab4ecb4323b Mon Sep 17 00:00:00 2001 From: PizieDust Date: Tue, 15 Oct 2024 09:44:19 +0200 Subject: [PATCH 11/23] lint --- middleware.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/middleware.ml b/middleware.ml index 8deb7476..c714418b 100644 --- a/middleware.ml +++ b/middleware.ml @@ -17,8 +17,7 @@ let has_cookie cookie_name (reqd : Httpaf.Reqd.t) = let parts = String.trim cookie |> String.split_on_char '=' in match parts with - | [ name; _ ] -> - String.equal name cookie_name + | [ name; _ ] -> String.equal name cookie_name | _ -> false) cookie_list | _ -> None From 929b9676d63d4dcc20b3e69d67c8328b9bd024ec Mon Sep 17 00:00:00 2001 From: PixieDust <111846546+PizieDust@users.noreply.github.com> Date: Tue, 15 Oct 2024 11:21:40 +0200 Subject: [PATCH 12/23] Update middleware.ml Co-authored-by: Hannes Mehnert --- middleware.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/middleware.ml b/middleware.ml index c714418b..ac6ed7cf 100644 --- a/middleware.ml +++ b/middleware.ml @@ -199,7 +199,9 @@ let csrf_cookie_verification form_csrf reqd = | Error (`Msg err) -> Logs.err (fun m -> m "Error with csrf cookie %s" err); false) - | None -> false + | None -> + Logs.err (fun m -> m "Couldn't find csrf cookie."); + false let csrf_verification users now form_csrf handler reqd = match user_of_cookie users now reqd with From d223a1f680701952e2ad10a7dde54b2d1f3d818f Mon Sep 17 00:00:00 2001 From: PixieDust <111846546+PizieDust@users.noreply.github.com> Date: Tue, 15 Oct 2024 11:21:47 +0200 Subject: [PATCH 13/23] Update middleware.ml Co-authored-by: Hannes Mehnert --- middleware.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/middleware.ml b/middleware.ml index ac6ed7cf..1dfbc963 100644 --- a/middleware.ml +++ b/middleware.ml @@ -15,7 +15,6 @@ let has_cookie cookie_name (reqd : Httpaf.Reqd.t) = List.find_opt (fun cookie -> let parts = String.trim cookie |> String.split_on_char '=' in - match parts with | [ name; _ ] -> String.equal name cookie_name | _ -> false) From 0aee9ff872b51bd2826ee92ce2e6772ff5004a23 Mon Sep 17 00:00:00 2001 From: PixieDust <111846546+PizieDust@users.noreply.github.com> Date: Tue, 15 Oct 2024 11:22:02 +0200 Subject: [PATCH 14/23] Update middleware.ml Co-authored-by: Hannes Mehnert --- middleware.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/middleware.ml b/middleware.ml index 1dfbc963..9f447a20 100644 --- a/middleware.ml +++ b/middleware.ml @@ -196,7 +196,7 @@ let csrf_cookie_verification form_csrf reqd = match cookie_value_from_cookie cookie with | Ok token -> csrf_match ~input_csrf:form_csrf ~check_csrf:token | Error (`Msg err) -> - Logs.err (fun m -> m "Error with csrf cookie %s" err); + Logs.err (fun m -> m "Error retrieving csrf value from cookie %s" err); false) | None -> Logs.err (fun m -> m "Couldn't find csrf cookie."); From 641b6812d6b081ea5ac874444eae9ebf6b6cbe5e Mon Sep 17 00:00:00 2001 From: PixieDust <111846546+PizieDust@users.noreply.github.com> Date: Tue, 15 Oct 2024 11:22:17 +0200 Subject: [PATCH 15/23] Update middleware.ml Co-authored-by: Hannes Mehnert --- middleware.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/middleware.ml b/middleware.ml index 9f447a20..5c0b4f82 100644 --- a/middleware.ml +++ b/middleware.ml @@ -223,6 +223,6 @@ let csrf_verification users now form_csrf handler reqd = reqd `Bad_request | None -> http_response - ~data:"CSRF token mismatch error. Please referesh and try again." - ~title:"CSRF Token Mismatch" reqd `Bad_request) + ~data:"Missing CSRF token. Please referesh and try again." + ~title:"Missing CSRF Token" reqd `Bad_request) | Error (`Msg err) -> redirect_to_login ~msg:err reqd () From 852fd2c2c0307c421aa16f5b9b3828d9ce31bd54 Mon Sep 17 00:00:00 2001 From: Auto-OCamlformat Date: Tue, 15 Oct 2024 09:25:10 +0000 Subject: [PATCH 16/23] formatted code --- middleware.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/middleware.ml b/middleware.ml index 5c0b4f82..6395f1c5 100644 --- a/middleware.ml +++ b/middleware.ml @@ -198,9 +198,9 @@ let csrf_cookie_verification form_csrf reqd = | Error (`Msg err) -> Logs.err (fun m -> m "Error retrieving csrf value from cookie %s" err); false) - | None -> - Logs.err (fun m -> m "Couldn't find csrf cookie."); - false + | None -> + Logs.err (fun m -> m "Couldn't find csrf cookie."); + false let csrf_verification users now form_csrf handler reqd = match user_of_cookie users now reqd with From 2c02a25628a10b80eb6e16a89cbd56348f38d957 Mon Sep 17 00:00:00 2001 From: PixieDust <111846546+PizieDust@users.noreply.github.com> Date: Tue, 15 Oct 2024 11:29:39 +0200 Subject: [PATCH 17/23] Update unikernel.ml Co-authored-by: Hannes Mehnert --- unikernel.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index 24e80fe6..14b69424 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -103,11 +103,10 @@ struct let extract_csrf_token reqd = decode_request_body reqd >>= fun data -> - let json = + match try Ok (Yojson.Basic.from_string data) with Yojson.Json_error s -> Error (`Msg s) - in - match json with + with | Error (`Msg err) -> Logs.warn (fun m -> m "Failed to parse JSON: %s" err); Lwt.return (String.empty, `Null) From 0739d36b2ce7d2cb6dd5489fa2a880f01b3fbf59 Mon Sep 17 00:00:00 2001 From: PixieDust <111846546+PizieDust@users.noreply.github.com> Date: Tue, 15 Oct 2024 11:54:32 +0200 Subject: [PATCH 18/23] Update unikernel.ml Co-authored-by: Hannes Mehnert --- unikernel.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unikernel.ml b/unikernel.ml index 14b69424..395d2daf 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -1180,7 +1180,7 @@ struct | "/unikernel/deploy" -> check_meth `GET (fun () -> authenticate !store reqd (deploy_form store reqd)) - | "/unikernel/destory" -> + | "/unikernel/destroy" -> check_meth `POST (fun () -> extract_csrf_token reqd >>= fun (form_csrf, json) -> authenticate !store reqd ~check_csrf:true ~form_csrf From a142cc076e4ea7ed057539c991b85a88ba60931e Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 16 Oct 2024 11:46:08 +0200 Subject: [PATCH 19/23] refactor: revise generate_csrf_token --- unikernel.ml | 298 +++++++++++++++++++++++---------------------------- 1 file changed, 132 insertions(+), 166 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index 395d2daf..991b4620 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -49,40 +49,26 @@ struct module Store = Storage.Make (BLOCK) module Map = Map.Make (String) - let generate_csrf_token ?(update_user = false) ?(user = None) store now = - if update_user then - match user with - | Some u -> ( - let csrf = Middleware.get_csrf now () in - let updated_user = - User_model.update_user u ~updated_at:now - ~cookies:(csrf :: u.cookies) () - in - Store.update_user !store updated_user >>= function - | Ok store' -> - store := store'; - Lwt.return (Ok csrf.value) - | Error (`Msg err) -> - let error = - { - Utils.Status.code = 500; - title = "CSRF Token Error"; - success = false; - data = err; - } - in - Lwt.return (Error error)) - | None -> - let error = - { - Utils.Status.code = 500; - title = "CSRF Token Error"; - success = false; - data = "Error generating csrf. No user"; - } - in - Lwt.return (Error error) - else Lwt.return (Ok (Middleware.get_csrf now ()).value) + let generate_csrf_token store user now = + let csrf = Middleware.get_csrf now () in + let updated_user = + User_model.update_user user ~updated_at:now + ~cookies:(csrf :: user.cookies) () + in + Store.update_user !store updated_user >>= function + | Ok store' -> + store := store'; + Lwt.return (Ok csrf.value) + | Error (`Msg err) -> + let error = + { + Utils.Status.code = 500; + title = "CSRF Token Error"; + success = false; + data = err; + } + in + Lwt.return (Error error) let decode_request_body reqd = let request_body = Httpaf.Reqd.request_body reqd in @@ -403,29 +389,25 @@ struct let verify_email store reqd user = let now = Ptime.v (P.now_d_ps ()) in - generate_csrf_token ~update_user:true ~user:(Some user) store now - >>= function - | csrf -> ( - match csrf with - | Ok csrf -> - let email_verification_uuid = User_model.generate_uuid () in - let verification_link = - Utils.Email.generate_verification_link email_verification_uuid - in - Logs.info (fun m -> m "Verification link is: %s" verification_link); - Lwt.return - (reply reqd ~content_type:"text/html" - (Verify_email.verify_page user csrf ~icon:"/images/robur.png" - ()) - ~header_list:[ ("X-MOLLY-CSRF", csrf) ] - `OK) - | Error err -> - Lwt.return - (reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user ~page_title:"500 | Mollymawk" - ~content:(Error_page.error_layout err) - ~icon:"/images/robur.png" ()) - `Internal_server_error)) + generate_csrf_token store user now >>= function + | Ok csrf -> + let email_verification_uuid = User_model.generate_uuid () in + let verification_link = + Utils.Email.generate_verification_link email_verification_uuid + in + Logs.info (fun m -> m "Verification link is: %s" verification_link); + Lwt.return + (reply reqd ~content_type:"text/html" + (Verify_email.verify_page user csrf ~icon:"/images/robur.png" ()) + ~header_list:[ ("X-MOLLY-CSRF", csrf) ] + `OK) + | Error err -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user ~page_title:"500 | Mollymawk" + ~content:(Error_page.error_layout err) + ~icon:"/images/robur.png" ()) + `Internal_server_error) let verify_email_token store reqd verification_token (user : User_model.user) = @@ -567,28 +549,24 @@ struct let settings store reqd user = let now = Ptime.v (P.now_d_ps ()) in - generate_csrf_token ~update_user:true ~user:(Some user) store now - >>= function - | csrf -> ( - match csrf with - | Ok csrf -> - Lwt.return - (reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user - ~page_title:"Settings | Mollymawk" - ~content: - (Settings_page.settings_layout - (snd !store).Storage.configuration csrf) - ~icon:"/images/robur.png" ()) - ~header_list:[ ("X-MOLLY-CSRF", csrf) ] - `OK) - | Error err -> - Lwt.return - (reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user ~page_title:"500 | Mollymawk" - ~content:(Error_page.error_layout err) - ~icon:"/images/robur.png" ()) - `Internal_server_error)) + generate_csrf_token store user now >>= function + | Ok csrf -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user ~page_title:"Settings | Mollymawk" + ~content: + (Settings_page.settings_layout + (snd !store).Storage.configuration csrf) + ~icon:"/images/robur.png" ()) + ~header_list:[ ("X-MOLLY-CSRF", csrf) ] + `OK) + | Error err -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user ~page_title:"500 | Mollymawk" + ~content:(Error_page.error_layout err) + ~icon:"/images/robur.png" ()) + `Internal_server_error) let update_settings json stack store albatross reqd _user = match Configuration.of_json_from_http json (Ptime.v (P.now_d_ps ())) with @@ -613,26 +591,23 @@ struct let deploy_form store reqd (user : User_model.user) = let now = Ptime.v (P.now_d_ps ()) in - generate_csrf_token ~update_user:true ~user:(Some user) store now - >>= function - | csrf -> ( - match csrf with - | Ok csrf -> - Lwt.return - (reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user - ~page_title:"Deploy a Unikernel | Mollymawk" - ~content:(Unikernel_create.unikernel_create_layout csrf) - ~icon:"/images/robur.png" ()) - ~header_list:[ ("X-MOLLY-CSRF", csrf) ] - `OK) - | Error err -> - Lwt.return - (reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user ~page_title:"500 | Mollymawk" - ~content:(Error_page.error_layout err) - ~icon:"/images/robur.png" ()) - `Internal_server_error)) + generate_csrf_token store user now >>= function + | Ok csrf -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user + ~page_title:"Deploy a Unikernel | Mollymawk" + ~content:(Unikernel_create.unikernel_create_layout csrf) + ~icon:"/images/robur.png" ()) + ~header_list:[ ("X-MOLLY-CSRF", csrf) ] + `OK) + | Error err -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user ~page_title:"500 | Mollymawk" + ~content:(Error_page.error_layout err) + ~icon:"/images/robur.png" ()) + `Internal_server_error) let unikernel_info albatross reqd (user : User_model.user) = (* TODO use uuid in the future *) @@ -680,25 +655,24 @@ struct | Ok (_, console_output) -> console_output) >>= fun console_output -> let now = Ptime.v (P.now_d_ps ()) in - generate_csrf_token ~update_user:true ~user:(Some user) store now - >|= function - | csrf -> ( - match csrf with - | Ok csrf -> - reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user - ~content: - (Unikernel_single.unikernel_single_layout - (List.hd unikernels) now console_output csrf) - ~icon:"/images/robur.png" ()) - ~header_list:[ ("X-MOLLY-CSRF", csrf) ] - `OK - | Error err -> - reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user ~page_title:"500 | Mollymawk" - ~content:(Error_page.error_layout err) - ~icon:"/images/robur.png" ()) - `Internal_server_error) + generate_csrf_token store user now >>= function + | Ok csrf -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user + ~content: + (Unikernel_single.unikernel_single_layout + (List.hd unikernels) now console_output csrf) + ~icon:"/images/robur.png" ()) + ~header_list:[ ("X-MOLLY-CSRF", csrf) ] + `OK) + | Error err -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user ~page_title:"500 | Mollymawk" + ~content:(Error_page.error_layout err) + ~icon:"/images/robur.png" ()) + `Internal_server_error) else let error = { @@ -888,30 +862,25 @@ struct | Error _ -> None in let now = Ptime.v (P.now_d_ps ()) in - generate_csrf_token ~update_user:true ~user:(Some user) store now - >>= function - | csrf -> ( - match csrf with - | Ok csrf -> - Lwt.return - (reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user - ~page_title: - (String.capitalize_ascii u.name ^ " | Mollymawk") - ~content: - (User_single.user_single_layout u unikernels policy - now csrf) - ~icon:"/images/robur.png" ()) - ~header_list:[ ("X-MOLLY-CSRF", csrf) ] - `OK) - | Error err -> - Lwt.return - (reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user - ~page_title:"500 | Mollymawk" - ~content:(Error_page.error_layout err) - ~icon:"/images/robur.png" ()) - `Internal_server_error))) + generate_csrf_token store user now >>= function + | Ok csrf -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user + ~page_title:(String.capitalize_ascii u.name ^ " | Mollymawk") + ~content: + (User_single.user_single_layout u unikernels policy now + csrf) + ~icon:"/images/robur.png" ()) + ~header_list:[ ("X-MOLLY-CSRF", csrf) ] + `OK) + | Error err -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user ~page_title:"500 | Mollymawk" + ~content:(Error_page.error_layout err) + ~icon:"/images/robur.png" ()) + `Internal_server_error)) | None -> let status = { @@ -941,30 +910,27 @@ struct match Albatross.policy_resource_avalaible albatross with | Ok unallocated_resources -> ( let now = Ptime.v (P.now_d_ps ()) in - generate_csrf_token ~update_user:true ~user:(Some user) store now - >>= function - | csrf -> ( - match csrf with - | Ok csrf -> - Lwt.return - (reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user - ~page_title: - (String.capitalize_ascii u.name ^ " | Mollymawk") - ~content: - (Update_policy.update_policy_layout u ~user_policy - ~unallocated_resources csrf) - ~icon:"/images/robur.png" ()) - ~header_list:[ ("X-MOLLY-CSRF", csrf) ] - `OK) - | Error err -> - Lwt.return - (reply reqd ~content_type:"text/html" - (Dashboard.dashboard_layout user - ~page_title:"500 | Mollymawk" - ~content:(Error_page.error_layout err) - ~icon:"/images/robur.png" ()) - `Internal_server_error))) + generate_csrf_token store user now >>= function + | Ok csrf -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user + ~page_title: + (String.capitalize_ascii u.name ^ " | Mollymawk") + ~content: + (Update_policy.update_policy_layout u ~user_policy + ~unallocated_resources csrf) + ~icon:"/images/robur.png" ()) + ~header_list:[ ("X-MOLLY-CSRF", csrf) ] + `OK) + | Error err -> + Lwt.return + (reply reqd ~content_type:"text/html" + (Dashboard.dashboard_layout user + ~page_title:"500 | Mollymawk" + ~content:(Error_page.error_layout err) + ~icon:"/images/robur.png" ()) + `Internal_server_error)) | Error err -> let status = { From b4aee8ce9f6f83e3c4b5a760303b6f6c5f0ece52 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 16 Oct 2024 12:21:36 +0200 Subject: [PATCH 20/23] revise authenticate (remove "?check_csrf"), and extract_csrf_token (error handling) --- unikernel.ml | 78 ++++++++++++++++++++++++++++++++-------------------- 1 file changed, 48 insertions(+), 30 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index 991b4620..f762d8bb 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -95,14 +95,11 @@ struct with | Error (`Msg err) -> Logs.warn (fun m -> m "Failed to parse JSON: %s" err); - Lwt.return (String.empty, `Null) - | Ok json -> - let csrf_token = - match Yojson.Basic.Util.member "molly_csrf" json with - | `String token -> token - | _ -> String.empty - in - Lwt.return (csrf_token, json) + Lwt.return (Error (`Msg err)) + | Ok json -> ( + match Yojson.Basic.Util.member "molly_csrf" json with + | `String token -> Lwt.return (Ok (token, json)) + | _ -> Lwt.return (Error (`Msg "Couldn't find CSRF token"))) module Albatross = Albatross.Make (T) (P) (S) @@ -130,7 +127,7 @@ struct go (Map.empty, []) m let authenticate ?(email_verified = true) ?(check_admin = false) - ?(api_meth = false) ?(check_csrf = false) ?(form_csrf = "") store reqd f = + ?(api_meth = false) ?form_csrf store reqd f = 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 @@ -141,8 +138,9 @@ struct @ (if email_verified && false (* TODO *) then [ Middleware.email_verified_middleware now users ] else []) - @ (if check_csrf then [ Middleware.csrf_verification users now form_csrf ] - else []) + @ Option.fold ~none:[] + ~some:(fun csrf -> [ Middleware.csrf_verification users now csrf ]) + form_csrf @ [ Middleware.auth_middleware now users ] in Middleware.apply_middleware middlewares @@ -1108,28 +1106,44 @@ struct authenticate ~check_admin:true !store reqd (settings store reqd)) | "/api/admin/settings/update" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= fun (form_csrf, json) -> - authenticate ~check_admin:true ~check_csrf:true ~form_csrf - ~api_meth:true !store reqd - (update_settings json stack store albatross reqd)) + extract_csrf_token reqd >>= function + | Ok (form_csrf, json) -> + authenticate ~check_admin:true ~form_csrf ~api_meth:true + !store reqd + (update_settings json stack store albatross reqd) + | Error (`Msg msg) -> + Middleware.http_response reqd ~title:"Error" + ~data:(String.escaped msg) `Bad_request) | "/api/admin/u/policy/update" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= fun (form_csrf, json) -> - authenticate ~check_admin:true ~check_csrf:true ~form_csrf - ~api_meth:true !store reqd - (update_policy json !store !albatross reqd)) + extract_csrf_token reqd >>= function + | Ok (form_csrf, json) -> + authenticate ~check_admin:true ~form_csrf ~api_meth:true + !store reqd + (update_policy json !store !albatross reqd) + | Error (`Msg msg) -> + Middleware.http_response reqd ~title:"Error" + ~data:(String.escaped msg) `Bad_request) | "/api/admin/user/activate/toggle" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= fun (form_csrf, _json) -> - authenticate ~check_admin:true ~check_csrf:true ~form_csrf - ~api_meth:true !store reqd - (toggle_account_activation store reqd)) + extract_csrf_token reqd >>= function + | Ok (form_csrf, _json) -> + authenticate ~check_admin:true ~form_csrf ~api_meth:true + !store reqd + (toggle_account_activation store reqd) + | Error (`Msg msg) -> + Middleware.http_response reqd ~title:"Error" + ~data:(String.escaped msg) `Bad_request) | "/api/admin/user/admin/toggle" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= fun (form_csrf, _json) -> - authenticate ~check_admin:true ~check_csrf:true ~form_csrf - ~api_meth:true !store reqd - (toggle_admin_activation store reqd)) + extract_csrf_token reqd >>= function + | Ok (form_csrf, _json) -> + authenticate ~check_admin:true ~form_csrf ~api_meth:true + !store reqd + (toggle_admin_activation store reqd) + | Error (`Msg msg) -> + Middleware.http_response reqd ~title:"Error" + ~data:(String.escaped msg) `Bad_request) | "/api/unikernels" -> check_meth `GET (fun () -> authenticate ~api_meth:true !store reqd @@ -1148,9 +1162,13 @@ struct authenticate !store reqd (deploy_form store reqd)) | "/unikernel/destroy" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= fun (form_csrf, json) -> - authenticate !store reqd ~check_csrf:true ~form_csrf - (unikernel_destroy json !albatross reqd)) + extract_csrf_token reqd >>= function + | Ok (form_csrf, json) -> + authenticate !store reqd ~form_csrf + (unikernel_destroy json !albatross reqd) + | Error (`Msg msg) -> + Middleware.http_response reqd ~title:"Error" + ~data:(String.escaped msg) `Bad_request) | path when String.( length path >= 19 && sub path 0 19 = "/unikernel/console/") -> From 88895ec5c67ddcf431d38903f4cbe8aab7bf4fe6 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 16 Oct 2024 12:29:27 +0200 Subject: [PATCH 21/23] introduce Middleware.session_cookie_value rename cookie_value_from_cookie to cookie_value --- middleware.ml | 15 ++++++++++++--- unikernel.ml | 28 ++++++---------------------- 2 files changed, 18 insertions(+), 25 deletions(-) diff --git a/middleware.ml b/middleware.ml index 6395f1c5..8eaaa674 100644 --- a/middleware.ml +++ b/middleware.ml @@ -117,13 +117,13 @@ let http_response ~title ?(header_list = []) ?(data = "") reqd http_status = Httpaf.Reqd.respond_with_string reqd response data; Lwt.return_unit -let cookie_value_from_cookie cookie = +let cookie_value 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_cookie cookie with + match cookie_value cookie with | Ok cookie_value -> ( match User_model.find_user_by_key cookie_value users with | Some user -> Ok user @@ -162,6 +162,15 @@ let user_of_cookie users now reqd = m "auth-middleware: No molly-session in cookie header."); Error (`Msg "User not found") +let session_cookie_value reqd = + match has_cookie "molly_session" reqd with + | Some cookie -> ( + match cookie_value cookie with + | Ok "" -> Ok None + | Ok x -> Ok (Some x) + | Error _ as e -> e) + | None -> Error (`Msg "no cookie found") + let auth_middleware now users handler reqd = match user_of_cookie users now reqd with | Ok user -> @@ -193,7 +202,7 @@ let csrf_match ~input_csrf ~check_csrf = let csrf_cookie_verification form_csrf reqd = match has_cookie "molly_csrf" reqd with | Some cookie -> ( - match cookie_value_from_cookie cookie with + match cookie_value cookie with | Ok token -> csrf_match ~input_csrf:form_csrf ~check_csrf:token | Error (`Msg err) -> Logs.err (fun m -> m "Error retrieving csrf value from cookie %s" err); diff --git a/unikernel.ml b/unikernel.ml index f762d8bb..35722812 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -169,18 +169,9 @@ struct let now = Ptime.v (P.now_d_ps ()) in let csrf = Middleware.get_csrf now () in let csrf_cookie = csrf.name ^ "=" ^ csrf.value ^ ";Path=/;HttpOnly=true" in - match Middleware.has_cookie "molly_session" reqd with - | Some cookie -> ( - match Middleware.cookie_value_from_cookie cookie with - | Ok "" -> - Lwt.return - (reply reqd ~content_type:"text/html" - (Sign_up.register_page csrf.value ~icon:"/images/robur.png" ()) - ~header_list: - [ ("Set-Cookie", csrf_cookie); ("X-MOLLY-CSRF", csrf.value) ] - `OK) - | _ -> Middleware.redirect_to_dashboard reqd ()) - | None -> + match Middleware.session_cookie_value reqd with + | Ok (Some x) -> Middleware.redirect_to_dashboard reqd () + | Ok None | Error (`Msg _) -> Lwt.return (reply reqd ~content_type:"text/html" (Sign_up.register_page csrf.value ~icon:"/images/robur.png" ()) @@ -189,16 +180,9 @@ struct `OK) let sign_in reqd = - match Middleware.has_cookie "molly_session" reqd with - | Some cookie -> ( - match Middleware.cookie_value_from_cookie cookie with - | Ok "" -> - Lwt.return - (reply reqd ~content_type:"text/html" - (Sign_in.login_page ~icon:"/images/robur.png" ()) - `OK) - | _ -> Middleware.redirect_to_dashboard reqd ()) - | None -> + match Middleware.session_cookie_value reqd with + | Ok (Some _) -> Middleware.redirect_to_dashboard reqd () + | Ok None | Error (`Msg _) -> Lwt.return (reply reqd ~content_type:"text/html" (Sign_in.login_page ~icon:"/images/robur.png" ()) From eedc956877f53b02d7411dfe909d66f2f26e7335 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 16 Oct 2024 12:35:16 +0200 Subject: [PATCH 22/23] use a labeled argument ~csrf for the individual pages --- settings_page.ml | 2 +- sign_up.ml | 2 +- unikernel.ml | 22 +++++++++++----------- unikernel_create.ml | 2 +- unikernel_single.ml | 2 +- update_policy.ml | 4 ++-- user_single.ml | 4 ++-- verify_email.ml | 2 +- 8 files changed, 20 insertions(+), 20 deletions(-) diff --git a/settings_page.ml b/settings_page.ml index a27f34a2..546b0fbc 100644 --- a/settings_page.ml +++ b/settings_page.ml @@ -1,4 +1,4 @@ -let settings_layout (configuration : Configuration.t) csrf = +let settings_layout ~csrf (configuration : Configuration.t) = let ip = Ipaddr.to_string configuration.server_ip in let port = string_of_int configuration.server_port in let certificate = X509.Certificate.encode_pem configuration.certificate in diff --git a/sign_up.ml b/sign_up.ml index 462a4c67..20f23d9c 100644 --- a/sign_up.ml +++ b/sign_up.ml @@ -1,6 +1,6 @@ open Tyxml -let register_page csrf ~icon () = +let register_page ~csrf ~icon = let page = Html.( html diff --git a/unikernel.ml b/unikernel.ml index 35722812..3f4027ca 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -174,7 +174,7 @@ struct | Ok None | Error (`Msg _) -> Lwt.return (reply reqd ~content_type:"text/html" - (Sign_up.register_page csrf.value ~icon:"/images/robur.png" ()) + (Sign_up.register_page ~csrf:csrf.value ~icon:"/images/robur.png") ~header_list: [ ("Set-Cookie", csrf_cookie); ("X-MOLLY-CSRF", csrf.value) ] `OK) @@ -380,7 +380,7 @@ struct Logs.info (fun m -> m "Verification link is: %s" verification_link); Lwt.return (reply reqd ~content_type:"text/html" - (Verify_email.verify_page user csrf ~icon:"/images/robur.png" ()) + (Verify_email.verify_page user ~csrf ~icon:"/images/robur.png") ~header_list:[ ("X-MOLLY-CSRF", csrf) ] `OK) | Error err -> @@ -537,8 +537,8 @@ struct (reply reqd ~content_type:"text/html" (Dashboard.dashboard_layout user ~page_title:"Settings | Mollymawk" ~content: - (Settings_page.settings_layout - (snd !store).Storage.configuration csrf) + (Settings_page.settings_layout ~csrf + (snd !store).Storage.configuration) ~icon:"/images/robur.png" ()) ~header_list:[ ("X-MOLLY-CSRF", csrf) ] `OK) @@ -579,7 +579,7 @@ struct (reply reqd ~content_type:"text/html" (Dashboard.dashboard_layout user ~page_title:"Deploy a Unikernel | Mollymawk" - ~content:(Unikernel_create.unikernel_create_layout csrf) + ~content:(Unikernel_create.unikernel_create_layout ~csrf) ~icon:"/images/robur.png" ()) ~header_list:[ ("X-MOLLY-CSRF", csrf) ] `OK) @@ -643,8 +643,8 @@ struct (reply reqd ~content_type:"text/html" (Dashboard.dashboard_layout user ~content: - (Unikernel_single.unikernel_single_layout - (List.hd unikernels) now console_output csrf) + (Unikernel_single.unikernel_single_layout ~csrf + (List.hd unikernels) now console_output) ~icon:"/images/robur.png" ()) ~header_list:[ ("X-MOLLY-CSRF", csrf) ] `OK) @@ -851,8 +851,8 @@ struct (Dashboard.dashboard_layout user ~page_title:(String.capitalize_ascii u.name ^ " | Mollymawk") ~content: - (User_single.user_single_layout u unikernels policy now - csrf) + (User_single.user_single_layout ~csrf u unikernels policy + now) ~icon:"/images/robur.png" ()) ~header_list:[ ("X-MOLLY-CSRF", csrf) ] `OK) @@ -900,8 +900,8 @@ struct ~page_title: (String.capitalize_ascii u.name ^ " | Mollymawk") ~content: - (Update_policy.update_policy_layout u ~user_policy - ~unallocated_resources csrf) + (Update_policy.update_policy_layout ~csrf u + ~user_policy ~unallocated_resources) ~icon:"/images/robur.png" ()) ~header_list:[ ("X-MOLLY-CSRF", csrf) ] `OK) diff --git a/unikernel_create.ml b/unikernel_create.ml index c378c4e4..0b9af4dc 100644 --- a/unikernel_create.ml +++ b/unikernel_create.ml @@ -1,4 +1,4 @@ -let unikernel_create_layout csrf = +let unikernel_create_layout ~csrf = Tyxml_html.( section ~a:[ a_class [ "col-span-7 p-4 bg-gray-50 my-1" ] ] diff --git a/unikernel_single.ml b/unikernel_single.ml index 604bcc0f..3608f830 100644 --- a/unikernel_single.ml +++ b/unikernel_single.ml @@ -1,4 +1,4 @@ -let unikernel_single_layout unikernel now console_output csrf = +let unikernel_single_layout ~csrf unikernel now console_output = let u_name, data = unikernel in Tyxml_html.( section diff --git a/update_policy.ml b/update_policy.ml index 0aaa005c..50edcceb 100644 --- a/update_policy.ml +++ b/update_policy.ml @@ -1,5 +1,5 @@ -let update_policy_layout (user : User_model.user) ~user_policy - ~unallocated_resources csrf = +let update_policy_layout ~csrf (user : User_model.user) ~user_policy + ~unallocated_resources = Tyxml_html.( section ~a:[ a_id "policy-form" ] diff --git a/user_single.ml b/user_single.ml index 024c96bb..3032465b 100644 --- a/user_single.ml +++ b/user_single.ml @@ -1,5 +1,5 @@ -let user_single_layout (user : User_model.user) unikernels policy current_time - csrf = +let user_single_layout ~csrf (user : User_model.user) unikernels policy + current_time = Tyxml_html.( section ~a:[ a_class [ "p-4 bg-gray-50 my-1" ] ] diff --git a/verify_email.ml b/verify_email.ml index 156a38e8..59974cf7 100644 --- a/verify_email.ml +++ b/verify_email.ml @@ -1,6 +1,6 @@ open Tyxml -let verify_page ~icon (user : User_model.user) csrf () = +let verify_page ~csrf ~icon (user : User_model.user) = let page = Html.( html From 883b2bd200f52df40d20035f3fba02879dbf4f93 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 16 Oct 2024 12:40:10 +0200 Subject: [PATCH 23/23] update user with email_verification_uuid again --- unikernel.ml | 29 ++++++++++++++++++++--------- 1 file changed, 20 insertions(+), 9 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index 3f4027ca..dad32f36 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -372,17 +372,28 @@ struct let verify_email store reqd user = let now = Ptime.v (P.now_d_ps ()) in generate_csrf_token store user now >>= function - | Ok csrf -> + | Ok csrf -> ( let email_verification_uuid = User_model.generate_uuid () in - let verification_link = - Utils.Email.generate_verification_link email_verification_uuid + let updated_user = + User_model.update_user user + ~updated_at:(Ptime.v (P.now_d_ps ())) + ~email_verification_uuid:(Some email_verification_uuid) () in - Logs.info (fun m -> m "Verification link is: %s" verification_link); - Lwt.return - (reply reqd ~content_type:"text/html" - (Verify_email.verify_page user ~csrf ~icon:"/images/robur.png") - ~header_list:[ ("X-MOLLY-CSRF", csrf) ] - `OK) + 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); + Lwt.return + (reply reqd ~content_type:"text/html" + (Verify_email.verify_page user ~csrf ~icon:"/images/robur.png") + ~header_list:[ ("X-MOLLY-CSRF", csrf) ] + `OK) + | Error (`Msg err) -> + Middleware.http_response reqd ~title:"Error" + ~data:(String.escaped err) `Internal_server_error) | Error err -> Lwt.return (reply reqd ~content_type:"text/html"