diff --git a/assets/main.js b/assets/main.js
index 40ebad8f..d1aec851 100644
--- a/assets/main.js
+++ b/assets/main.js
@@ -83,8 +83,10 @@ 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 = ``
+ formButton.innerHTML = `Processing `
+ formButton.disabled = true;
if (ipInput === '' || portInput === '' || certificateInput === '' || pkeyInput === '') {
formAlert.classList.remove("hidden");
formAlert.classList.add("text-secondary-500");
@@ -96,7 +98,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) {
@@ -119,6 +127,7 @@ async function saveConfig() {
}
}
formButton.innerHTML = "Update"
+ formButton.disabled = false;
}
function closeBanner() {
@@ -146,6 +155,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 +168,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 +202,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 +239,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 +297,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 +312,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();
diff --git a/middleware.ml b/middleware.ml
index 004fac84..8eaaa674 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,13 +98,32 @@ let redirect_to_dashboard reqd ?(msg = "") () =
Httpaf.Reqd.respond_with_string reqd response msg;
Lwt.return_unit
-let cookie_value_from_auth_cookie cookie =
+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; success } in
+ let data = Utils.Status.to_json status in
+ let headers =
+ 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;
+ Lwt.return_unit
+
+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_auth_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
@@ -108,7 +133,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 -> (
@@ -137,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 ->
@@ -161,3 +195,43 @@ 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 (Utils.Json.clean_string input_csrf) check_csrf
+
+let csrf_cookie_verification form_csrf reqd =
+ match has_cookie "molly_csrf" reqd with
+ | Some cookie -> (
+ 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);
+ 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
+ | 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:form_csrf
+ then handler reqd
+ else
+ http_response ~title:"CSRF Token Mismatch"
+ ~data:"CSRF token mismatch error. Please referesh and try again."
+ reqd `Bad_request
+ | None ->
+ http_response
+ ~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 ()
diff --git a/settings_page.ml b/settings_page.ml
index 7f246984..546b0fbc 100644
--- a/settings_page.ml
+++ b/settings_page.ml
@@ -1,4 +1,4 @@
-let settings_layout (configuration : Configuration.t) =
+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
@@ -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..20f23d9c 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.ml b/unikernel.ml
index 21575829..dad32f36 100644
--- a/unikernel.ml
+++ b/unikernel.ml
@@ -49,6 +49,27 @@ struct
module Store = Storage.Make (BLOCK)
module Map = Map.Make (String)
+ 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
let finished, notify_finished = Lwt.wait () in
@@ -66,6 +87,20 @@ struct
~on_eof:(on_eof f_init);
finished >>= fun data -> data
+ let extract_csrf_token reqd =
+ decode_request_body reqd >>= fun data ->
+ match
+ try Ok (Yojson.Basic.from_string data)
+ with Yojson.Json_error s -> Error (`Msg s)
+ with
+ | Error (`Msg err) ->
+ Logs.warn (fun m -> m "Failed to parse JSON: %s" err);
+ 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)
let to_map ~assoc m =
@@ -92,7 +127,7 @@ struct
go (Map.empty, []) m
let authenticate ?(email_verified = true) ?(check_admin = false)
- ?(api_meth = false) 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
@@ -103,6 +138,9 @@ struct
@ (if email_verified && false (* TODO *) then
[ Middleware.email_verified_middleware now users ]
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
@@ -127,42 +165,24 @@ 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 =
- match Middleware.has_session_cookie reqd with
- | Some cookie -> (
- match Middleware.cookie_value_from_auth_cookie cookie with
- | Ok "" ->
- Lwt.return
- (reply reqd ~content_type:"text/html"
- (Sign_up.register_page ~icon:"/images/robur.png" ())
- `OK)
- | _ -> Middleware.redirect_to_dashboard reqd ())
- | None ->
+ 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.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 ~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)
let sign_in reqd =
- match Middleware.has_session_cookie reqd with
- | Some cookie -> (
- match Middleware.cookie_value_from_auth_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" ())
@@ -177,10 +197,10 @@ 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 =
+ 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 +209,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 +222,75 @@ 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 "form_csrf" |> 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
+ 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
+ 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 ->
+ Middleware.http_response reqd ~title:"Error"
+ ~data:"A user with this name already exist." `Bad_request
+ | None, Some _ ->
+ 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
+ let user =
+ let active, super_user =
+ if List.length users = 0 then (true, true)
+ else (false, false)
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))
+ 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
+ Middleware.http_response reqd ~header_list
+ ~title:"Success"
+ ~data:
+ (Yojson.Basic.to_string
+ (User_model.user_to_json user))
+ `OK
+ | Error (`Msg err) ->
+ Middleware.http_response reqd ~title:"Error"
+ ~data:(String.escaped err) `Bad_request)
+ | _ ->
+ Middleware.http_response reqd ~title:"Error"
+ ~data:"A user with this name or email already exist."
+ `Bad_request
+ else
+ Middleware.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 ->
@@ -264,7 +301,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 =
@@ -283,8 +320,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
@@ -292,8 +329,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' -> (
@@ -316,42 +353,54 @@ 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 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
+ let now = Ptime.v (P.now_d_ps ()) in
+ generate_csrf_token store user now >>= function
+ | Ok csrf -> (
+ 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
- Logs.info (fun m -> m "Verification link is: %s" verification_link);
+ 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"
- (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
+ (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)
=
@@ -369,10 +418,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 ()
@@ -386,7 +435,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) -> (
@@ -396,33 +445,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 =
@@ -492,64 +541,73 @@ 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 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 ~csrf
+ (snd !store).Storage.configuration)
+ ~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 ->
- 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);
- 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;
- 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)
- | Error (`Msg err) ->
- 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 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 *)
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)))
@@ -557,15 +615,15 @@ 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)
- 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 +646,26 @@ 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 store user now >>= function
+ | Ok csrf ->
+ Lwt.return
+ (reply reqd ~content_type:"text/html"
+ (Dashboard.dashboard_layout user
+ ~content:
+ (Unikernel_single.unikernel_single_layout ~csrf
+ (List.hd unikernels) now console_output)
+ ~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 =
{
@@ -614,24 +683,27 @@ struct
~icon:"/images/robur.png" ())
`Internal_server_error)
- let unikernel_destroy albatross name reqd (user : User_model.user) =
+ let unikernel_destroy json albatross reqd (user : User_model.user) =
(* TODO use uuid in the future *)
- Albatross.query albatross ~domain:user.name ~name
+ 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"
+ 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)
@@ -660,14 +732,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) -> (
@@ -675,49 +747,77 @@ 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);
+ 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 ->
+ 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))
+ | 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
+ Middleware.http_response reqd ~title:"Error"
+ ~data:
+ "CSRF token mismatch error. Please referesh and try \
+ again."
+ `Internal_server_error
+ | None ->
+ 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) ->
@@ -731,9 +831,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 +854,26 @@ 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 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 ~csrf u unikernels policy
+ now)
+ ~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 +885,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 +901,29 @@ 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 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 ~csrf u
+ ~user_policy ~unallocated_resources)
+ ~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 =
{
@@ -831,82 +955,69 @@ 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);
- 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);
- http_response reqd ~title:"Error"
- ~data:
- ("policy is not smaller than 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:("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);
- http_response reqd ~title:"Error"
- ~data:("error setting policy: " ^ err)
- `Internal_server_error
- | Ok policy ->
- 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"
- ~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);
- 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)
- | None ->
- 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 =
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 =
@@ -976,7 +1087,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,27 +1095,50 @@ 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
- (update_settings 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 () ->
- authenticate ~check_admin:true ~api_meth:true !store reqd
- (update_policy !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 () ->
- authenticate ~check_admin:true ~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 () ->
- authenticate ~check_admin:true ~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
@@ -1017,19 +1151,19 @@ 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/destroy" ->
+ check_meth `POST (fun () ->
+ 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/") ->
diff --git a/unikernel_create.ml b/unikernel_create.ml
index a5c2d1a8..0b9af4dc 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..3608f830 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 ~csrf unikernel now console_output =
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..50edcceb 100644
--- a/update_policy.ml
+++ b/update_policy.ml
@@ -1,9 +1,10 @@
-let update_policy_layout (user : User_model.user) ~user_policy
+let update_policy_layout ~csrf (user : User_model.user) ~user_policy
~unallocated_resources =
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..3032465b 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 ~csrf (user : User_model.user) unikernels policy
+ current_time =
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/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.(
diff --git a/verify_email.ml b/verify_email.ml
index 74378622..59974cf7 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 ~csrf ~icon (user : User_model.user) =
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" ];