From f2f87ab22ed510f3f5c0351811ef766a230e8e50 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Fri, 6 Dec 2024 00:10:55 +0100 Subject: [PATCH 01/23] check if a token is valid --- user_model.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/user_model.ml b/user_model.ml index c2925603..4ace8fe0 100644 --- a/user_model.ml +++ b/user_model.ml @@ -764,6 +764,11 @@ let is_valid_cookie (cookie : cookie) now = ~check_time:cookie.created_at < cookie.expires_in +let is_valid_token (token : token) now = + Utils.TimeHelper.diff_in_seconds ~current_time:now + ~check_time:token.created_at + < token.expires_in + let is_email_verified user = Option.is_some user.email_verified let password_validation password = String.length password >= 8 From 81bdb5012cdf79e751f13d9d6e3cab29cb9fc8fb Mon Sep 17 00:00:00 2001 From: PizieDust Date: Fri, 6 Dec 2024 00:11:07 +0100 Subject: [PATCH 02/23] find user from api_token --- storage.ml | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/storage.ml b/storage.ml index 8461579a..0f3d52ea 100644 --- a/storage.ml +++ b/storage.ml @@ -164,6 +164,18 @@ module Make (BLOCK : Mirage_block.S) = struct | Some c -> Some (user, c))) None store.users + let find_by_api_token store token = + List.find_map + (fun (user : User_model.user) -> + match + List.find_opt + (fun (token_ : User_model.token) -> String.equal token token_.value) + user.tokens + with + | Some token_ -> Some (user, token_) + | None -> None) + store.users + let count_users store = List.length store.users let find_email_verification_token store uuid = From a6e2df6856b0e23887800f443912ab18b9db3848 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Fri, 6 Dec 2024 00:11:22 +0100 Subject: [PATCH 03/23] find token in api request --- middleware.ml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/middleware.ml b/middleware.ml index 3dac42c8..7376d880 100644 --- a/middleware.ml +++ b/middleware.ml @@ -178,3 +178,10 @@ let csrf_verification user now form_csrf handler reqd = | None -> http_response ~data:"Missing CSRF token. Please refresh and try again." ~title:"Missing CSRF Token" reqd `Bad_request + +let api_authentication reqd = + match header "Authorization" reqd with + | Some auth when String.starts_with ~prefix:"Bearer " auth -> + let token = String.sub auth 7 (String.length auth - 7) in + Some token + | _ -> None From 21d85b3fb5fc83ce7d278cb061116b1048349743 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Fri, 6 Dec 2024 07:21:49 +0100 Subject: [PATCH 04/23] add api authentication to authenticate function --- unikernel.ml | 145 ++++++++++++++++++++++++++++++++------------------- 1 file changed, 90 insertions(+), 55 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index cc2bcdbb..e67919bc 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -130,64 +130,99 @@ struct let authenticate ?(email_verified = true) ?(check_admin = false) ?(api_meth = false) ?form_csrf store reqd f = let now = Ptime.v (P.now_d_ps ()) in - match Middleware.session_cookie_value reqd with - | Error (`Msg err) -> - Logs.err (fun m -> - m "auth-middleware: No molly-session in cookie header. %s" err); - Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true - ~with_error:true ~msg:"No session cookie found in request." reqd () - | Ok cookie_value -> ( - match Store.find_by_cookie store cookie_value with + let middlewares user = + (if check_admin then [ Middleware.is_user_admin_middleware api_meth user ] + else []) + @ (if email_verified && false (* TODO *) then + [ Middleware.email_verified_middleware user ] + else []) + @ Option.fold ~none:[] + ~some:(fun csrf -> [ Middleware.csrf_verification user now csrf ]) + form_csrf + @ [ Middleware.auth_middleware user ] + in + match Middleware.api_authentication reqd with + | Some token_value -> ( + match Store.find_by_api_token store token_value with + | Some (user, token) -> + if User_model.is_valid_token token now then ( + let token = { token with usage_count = token.usage_count + 1 } in + let tokens = + List.map + (fun (token' : User_model.token) -> + if String.equal token_value token'.value then token + else token') + user.tokens + in + let updated_user = User_model.update_user user ~tokens () in + Store.update_user store updated_user >>= function + | Ok () -> f user + | Error (`Msg err) -> + Logs.err (fun m -> m "Error with storage: %s" err); + Middleware.http_response reqd ~title:"Error" ~data:err + `Not_found) + else + Middleware.http_response reqd ~title:"Error" + ~data: + "Authorization token has expired. Please generate a new \ + token from your account dashboard." + `Not_found | None -> + Middleware.http_response reqd ~title:"Error" + ~data: + ("Invalid authorization token. User not found for token " + ^ token_value) + `Not_found) + | None -> ( + match Middleware.session_cookie_value reqd with + | Error (`Msg err) -> Logs.err (fun m -> - m "auth-middleware: Failed to find user with key %s" - cookie_value); + m "auth-middleware: No molly-session in cookie header. %s" err); Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true - ~with_error:true ~msg:"No user account found." reqd () - | Some (user, cookie) -> - if not (User_model.is_valid_cookie cookie now) then ( - Logs.err (fun m -> - m - "auth-middleware: Session value doesn't match user session \ - %s" - cookie_value); - Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true - ~with_error:true ~msg:"Session cookie is no longer valid." reqd - ()) - else - let middlewares = - (if check_admin then - [ Middleware.is_user_admin_middleware api_meth user ] - else []) - @ (if email_verified && false (* TODO *) then - [ Middleware.email_verified_middleware user ] - else []) - @ Option.fold ~none:[] - ~some:(fun csrf -> - [ Middleware.csrf_verification user now csrf ]) - form_csrf - @ [ Middleware.auth_middleware user ] - in - Middleware.apply_middleware middlewares - (fun reqd -> - let cookie = - { cookie with user_agent = Middleware.user_agent reqd } - in - let cookies = - List.map - (fun (cookie' : User_model.cookie) -> - if String.equal cookie_value cookie'.value then cookie - else cookie') - user.cookies - in - let updated_user = User_model.update_user user ~cookies () in - Store.update_user store updated_user >>= function - | Ok () -> f user - | Error (`Msg err) -> - Logs.err (fun m -> m "Error with storage: %s" err); - Middleware.http_response reqd ~title:"Error" ~data:err - `Not_found) - reqd) + ~with_error:true ~msg:"No session cookie found in request." reqd + () + | Ok cookie_value -> ( + match Store.find_by_cookie store cookie_value with + | None -> + Logs.err (fun m -> + m "auth-middleware: Failed to find user with key %s" + cookie_value); + Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true + ~with_error:true ~msg:"No user account found." reqd () + | Some (user, cookie) -> + if not (User_model.is_valid_cookie cookie now) then ( + Logs.err (fun m -> + m + "auth-middleware: Session value doesn't match user \ + session %s" + cookie_value); + Middleware.redirect_to_page ~path:"/sign-in" + ~clear_session:true ~with_error:true + ~msg:"Session cookie is no longer valid." reqd ()) + else + Middleware.apply_middleware (middlewares user) + (fun reqd -> + let cookie = + { cookie with user_agent = Middleware.user_agent reqd } + in + let cookies = + List.map + (fun (cookie' : User_model.cookie) -> + if String.equal cookie_value cookie'.value then + cookie + else cookie') + user.cookies + in + let updated_user = + User_model.update_user user ~cookies () + in + Store.update_user store updated_user >>= function + | Ok () -> f user + | Error (`Msg err) -> + Logs.err (fun m -> m "Error with storage: %s" err); + Middleware.http_response reqd ~title:"Error" ~data:err + `Not_found) + reqd)) let reply reqd ?(content_type = "text/plain") ?(header_list = []) data status = From f0d26b204194e4da159cad0570ab9037c404c98d Mon Sep 17 00:00:00 2001 From: PizieDust Date: Fri, 6 Dec 2024 10:32:37 +0100 Subject: [PATCH 05/23] extract just the json body where theres no csrf --- unikernel.ml | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/unikernel.ml b/unikernel.ml index e67919bc..18a44dcb 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -102,6 +102,20 @@ struct Logs.warn (fun m -> m "JSON is not a dictionary: %s" data); Lwt.return (Error (`Msg "not a dictionary")) + let extract_json_body 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 (`Assoc json_dict) -> Lwt.return (Ok json_dict) + | Ok _ -> + Logs.warn (fun m -> m "JSON is not a dictionary: %s" data); + Lwt.return (Error (`Msg "not a dictionary")) + module Albatross = Albatross.Make (T) (P) (S) let to_map ~assoc m = From 8633f1c37bdbc4adf153fd8fe36f1045e7130ba5 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Fri, 6 Dec 2024 10:33:00 +0100 Subject: [PATCH 06/23] refactor csrf verification --- unikernel.ml | 374 +++++++++++++++++++++------------------------------ 1 file changed, 157 insertions(+), 217 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index 18a44dcb..c7b5945d 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -142,101 +142,118 @@ struct go (Map.empty, []) m let authenticate ?(email_verified = true) ?(check_admin = false) - ?(api_meth = false) ?form_csrf store reqd f = + ?(api_meth = false) store reqd f = let now = Ptime.v (P.now_d_ps ()) in - let middlewares user = + let middlewares form_csrf user = (if check_admin then [ Middleware.is_user_admin_middleware api_meth user ] else []) @ (if email_verified && false (* TODO *) then [ Middleware.email_verified_middleware user ] else []) - @ Option.fold ~none:[] - ~some:(fun csrf -> [ Middleware.csrf_verification user now csrf ]) - form_csrf + @ (if api_meth then [ Middleware.csrf_verification user now form_csrf ] + else []) @ [ Middleware.auth_middleware user ] in match Middleware.api_authentication reqd with | Some token_value -> ( - match Store.find_by_api_token store token_value with - | Some (user, token) -> - if User_model.is_valid_token token now then ( - let token = { token with usage_count = token.usage_count + 1 } in - let tokens = - List.map - (fun (token' : User_model.token) -> - if String.equal token_value token'.value then token - else token') - user.tokens - in - let updated_user = User_model.update_user user ~tokens () in - Store.update_user store updated_user >>= function - | Ok () -> f user - | Error (`Msg err) -> - Logs.err (fun m -> m "Error with storage: %s" err); - Middleware.http_response reqd ~title:"Error" ~data:err - `Not_found) - else - Middleware.http_response reqd ~title:"Error" - ~data: - "Authorization token has expired. Please generate a new \ - token from your account dashboard." - `Not_found - | None -> + extract_json_body reqd >>= function + | Ok json_dict -> ( + match Store.find_by_api_token store token_value with + | Some (user, token) -> + if User_model.is_valid_token token now then ( + let token = + { token with usage_count = token.usage_count + 1 } + in + let tokens = + List.map + (fun (token' : User_model.token) -> + if String.equal token_value token'.value then token + else token') + user.tokens + in + let updated_user = User_model.update_user user ~tokens () in + Store.update_user store updated_user >>= function + | Ok () -> f ~json_dict user + | Error (`Msg err) -> + Logs.err (fun m -> m "Error with storage: %s" err); + Middleware.http_response reqd ~title:"Error" ~data:err + `Not_found) + else + Middleware.http_response reqd ~title:"Error" + ~data: + "Authorization token has expired. Please generate a new \ + token from your account dashboard." + `Not_found + | None -> + Middleware.http_response reqd ~title:"Error" + ~data: + ("Invalid authorization token. User not found for token " + ^ token_value) + `Not_found) + | Error (`Msg msg) -> Middleware.http_response reqd ~title:"Error" - ~data: - ("Invalid authorization token. User not found for token " - ^ token_value) - `Not_found) + ~data:(String.escaped msg) `Bad_request) | None -> ( - match Middleware.session_cookie_value reqd with - | Error (`Msg err) -> - Logs.err (fun m -> - m "auth-middleware: No molly-session in cookie header. %s" err); - Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true - ~with_error:true ~msg:"No session cookie found in request." reqd - () - | Ok cookie_value -> ( - match Store.find_by_cookie store cookie_value with - | None -> + extract_csrf_token reqd >>= function + | Ok (form_csrf, json_dict) -> ( + match Middleware.session_cookie_value reqd with + | Error (`Msg err) -> Logs.err (fun m -> - m "auth-middleware: Failed to find user with key %s" - cookie_value); + m "auth-middleware: No molly-session in cookie header. %s" + err); Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true - ~with_error:true ~msg:"No user account found." reqd () - | Some (user, cookie) -> - if not (User_model.is_valid_cookie cookie now) then ( - Logs.err (fun m -> - m - "auth-middleware: Session value doesn't match user \ - session %s" - cookie_value); - Middleware.redirect_to_page ~path:"/sign-in" - ~clear_session:true ~with_error:true - ~msg:"Session cookie is no longer valid." reqd ()) - else - Middleware.apply_middleware (middlewares user) - (fun reqd -> - let cookie = - { cookie with user_agent = Middleware.user_agent reqd } - in - let cookies = - List.map - (fun (cookie' : User_model.cookie) -> - if String.equal cookie_value cookie'.value then - cookie - else cookie') - user.cookies - in - let updated_user = - User_model.update_user user ~cookies () - in - Store.update_user store updated_user >>= function - | Ok () -> f user - | Error (`Msg err) -> - Logs.err (fun m -> m "Error with storage: %s" err); - Middleware.http_response reqd ~title:"Error" ~data:err - `Not_found) - reqd)) + ~with_error:true ~msg:"No session cookie found in request." + reqd () + | Ok cookie_value -> ( + match Store.find_by_cookie store cookie_value with + | None -> + Logs.err (fun m -> + m "auth-middleware: Failed to find user with key %s" + cookie_value); + Middleware.redirect_to_page ~path:"/sign-in" + ~clear_session:true ~with_error:true + ~msg:"No user account found." reqd () + | Some (user, cookie) -> + if not (User_model.is_valid_cookie cookie now) then ( + Logs.err (fun m -> + m + "auth-middleware: Session value doesn't match user \ + session %s" + cookie_value); + Middleware.redirect_to_page ~path:"/sign-in" + ~clear_session:true ~with_error:true + ~msg:"Session cookie is no longer valid." reqd ()) + else + Middleware.apply_middleware + (middlewares form_csrf user) + (fun reqd -> + let cookie = + { + cookie with + user_agent = Middleware.user_agent reqd; + } + in + let cookies = + List.map + (fun (cookie' : User_model.cookie) -> + if String.equal cookie_value cookie'.value then + cookie + else cookie') + user.cookies + in + let updated_user = + User_model.update_user user ~cookies () + in + Store.update_user store updated_user >>= function + | Ok () -> f ~json_dict user + | Error (`Msg err) -> + Logs.err (fun m -> m "Error with storage: %s" err); + Middleware.http_response reqd ~title:"Error" + ~data:err `Not_found) + reqd)) + | Error (`Msg msg) -> + Middleware.http_response reqd ~title:"Error" + ~data:(String.escaped msg) `Bad_request) let reply reqd ?(content_type = "text/plain") ?(header_list = []) data status = @@ -513,7 +530,7 @@ struct Middleware.http_response reqd ~title:"Error" ~data:"Update password: expected a dictionary" `Bad_request - let verify_email store reqd (user : User_model.user) = + let verify_email store reqd ~json_dict:_ (user : User_model.user) = let now = Ptime.v (P.now_d_ps ()) in generate_csrf_token store user now reqd >>= function | Ok csrf -> ( @@ -545,8 +562,8 @@ struct ~icon:"/images/robur.png" ()) `Internal_server_error) - let verify_email_token store reqd verification_token (user : User_model.user) - = + let verify_email_token store reqd verification_token ~json_dict:_ + (user : User_model.user) = match let ( let* ) = Result.bind in let* uuid = @@ -601,7 +618,7 @@ struct Middleware.http_response reqd ~title:"Error" ~data:"Couldn't find a UUID in the JSON." `Not_found - let toggle_account_activation json_dict store reqd _user = + let toggle_account_activation ~json_dict store reqd _user = toggle_account_attribute json_dict store reqd ~key:"toggle-active-account" (fun user -> User_model.update_user user ~active:(not user.active) @@ -610,7 +627,7 @@ struct (fun user -> user.active && Store.count_active store <= 1) ~error_message:"Cannot deactivate last active user" - let toggle_admin_activation json_dict store reqd _user = + let toggle_admin_activation ~json_dict store reqd _user = toggle_account_attribute json_dict store reqd ~key:"toggle-admin-account" (fun user -> User_model.update_user user ~super_user:(not user.super_user) @@ -619,7 +636,7 @@ struct (fun user -> user.super_user && Store.count_superusers store <= 1) ~error_message:"Cannot remove last administrator" - let dashboard store albatross reqd (user : User_model.user) = + let dashboard store albatross reqd ~json_dict:_ (user : User_model.user) = let now = Ptime.v (P.now_d_ps ()) in generate_csrf_token store user now reqd >>= function | Ok csrf -> @@ -641,7 +658,7 @@ struct ~icon:"/images/robur.png" ()) `Internal_server_error) - let account_page store reqd (user : User_model.user) = + let account_page store reqd ~json_dict:_ (user : User_model.user) = match Middleware.session_cookie_value reqd with | Ok active_cookie_value -> ( let now = Ptime.v (P.now_d_ps ()) in @@ -680,7 +697,7 @@ struct ~icon:"/images/robur.png" ()) `Unauthorized) - let update_password json_dict store reqd (user : User_model.user) = + let update_password store reqd ~json_dict (user : User_model.user) = match Utils.Json. ( get "current_password" json_dict, @@ -742,7 +759,7 @@ struct Middleware.http_response reqd ~title:"Error" ~data:err `Internal_server_error - let close_sessions ?to_logout_cookie ?(logout = false) store reqd + let close_sessions ?to_logout_cookie ?(logout = false) store reqd ~json_dict:_ (user : User_model.user) = match Middleware.session_cookie_value reqd with | Ok cookie_value -> ( @@ -800,7 +817,7 @@ struct ~icon:"/images/robur.png" ()) `Unauthorized) - let users store reqd (user : User_model.user) = + let users store reqd ~json_dict:_ (user : User_model.user) = let now = Ptime.v (P.now_d_ps ()) in generate_csrf_token store user now reqd >>= function | Ok csrf -> @@ -821,7 +838,7 @@ struct ~icon:"/images/robur.png" ()) `Internal_server_error) - let settings store reqd (user : User_model.user) = + let settings store reqd ~json_dict:_ (user : User_model.user) = let now = Ptime.v (P.now_d_ps ()) in generate_csrf_token store user now reqd >>= function | Ok csrf -> @@ -842,7 +859,7 @@ struct ~icon:"/images/robur.png" ()) `Internal_server_error) - let update_settings json_dict stack store albatross reqd _user = + let update_settings stack store albatross reqd ~json_dict _user = match Configuration.of_json_from_http json_dict (Ptime.v (P.now_d_ps ())) with @@ -864,7 +881,7 @@ struct Middleware.http_response ~title:"Error" ~data:(String.escaped err) reqd `Bad_request - let deploy_form store reqd (user : User_model.user) = + let deploy_form store reqd ~json_dict:_ (user : User_model.user) = let now = Ptime.v (P.now_d_ps ()) in generate_csrf_token store user now reqd >>= function | Ok csrf -> @@ -884,7 +901,7 @@ struct ~icon:"/images/robur.png" ()) `Internal_server_error) - let unikernel_info albatross reqd (user : User_model.user) = + let unikernel_info albatross reqd ~json_dict:_ (user : User_model.user) = (* TODO use uuid in the future *) Albatross.query albatross ~domain:user.name (`Unikernel_cmd `Unikernel_info) >>= function @@ -905,7 +922,8 @@ struct ~data:(Yojson.Basic.to_string (`String res)) `Internal_server_error) - let unikernel_info_one albatross store name reqd (user : User_model.user) = + let unikernel_info_one albatross store name reqd ~json_dict:_ + (user : User_model.user) = (* TODO use uuid in the future *) (Albatross.query albatross ~domain:user.name ~name (`Unikernel_cmd `Unikernel_info) @@ -964,7 +982,7 @@ struct ~icon:"/images/robur.png" ()) `Internal_server_error) - let unikernel_destroy json_dict albatross reqd (user : User_model.user) = + let unikernel_destroy ~json_dict albatross reqd (user : User_model.user) = (* TODO use uuid in the future *) match Utils.Json.get "name" json_dict with | Some (`String unikernel_name) -> ( @@ -990,7 +1008,7 @@ struct Middleware.http_response reqd ~title:"Error" ~data:"Couldn't find unikernel name in json" `Bad_request - let unikernel_restart json_dict albatross reqd (user : User_model.user) = + let unikernel_restart ~json_dict albatross reqd (user : User_model.user) = (* TODO use uuid in the future *) match Utils.Json.get "name" json_dict with | Some (`String unikernel_name) -> ( @@ -1016,7 +1034,7 @@ struct Middleware.http_response reqd ~title:"Error" ~data:"Couldn't find unikernel name in json" `Bad_request - let unikernel_create albatross reqd (user : User_model.user) = + let unikernel_create albatross reqd ~json_dict:_ (user : User_model.user) = read_multipart_data reqd >>= function | Error (`Msg msg) -> Middleware.http_response reqd ~title:"Error" @@ -1070,7 +1088,8 @@ struct Middleware.http_response reqd ~title:"Error" ~data:"Couldn't find fields" `Bad_request) - let unikernel_console albatross name reqd (user : User_model.user) = + let unikernel_console albatross name reqd ~json_dict:_ + (user : User_model.user) = (* TODO use uuid in the future *) Albatross.query_console ~domain:user.name albatross ~name >>= function | Error err -> @@ -1088,7 +1107,8 @@ struct (Yojson.Basic.to_string (`List console_output)) `OK) - let view_user albatross store uuid reqd (user : User_model.user) = + let view_user albatross store uuid reqd ~json_dict:_ (user : User_model.user) + = match Store.find_by_uuid store uuid with | Some u -> ( user_unikernels albatross user.name >>= fun unikernels -> @@ -1132,7 +1152,8 @@ struct ~icon:"/images/robur.png" ()) `Not_found) - let edit_policy albatross store uuid reqd (user : User_model.user) = + let edit_policy albatross store uuid reqd ~json_dict:_ + (user : User_model.user) = match Store.find_by_uuid store uuid with | Some u -> ( let user_policy = @@ -1195,7 +1216,7 @@ struct ~icon:"/images/robur.png" ()) `Not_found) - let update_policy json_dict store albatross reqd _user = + let update_policy store albatross reqd ~json_dict _user = match Utils.Json.get "user_uuid" json_dict with | Some (`String user_uuid) -> ( match Store.find_by_uuid store user_uuid with @@ -1258,7 +1279,7 @@ struct (Yojson.Basic.to_string (`Assoc json_dict))) `Bad_request - let volumes store albatross reqd (user : User_model.user) = + let volumes store albatross reqd ~json_dict:_ (user : User_model.user) = user_volumes albatross user.name >>= fun blocks -> let policy = Result.fold ~ok:Fun.id @@ -1284,7 +1305,7 @@ struct ~icon:"/images/robur.png" ()) `Internal_server_error) - let delete_volume json_dict albatross reqd (user : User_model.user) = + let delete_volume albatross reqd ~json_dict (user : User_model.user) = match Utils.Json.get "block_name" json_dict with | Some (`String block_name) -> ( Albatross.query albatross ~domain:user.name ~name:block_name @@ -1309,7 +1330,7 @@ struct Middleware.http_response reqd ~title:"Error" ~data:"Couldn't find block name in json" `Bad_request - let create_volume albatross reqd (user : User_model.user) = + let create_volume albatross reqd ~json_dict:_ (user : User_model.user) = read_multipart_data reqd >>= fun result -> match result with | Error (`Msg msg) -> @@ -1377,7 +1398,7 @@ struct Middleware.http_response reqd ~title:"Error" ~data:"Couldn't find fields" `Bad_request) - let download_volume json_dict albatross reqd (user : User_model.user) = + let download_volume albatross reqd ~json_dict (user : User_model.user) = match Utils.Json.(get "block_name" json_dict, get "compression_level" json_dict) with @@ -1408,7 +1429,7 @@ struct Middleware.http_response reqd ~title:"Error" ~data:"Couldn't find block name in json" `Bad_request - let upload_to_volume albatross reqd (user : User_model.user) = + let upload_to_volume albatross reqd ~json_dict:_ (user : User_model.user) = read_multipart_data reqd >>= function | Error (`Msg msg) -> Middleware.http_response reqd ~title:"Error" @@ -1472,7 +1493,7 @@ struct Middleware.http_response reqd ~title:"Error" ~data:"Couldn't find fields" `Bad_request) - let account_usage store albatross reqd (user : User_model.user) = + let account_usage store albatross reqd ~json_dict:_ (user : User_model.user) = let now = Ptime.v (P.now_d_ps ()) in generate_csrf_token store user now reqd >>= function | Ok csrf -> @@ -1501,7 +1522,7 @@ struct ~icon:"/images/robur.png" ()) `Internal_server_error) - let api_tokens store reqd (user : User_model.user) = + let api_tokens store reqd ~json_dict:_ (user : User_model.user) = let now = Ptime.v (P.now_d_ps ()) in generate_csrf_token store user now reqd >>= function | Ok csrf -> @@ -1521,7 +1542,7 @@ struct ~icon:"/images/robur.png" ()) `Internal_server_error) - let create_token json_dict store reqd (user : User_model.user) = + let create_token store reqd ~json_dict (user : User_model.user) = match Utils.Json.(get "token_name" json_dict, get "token_expiry" json_dict) with @@ -1547,7 +1568,7 @@ struct (Yojson.Basic.to_string (`Assoc json_dict))) `Bad_request - let delete_token json_dict store reqd (user : User_model.user) = + let delete_token store reqd ~json_dict (user : User_model.user) = match Utils.Json.(get "token_value" json_dict) with | Some (`String value) -> ( let now = Ptime.v (P.now_d_ps ()) in @@ -1575,7 +1596,7 @@ struct (Yojson.Basic.to_string (`Assoc json_dict))) `Bad_request - let update_token json_dict store reqd (user : User_model.user) = + let update_token store reqd ~json_dict (user : User_model.user) = match Utils.Json. ( get "token_name" json_dict, @@ -1691,39 +1712,22 @@ struct authenticate store reqd (account_page store reqd)) | "/account/password/update" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> - authenticate ~form_csrf store reqd - (update_password json_dict store reqd) - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + authenticate store reqd (update_password store reqd)) | "/account/sessions/close" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= function - | Ok (form_csrf, _) -> - authenticate ~form_csrf store reqd - (close_sessions store reqd) - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + authenticate store reqd (close_sessions store reqd)) | "/logout" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= function - | Ok (form_csrf, _) -> - authenticate ~form_csrf store reqd - (close_sessions ~logout:true store reqd) - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + authenticate store reqd (close_sessions ~logout:true store reqd)) | path when String.starts_with ~prefix:"/account/session/close/" path -> check_meth `GET (fun () -> match String.split_on_char '/' (String.sub path 23 (String.length path - 23)) with - | [ to_logout_cookie; form_csrf ] -> - authenticate ~form_csrf store reqd + (* TODO: Find a way to do CSRF verification here or change to Post request*) + | [ to_logout_cookie ] -> + authenticate store reqd (close_sessions ~to_logout_cookie store reqd) | _ -> Middleware.http_response reqd ~title:"Error" @@ -1734,25 +1738,15 @@ struct authenticate store reqd (volumes store !albatross reqd)) | "/api/volume/delete" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> - authenticate ~form_csrf ~api_meth:true store reqd - (delete_volume json_dict !albatross reqd) - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + authenticate ~api_meth:true store reqd + (delete_volume !albatross reqd)) | "/api/volume/create" -> check_meth `POST (fun () -> authenticate store reqd (create_volume !albatross reqd)) | "/api/volume/download" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> - authenticate ~form_csrf ~api_meth:true store reqd - (download_volume json_dict !albatross reqd) - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + authenticate ~api_meth:true store reqd + (download_volume !albatross reqd)) | "/api/volume/upload" -> check_meth `POST (fun () -> authenticate store reqd (upload_to_volume !albatross reqd)) @@ -1761,31 +1755,13 @@ struct authenticate store reqd (api_tokens store reqd)) | "/api/tokens/create" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> - authenticate ~form_csrf ~api_meth:true store reqd - (create_token json_dict store reqd) - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + authenticate ~api_meth:true store reqd (create_token store reqd)) | "/api/tokens/delete" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> - authenticate ~form_csrf ~api_meth:true store reqd - (delete_token json_dict store reqd) - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + authenticate ~api_meth:true store reqd (delete_token store reqd)) | "/api/tokens/update" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> - authenticate ~form_csrf ~api_meth:true store reqd - (update_token json_dict store reqd) - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + authenticate ~api_meth:true store reqd (update_token store reqd)) | "/admin/users" -> check_meth `GET (fun () -> authenticate ~check_admin:true store reqd (users store reqd)) @@ -1807,44 +1783,20 @@ struct authenticate ~check_admin:true store reqd (settings store reqd)) | "/api/admin/settings/update" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> - authenticate ~check_admin:true ~form_csrf ~api_meth:true - store reqd - (update_settings json_dict stack store albatross reqd) - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + authenticate ~check_admin:true ~api_meth:true store reqd + (update_settings stack store albatross reqd)) | "/api/admin/u/policy/update" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> - authenticate ~check_admin:true ~form_csrf ~api_meth:true - store reqd - (update_policy json_dict store !albatross reqd) - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + authenticate ~check_admin:true ~api_meth:true store reqd + (update_policy store !albatross reqd)) | "/api/admin/user/activate/toggle" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> - authenticate ~check_admin:true ~form_csrf ~api_meth:true - store reqd - (toggle_account_activation json_dict store reqd) - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + authenticate ~check_admin:true ~api_meth:true store reqd + (toggle_account_activation store reqd)) | "/api/admin/user/admin/toggle" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> - authenticate ~check_admin:true ~form_csrf ~api_meth:true - store reqd - (toggle_admin_activation json_dict store reqd) - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + authenticate ~check_admin:true ~api_meth:true store reqd + (toggle_admin_activation store reqd)) | "/api/unikernels" -> check_meth `GET (fun () -> authenticate ~api_meth:true store reqd @@ -1861,22 +1813,10 @@ struct authenticate store reqd (deploy_form store reqd)) | "/unikernel/destroy" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> - authenticate store reqd ~form_csrf - (unikernel_destroy json_dict !albatross reqd) - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + authenticate store reqd (unikernel_destroy !albatross reqd)) | "/unikernel/restart" -> check_meth `POST (fun () -> - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> - authenticate store reqd ~form_csrf - (unikernel_restart json_dict !albatross reqd) - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + authenticate store reqd (unikernel_restart !albatross reqd)) | path when String.starts_with ~prefix:"/unikernel/console/" path -> check_meth `GET (fun () -> let unikernel_name = From f9f0049076565f696a18647424b89e80ac10c782 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Sun, 8 Dec 2024 11:23:12 +0100 Subject: [PATCH 07/23] fix csrf authentication --- unikernel.ml | 189 ++++++++++++++++++++++++++++----------------------- 1 file changed, 105 insertions(+), 84 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index c7b5945d..a9557097 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -142,20 +142,79 @@ 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) store reqd f = let now = Ptime.v (P.now_d_ps ()) in - let middlewares form_csrf user = + let middlewares ?(form_csrf = None) user = (if check_admin then [ Middleware.is_user_admin_middleware api_meth user ] else []) @ (if email_verified && false (* TODO *) then [ Middleware.email_verified_middleware user ] else []) - @ (if api_meth then [ Middleware.csrf_verification user now form_csrf ] - else []) + @ Option.fold ~none:[] + ~some:(fun csrf -> [ Middleware.csrf_verification user now csrf ]) + form_csrf @ [ Middleware.auth_middleware user ] in - match Middleware.api_authentication reqd with - | Some token_value -> ( + let handle_csrf () = + if check_csrf then + extract_csrf_token reqd >>= function + | Ok (form_csrf, json_dict) -> + Lwt.return (Ok (Some (form_csrf, json_dict))) + | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) + else Lwt.return (Ok None) + in + let process_request ?(json_dict = []) ?form_csrf () = + match Middleware.session_cookie_value reqd with + | Error (`Msg err) -> + Logs.err (fun m -> + m "auth-middleware: No molly-session in cookie header. %s" err); + Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true + ~with_error:true ~msg:"No session cookie found in request." reqd () + | Ok cookie_value -> ( + match Store.find_by_cookie store cookie_value with + | None -> + Logs.err (fun m -> + m "auth-middleware: Failed to find user with key %s" + cookie_value); + Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true + ~with_error:true ~msg:"No user account found." reqd () + | Some (user, cookie) -> + if not (User_model.is_valid_cookie cookie now) then ( + Logs.err (fun m -> + m + "auth-middleware: Session value doesn't match user \ + session %s" + cookie_value); + Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true + ~with_error:true ~msg:"Session cookie is no longer valid." + reqd ()) + else + Middleware.apply_middleware + (middlewares ~form_csrf user) + (fun reqd -> + let cookie = + { cookie with user_agent = Middleware.user_agent reqd } + in + let cookies = + List.map + (fun (cookie' : User_model.cookie) -> + if String.equal cookie_value cookie'.value then cookie + else cookie') + user.cookies + in + let updated_user = + User_model.update_user user ~cookies () + in + Store.update_user store updated_user >>= function + | Ok () -> f ~json_dict user + | Error (`Msg err) -> + Logs.err (fun m -> m "Error with storage: %s" err); + Middleware.http_response reqd ~title:"Error" ~data:err + `Not_found) + reqd) + in + match (Middleware.api_authentication reqd, api_meth) with + | Some token_value, true -> ( extract_json_body reqd >>= function | Ok json_dict -> ( match Store.find_by_api_token store token_value with @@ -193,64 +252,11 @@ struct | Error (`Msg msg) -> Middleware.http_response reqd ~title:"Error" ~data:(String.escaped msg) `Bad_request) - | None -> ( - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> ( - match Middleware.session_cookie_value reqd with - | Error (`Msg err) -> - Logs.err (fun m -> - m "auth-middleware: No molly-session in cookie header. %s" - err); - Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true - ~with_error:true ~msg:"No session cookie found in request." - reqd () - | Ok cookie_value -> ( - match Store.find_by_cookie store cookie_value with - | None -> - Logs.err (fun m -> - m "auth-middleware: Failed to find user with key %s" - cookie_value); - Middleware.redirect_to_page ~path:"/sign-in" - ~clear_session:true ~with_error:true - ~msg:"No user account found." reqd () - | Some (user, cookie) -> - if not (User_model.is_valid_cookie cookie now) then ( - Logs.err (fun m -> - m - "auth-middleware: Session value doesn't match user \ - session %s" - cookie_value); - Middleware.redirect_to_page ~path:"/sign-in" - ~clear_session:true ~with_error:true - ~msg:"Session cookie is no longer valid." reqd ()) - else - Middleware.apply_middleware - (middlewares form_csrf user) - (fun reqd -> - let cookie = - { - cookie with - user_agent = Middleware.user_agent reqd; - } - in - let cookies = - List.map - (fun (cookie' : User_model.cookie) -> - if String.equal cookie_value cookie'.value then - cookie - else cookie') - user.cookies - in - let updated_user = - User_model.update_user user ~cookies () - in - Store.update_user store updated_user >>= function - | Ok () -> f ~json_dict user - | Error (`Msg err) -> - Logs.err (fun m -> m "Error with storage: %s" err); - Middleware.http_response reqd ~title:"Error" - ~data:err `Not_found) - reqd)) + | _ -> ( + handle_csrf () >>= function + | Ok None -> process_request () + | Ok (Some (form_csrf, json_dict)) -> + process_request ~json_dict ~form_csrf () | Error (`Msg msg) -> Middleware.http_response reqd ~title:"Error" ~data:(String.escaped msg) `Bad_request) @@ -1556,7 +1562,8 @@ struct Store.update_user store updated_user >>= function | Ok () -> Middleware.http_response reqd ~title:"Success" - ~data:"Token created succesfully" `OK + ~data:(User_model.token_to_json token |> Yojson.Basic.to_string) + `OK | Error (`Msg err) -> Logs.warn (fun m -> m "Storage error with %s" err); Middleware.http_response reqd ~title:"Error" ~data:err @@ -1712,13 +1719,16 @@ struct authenticate store reqd (account_page store reqd)) | "/account/password/update" -> check_meth `POST (fun () -> - authenticate store reqd (update_password store reqd)) + authenticate ~check_csrf:true store reqd + (update_password store reqd)) | "/account/sessions/close" -> check_meth `POST (fun () -> - authenticate store reqd (close_sessions store reqd)) + authenticate ~check_csrf:true store reqd + (close_sessions store reqd)) | "/logout" -> check_meth `POST (fun () -> - authenticate store reqd (close_sessions ~logout:true store reqd)) + authenticate ~check_csrf:true store reqd + (close_sessions ~logout:true store reqd)) | path when String.starts_with ~prefix:"/account/session/close/" path -> check_meth `GET (fun () -> match @@ -1738,30 +1748,35 @@ struct authenticate store reqd (volumes store !albatross reqd)) | "/api/volume/delete" -> check_meth `POST (fun () -> - authenticate ~api_meth:true store reqd + authenticate ~check_csrf:true ~api_meth:true store reqd (delete_volume !albatross reqd)) | "/api/volume/create" -> check_meth `POST (fun () -> - authenticate store reqd (create_volume !albatross reqd)) + authenticate ~check_csrf:true store reqd + (create_volume !albatross reqd)) | "/api/volume/download" -> check_meth `POST (fun () -> - authenticate ~api_meth:true store reqd + authenticate ~check_csrf:true ~api_meth:true store reqd (download_volume !albatross reqd)) | "/api/volume/upload" -> check_meth `POST (fun () -> - authenticate store reqd (upload_to_volume !albatross reqd)) + authenticate ~check_csrf:true store reqd + (upload_to_volume !albatross reqd)) | "/tokens" -> check_meth `GET (fun () -> authenticate store reqd (api_tokens store reqd)) | "/api/tokens/create" -> check_meth `POST (fun () -> - authenticate ~api_meth:true store reqd (create_token store reqd)) + authenticate ~check_csrf:true ~api_meth:true store reqd + (create_token store reqd)) | "/api/tokens/delete" -> check_meth `POST (fun () -> - authenticate ~api_meth:true store reqd (delete_token store reqd)) + authenticate ~check_csrf:true ~api_meth:true store reqd + (delete_token store reqd)) | "/api/tokens/update" -> check_meth `POST (fun () -> - authenticate ~api_meth:true store reqd (update_token store reqd)) + authenticate ~check_csrf:true ~api_meth:true store reqd + (update_token store reqd)) | "/admin/users" -> check_meth `GET (fun () -> authenticate ~check_admin:true store reqd (users store reqd)) @@ -1783,19 +1798,23 @@ struct 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 + authenticate ~check_csrf:true ~check_admin:true ~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 + authenticate ~check_csrf:true ~check_admin:true ~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 + authenticate ~check_csrf:true ~check_admin:true ~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 + authenticate ~check_csrf:true ~check_admin:true ~api_meth:true + store reqd (toggle_admin_activation store reqd)) | "/api/unikernels" -> check_meth `GET (fun () -> @@ -1811,12 +1830,13 @@ struct | "/unikernel/deploy" -> check_meth `GET (fun () -> authenticate store reqd (deploy_form store reqd)) - | "/unikernel/destroy" -> + | "api/unikernel/destroy" -> check_meth `POST (fun () -> authenticate store reqd (unikernel_destroy !albatross reqd)) - | "/unikernel/restart" -> + | "api/unikernel/restart" -> check_meth `POST (fun () -> - authenticate store reqd (unikernel_restart !albatross reqd)) + authenticate ~check_csrf:true store reqd + (unikernel_restart !albatross reqd)) | path when String.starts_with ~prefix:"/unikernel/console/" path -> check_meth `GET (fun () -> let unikernel_name = @@ -1824,9 +1844,10 @@ struct in authenticate store reqd (unikernel_console !albatross unikernel_name reqd)) - | "/unikernel/create" -> + | "api/unikernel/create" -> check_meth `POST (fun () -> - authenticate store reqd (unikernel_create !albatross reqd)) + authenticate ~check_csrf:true store reqd + (unikernel_create !albatross reqd)) | _ -> let error = { From 4dc8caba9fb27d7a2473ffb8ff3d519a473b9594 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Sun, 8 Dec 2024 13:25:07 +0100 Subject: [PATCH 08/23] refactor json responses --- error_page.ml | 4 +- middleware.ml | 15 ++- unikernel.ml | 331 ++++++++++++++++++++++++++------------------------ user_model.ml | 6 +- utils.ml | 4 +- 5 files changed, 189 insertions(+), 171 deletions(-) diff --git a/error_page.ml b/error_page.ml index 76bd7515..26e420a6 100644 --- a/error_page.ml +++ b/error_page.ml @@ -8,5 +8,7 @@ let error_layout (error : Utils.Status.t) = ~a:[ a_class [ "text-5xl text-secondary-500 font-semibold" ] ] [ txt (string_of_int error.code) ]; p ~a:[ a_class [ "uppercase font-bold text-5xl" ] ] [ txt error.title ]; - p ~a:[ a_class [ "capitalize text-xl my-6" ] ] [ txt error.data ]; + p + ~a:[ a_class [ "text-xl my-6" ] ] + [ txt (Yojson.Basic.to_string error.data) ]; ]) diff --git a/middleware.ml b/middleware.ml index 7376d880..d0234d51 100644 --- a/middleware.ml +++ b/middleware.ml @@ -101,7 +101,8 @@ let redirect_to_dashboard reqd ?(msg = "") () = Httpaf.Reqd.respond_with_string reqd response msg; Lwt.return_unit -let http_response ~title ?(header_list = []) ?(data = "") reqd http_status = +let http_response ~title ?(header_list = []) ?(data = `String "") 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 @@ -152,7 +153,9 @@ let is_user_admin_middleware api_meth user handler reqd = if user.User_model.super_user && user.active then handler reqd else redirect_to_error ~title:"Unauthorized" - ~data:"You don't have the necessary permissions to access this service." + ~data: + (`String + "You don't have the necessary permissions to access this service.") `Unauthorized 401 api_meth reqd () let csrf_cookie_verification form_csrf reqd = @@ -173,10 +176,12 @@ let csrf_verification user now form_csrf handler reqd = if User_model.is_valid_cookie csrf_token now then handler reqd else http_response ~title:"CSRF Token Mismatch" - ~data:"Invalid CSRF token error. Please refresh and try again." reqd - `Bad_request + ~data: + (`String "Invalid CSRF token error. Please refresh and try again.") + reqd `Bad_request | None -> - http_response ~data:"Missing CSRF token. Please refresh and try again." + http_response + ~data:(`String "Missing CSRF token. Please refresh and try again.") ~title:"Missing CSRF Token" reqd `Bad_request let api_authentication reqd = diff --git a/unikernel.ml b/unikernel.ml index a9557097..b38b730e 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -63,7 +63,7 @@ struct Utils.Status.code = 500; title = "CSRF Token Error"; success = false; - data = err; + data = `String err; } in Lwt.return (Error error) @@ -209,8 +209,8 @@ struct | Ok () -> f ~json_dict user | Error (`Msg err) -> Logs.err (fun m -> m "Error with storage: %s" err); - Middleware.http_response reqd ~title:"Error" ~data:err - `Not_found) + Middleware.http_response reqd ~title:"Error" + ~data:(`String err) `Not_found) reqd) in match (Middleware.api_authentication reqd, api_meth) with @@ -235,23 +235,26 @@ struct | Ok () -> f ~json_dict user | Error (`Msg err) -> Logs.err (fun m -> m "Error with storage: %s" err); - Middleware.http_response reqd ~title:"Error" ~data:err - `Not_found) + Middleware.http_response reqd ~title:"Error" + ~data:(`String err) `Not_found) else Middleware.http_response reqd ~title:"Error" ~data: - "Authorization token has expired. Please generate a new \ - token from your account dashboard." + (`String + "Authorization token has expired. Please generate a \ + new token from your account dashboard.") `Not_found | None -> Middleware.http_response reqd ~title:"Error" ~data: - ("Invalid authorization token. User not found for token " - ^ token_value) + (`String + ("Invalid authorization token. User not found for token " + ^ token_value)) `Not_found) | Error (`Msg msg) -> Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + ~data:(`String (String.escaped msg)) + `Bad_request) | _ -> ( handle_csrf () >>= function | Ok None -> process_request () @@ -259,7 +262,8 @@ struct process_request ~json_dict ~form_csrf () | Error (`Msg msg) -> Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Bad_request) + ~data:(`String (String.escaped msg)) + `Bad_request) let reply reqd ?(content_type = "text/plain") ?(header_list = []) data status = @@ -371,7 +375,8 @@ struct match json with | 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 reqd ~title:"Error" + ~data:(`String (String.escaped err)) `Bad_request | Ok (`Assoc json_dict) -> ( let validate_user_input ~name ~email ~password ~form_csrf = @@ -401,7 +406,8 @@ struct match validate_user_input ~name ~email ~password ~form_csrf with | Error err -> Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped err) `Bad_request + ~data:(`String (String.escaped err)) + `Bad_request | Ok _ -> if Middleware.csrf_cookie_verification form_csrf reqd then let existing_email = Store.find_by_email store email in @@ -409,11 +415,11 @@ struct match (existing_name, existing_email) with | Some _, None -> Middleware.http_response reqd ~title:"Error" - ~data:"A user with this name already exist." + ~data:(`String "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." + ~data:(`String "A user with this email already exist.") `Bad_request | None, None -> ( let created_at = Ptime.v (P.now_d_ps ()) in @@ -440,32 +446,34 @@ struct in Middleware.http_response reqd ~header_list ~title:"Success" - ~data: - (Yojson.Basic.to_string - (User_model.user_to_json user)) + ~data:(User_model.user_to_json user) `OK | Error (`Msg err) -> Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped err) `Bad_request) + ~data:(`String (String.escaped err)) + `Bad_request) | _ -> Middleware.http_response reqd ~title:"Error" - ~data:"A user with this name or email already exist." + ~data: + (`String + "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) + (`String + "CSRF token mismatch error. Please referesh and try \ + again.") `Bad_request) | _ -> Middleware.http_response reqd ~title:"Error" ~data: - (Fmt.str "Register: Unexpected fields. Got %s" - (Yojson.Basic.to_string (`Assoc json_dict))) + (`String + (Fmt.str "Register: Unexpected fields. Got %s" + (Yojson.Basic.to_string (`Assoc json_dict)))) `Bad_request) | _ -> Middleware.http_response reqd ~title:"Error" - ~data:"Register account: expected a dictionary" `Bad_request + ~data:(`String "Register account: expected a dictionary") `Bad_request let login store reqd = decode_request_body reqd >>= fun data -> @@ -476,7 +484,8 @@ struct match json with | 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 reqd ~title:"Error" + ~data:(`String (String.escaped err)) `Bad_request | Ok (`Assoc json_dict) -> ( let validate_user_input ~email ~password = @@ -492,7 +501,8 @@ struct match validate_user_input ~email ~password with | Error err -> Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped err) `Bad_request + ~data:(`String (String.escaped err)) + `Bad_request | Ok _ -> ( let now = Ptime.v (P.now_d_ps ()) in let user = Store.find_by_email store email in @@ -503,7 +513,8 @@ struct with | Error (`Msg err) -> Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped err) `Bad_request + ~data:(`String (String.escaped err)) + `Bad_request | Ok (user, cookie) -> ( Store.update_user store user >>= function | Ok () -> @@ -519,22 +530,22 @@ struct in Middleware.http_response reqd ~header_list ~title:"Success" - ~data: - (Yojson.Basic.to_string - (User_model.user_to_json user)) + ~data:(User_model.user_to_json user) `OK | Error (`Msg err) -> Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped err) `Internal_server_error))) + ~data:(`String (String.escaped err)) + `Internal_server_error))) | _ -> Middleware.http_response reqd ~title:"Error" ~data: - (Fmt.str "Update password: Unexpected fields. Got %s" - (Yojson.Basic.to_string (`Assoc json_dict))) + (`String + (Fmt.str "Update password: Unexpected fields. Got %s" + (Yojson.Basic.to_string (`Assoc json_dict)))) `Bad_request) | _ -> Middleware.http_response reqd ~title:"Error" - ~data:"Update password: expected a dictionary" `Bad_request + ~data:(`String "Update password: expected a dictionary") `Bad_request let verify_email store reqd ~json_dict:_ (user : User_model.user) = let now = Ptime.v (P.now_d_ps ()) in @@ -559,7 +570,8 @@ struct `OK) | Error (`Msg err) -> Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped err) `Internal_server_error) + ~data:(`String (String.escaped err)) + `Internal_server_error) | Error err -> Lwt.return (reply reqd ~content_type:"text/html" @@ -586,10 +598,12 @@ struct | Ok () -> Middleware.redirect_to_dashboard reqd () | Error (`Msg msg) -> Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped msg) `Internal_server_error + ~data:(`String (String.escaped msg)) + `Internal_server_error else Middleware.http_response reqd ~title:"Error" - ~data:"Logged in user is not the to-be-verified one" `Bad_request + ~data:(`String "Logged in user is not the to-be-verified one") + `Bad_request | Error (`Msg s) -> Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true ~with_error:true reqd ~msg:s () @@ -602,7 +616,7 @@ struct | None -> Logs.warn (fun m -> m "%s : Account not found" key); Middleware.http_response reqd ~title:"Error" - ~data:"Account not found" `Not_found + ~data:(`String "Account not found") `Not_found | Some user -> ( if error_on_last user then ( Logs.warn (fun m -> @@ -614,15 +628,15 @@ struct Store.update_user store updated_user >>= function | Ok () -> Middleware.http_response reqd ~title:"OK" - ~data:"Updated user successfully" `OK + ~data:(`String "Updated user successfully") `OK | Error (`Msg msg) -> Logs.warn (fun m -> m "%s : Storage error with %s" key msg); - Middleware.http_response reqd ~title:"Error" ~data:msg - `Internal_server_error)) + Middleware.http_response reqd ~title:"Error" + ~data:(`String msg) `Internal_server_error)) | _ -> Logs.warn (fun m -> m "%s: Failed to parse JSON - no UUID found" key); Middleware.http_response reqd ~title:"Error" - ~data:"Couldn't find a UUID in the JSON." `Not_found + ~data:(`String "Couldn't find a UUID in the JSON.") `Not_found let toggle_account_activation ~json_dict store reqd _user = toggle_account_attribute json_dict store reqd ~key:"toggle-active-account" @@ -631,7 +645,7 @@ struct ~updated_at:(Ptime.v (P.now_d_ps ())) ()) (fun user -> user.active && Store.count_active store <= 1) - ~error_message:"Cannot deactivate last active user" + ~error_message:(`String "Cannot deactivate last active user") let toggle_admin_activation ~json_dict store reqd _user = toggle_account_attribute json_dict store reqd ~key:"toggle-admin-account" @@ -640,7 +654,7 @@ struct ~updated_at:(Ptime.v (P.now_d_ps ())) ()) (fun user -> user.super_user && Store.count_superusers store <= 1) - ~error_message:"Cannot remove last administrator" + ~error_message:(`String "Cannot remove last administrator") let dashboard store albatross reqd ~json_dict:_ (user : User_model.user) = let now = Ptime.v (P.now_d_ps ()) in @@ -693,7 +707,7 @@ struct Utils.Status.code = 401; title = "Unauthenticated"; success = false; - data = err; + data = `String err; } in Lwt.return @@ -724,13 +738,15 @@ struct ~uuid:user.uuid)) then Middleware.http_response reqd ~title:"Error" - ~data:"The current password entered is wrong." `Bad_request + ~data:(`String "The current password entered is wrong.") + `Bad_request else if not (String.equal new_password confirm_password) then Middleware.http_response reqd ~title:"Error" - ~data:"New password and confirm password do not match" `Bad_request + ~data:(`String "New password and confirm password do not match") + `Bad_request else if not (User_model.password_validation new_password) then Middleware.http_response reqd ~title:"Error" - ~data:"New password must be atleast 8 characters." + ~data:(`String "New password must be atleast 8 characters.") `Internal_server_error else let updated_user = @@ -740,16 +756,17 @@ struct Store.update_user store updated_user >>= function | Ok () -> Middleware.http_response reqd ~title:"OK" - ~data:"Updated password successfully" `OK + ~data:(`String "Updated password successfully") `OK | Error (`Msg err) -> Logs.warn (fun m -> m "Storage error with %s" err); - Middleware.http_response reqd ~title:"Error" ~data:err + Middleware.http_response reqd ~title:"Error" ~data:(`String err) `Internal_server_error) | _ -> Middleware.http_response reqd ~title:"Error" ~data: - (Fmt.str "Update password: Unexpected fields. Got %s" - (Yojson.Basic.to_string (`Assoc json_dict))) + (`String + (Fmt.str "Update password: Unexpected fields. Got %s" + (Yojson.Basic.to_string (`Assoc json_dict)))) `Bad_request let new_user_cookies ~user ~filter ~redirect store reqd = @@ -762,7 +779,7 @@ struct | Ok () -> redirect | Error (`Msg err) -> Logs.warn (fun m -> m "Storage error with %s" err); - Middleware.http_response reqd ~title:"Error" ~data:err + Middleware.http_response reqd ~title:"Error" ~data:(`String err) `Internal_server_error let close_sessions ?to_logout_cookie ?(logout = false) store reqd ~json_dict:_ @@ -779,12 +796,12 @@ struct (String.equal c.name User_model.session_cookie && c.value <> cookie.value)), Middleware.http_response reqd ~title:"OK" - ~data:"Closed all sessions succesfully" `OK ) + ~data:(`String "Closed all sessions succesfully") `OK ) | _, true -> ( (fun (c : User_model.cookie) -> not (String.equal c.value cookie.value)), Middleware.http_response reqd ~title:"OK" - ~data:"Logout succesful" `OK ) + ~data:(`String "Logout succesful") `OK ) | Some to_logout_cookie_value, false -> ( (fun (c : User_model.cookie) -> not (String.equal to_logout_cookie_value c.value)), @@ -798,7 +815,7 @@ struct Utils.Status.code = 401; title = "Unauthenticated"; success = false; - data = "Auth cookie not found"; + data = `String "Auth cookie not found"; } in Lwt.return @@ -813,7 +830,7 @@ struct Utils.Status.code = 401; title = "Unauthenticated"; success = false; - data = err; + data = `String err; } in Lwt.return @@ -879,13 +896,15 @@ struct >>= fun new_albatross -> albatross := new_albatross; Middleware.http_response reqd ~title:"Success" - ~data:"Configuration updated successfully" `OK + ~data:(`String "Configuration updated successfully") `OK | Error (`Msg err) -> Middleware.http_response reqd ~title:"Error" - ~data:(String.escaped err) `Internal_server_error) + ~data:(`String (String.escaped err)) + `Internal_server_error) | Error (`Msg err) -> - Middleware.http_response ~title:"Error" ~data:(String.escaped err) reqd - `Bad_request + Middleware.http_response ~title:"Error" + ~data:(`String (String.escaped err)) + reqd `Bad_request let deploy_form store reqd ~json_dict:_ (user : User_model.user) = let now = Ptime.v (P.now_d_ps ()) in @@ -913,19 +932,13 @@ struct >>= function | Error msg -> Middleware.http_response reqd ~title:"Error" - ~data: - (Yojson.Basic.to_string - (`String ("Error while querying albatross: " ^ msg))) + ~data:(`String ("Error while 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.Basic.to_string res) - `OK + | Ok res -> Middleware.http_response reqd ~title:"Success" ~data:res `OK | Error (`String res) -> - Middleware.http_response reqd ~title:"Error" - ~data:(Yojson.Basic.to_string (`String res)) + Middleware.http_response reqd ~title:"Error" ~data:(`String res) `Internal_server_error) let unikernel_info_one albatross store name reqd ~json_dict:_ @@ -978,7 +991,7 @@ struct Utils.Status.code = 500; title = "An error occured"; success = false; - data = "Error while fetching unikernel."; + data = `String "Error while fetching unikernel."; } in Lwt.return @@ -998,21 +1011,18 @@ struct | Error msg -> Logs.err (fun m -> m "Error querying albatross: %s" msg); Middleware.http_response reqd ~title:"Error" - ~data:("Error querying albatross: " ^ msg) + ~data:(`String ("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.Basic.to_string res) - `OK + Middleware.http_response reqd ~title:"Success" ~data:res `OK | Error (`String res) -> - Middleware.http_response reqd ~title:"Error" - ~data:(Yojson.Basic.to_string (`String res)) + Middleware.http_response reqd ~title:"Error" ~data:(`String res) `Internal_server_error)) | _ -> Middleware.http_response reqd ~title:"Error" - ~data:"Couldn't find unikernel name in json" `Bad_request + ~data:(`String "Couldn't find unikernel name in json") `Bad_request let unikernel_restart ~json_dict albatross reqd (user : User_model.user) = (* TODO use uuid in the future *) @@ -1024,27 +1034,24 @@ struct | Error msg -> Logs.err (fun m -> m "Error querying albatross: %s" msg); Middleware.http_response reqd ~title:"Error" - ~data:("Error querying albatross: " ^ msg) + ~data:(`String ("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.Basic.to_string res) - `OK + Middleware.http_response reqd ~title:"Success" ~data:res `OK | Error (`String res) -> - Middleware.http_response reqd ~title:"Error" - ~data:(Yojson.Basic.to_string (`String res)) + Middleware.http_response reqd ~title:"Error" ~data:(`String res) `Internal_server_error)) | _ -> Middleware.http_response reqd ~title:"Error" - ~data:"Couldn't find unikernel name in json" `Bad_request + ~data:(`String "Couldn't find unikernel name in json") `Bad_request let unikernel_create albatross reqd ~json_dict:_ (user : User_model.user) = read_multipart_data reqd >>= function | Error (`Msg msg) -> Middleware.http_response reqd ~title:"Error" - ~data:("Couldn't multipart: " ^ msg) + ~data:(`String ("Couldn't multipart: " ^ msg)) `Bad_request | Ok (m, assoc) -> ( let m, _r = to_map ~assoc m in @@ -1072,27 +1079,26 @@ struct Logs.warn (fun m -> m "Error querying albatross: %s" err); Middleware.http_response reqd ~title:"Error" - ~data:("Error while querying Albatross: " ^ err) + ~data: + (`String ("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.Basic.to_string res) - `OK + ~data:res `OK | Error (`String res) -> Middleware.http_response reqd ~title:"Error" - ~data:(Yojson.Basic.to_string (`String res)) - `Internal_server_error)) + ~data:(`String res) `Internal_server_error)) | Error (`Msg err) -> Logs.warn (fun m -> m "couldn't decode data %s" err); - Middleware.http_response reqd ~title:"Error" ~data:err - `Internal_server_error) + Middleware.http_response reqd ~title:"Error" + ~data:(`String err) `Internal_server_error) reqd | _ -> Logs.warn (fun m -> m "couldn't find fields"); Middleware.http_response reqd ~title:"Error" - ~data:"Couldn't find fields" `Bad_request) + ~data:(`String "Couldn't find fields") `Bad_request) let unikernel_console albatross name reqd ~json_dict:_ (user : User_model.user) = @@ -1101,7 +1107,7 @@ struct | Error err -> Logs.warn (fun m -> m "error querying albatross: %s" err); Middleware.http_response reqd ~title:"Error" - ~data:("Error while querying Albatross: " ^ err) + ~data:(`String ("Error while querying Albatross: " ^ err)) `Internal_server_error | Ok (_, console_output) -> let console_output = @@ -1147,7 +1153,7 @@ struct { Utils.Status.code = 404; title = "Error"; - data = "Couldn't find account with uuid: " ^ uuid; + data = `String ("Couldn't find account with uuid: " ^ uuid); success = false; } in @@ -1196,7 +1202,7 @@ struct { Utils.Status.code = 500; title = "Error"; - data = "Policy error: " ^ err; + data = `String ("Policy error: " ^ err); success = false; } in @@ -1211,7 +1217,7 @@ struct { Utils.Status.code = 404; title = "Error"; - data = "Couldn't find account with uuid: " ^ uuid; + data = `String ("Couldn't find account with uuid: " ^ uuid); success = false; } in @@ -1241,7 +1247,8 @@ struct root_policy err); Middleware.http_response reqd ~title:"Error" ~data: - ("policy is not smaller than root policy: " ^ err) + (`String + ("Policy is not smaller than root policy: " ^ err)) `Internal_server_error | Ok () -> ( Albatross.set_policy albatross ~domain:u.name policy @@ -1251,18 +1258,17 @@ struct 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) + ~data:(`String ("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)) + ~data:(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 + ~data:(`String "Root policy is null") + `Internal_server_error | Error err -> Logs.err (fun m -> m @@ -1270,19 +1276,20 @@ struct policy: %s" err); Middleware.http_response reqd ~title:"Error" - ~data:("error with root policy: " ^ err) + ~data:(`String ("error with root policy: " ^ err)) `Internal_server_error) | Error (`Msg err) -> - Middleware.http_response reqd ~title:"Error" ~data:err + Middleware.http_response reqd ~title:"Error" ~data:(`String err) `Bad_request) | None -> - Middleware.http_response reqd ~title:"Error" ~data:"User not found" - `Not_found) + Middleware.http_response reqd ~title:"Error" + ~data:(`String "User not found") `Not_found) | _ -> Middleware.http_response reqd ~title:"Error" ~data: - (Fmt.str "Update policy: Unexpected fields. Got %s" - (Yojson.Basic.to_string (`Assoc json_dict))) + (`String + (Fmt.str "Update policy: Unexpected fields. Got %s" + (Yojson.Basic.to_string (`Assoc json_dict)))) `Bad_request let volumes store albatross reqd ~json_dict:_ (user : User_model.user) = @@ -1320,28 +1327,25 @@ struct | Error msg -> Logs.err (fun m -> m "Error querying albatross: %s" msg); Middleware.http_response reqd ~title:"Error" - ~data:("Error querying albatross: " ^ msg) + ~data:(`String ("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.Basic.to_string res) - `OK + Middleware.http_response reqd ~title:"Success" ~data:res `OK | Error (`String res) -> - Middleware.http_response reqd ~title:"Error" - ~data:(Yojson.Basic.to_string (`String res)) + Middleware.http_response reqd ~title:"Error" ~data:(`String res) `Internal_server_error)) | _ -> Middleware.http_response reqd ~title:"Error" - ~data:"Couldn't find block name in json" `Bad_request + ~data:(`String "Couldn't find block name in json") `Bad_request let create_volume albatross reqd ~json_dict:_ (user : User_model.user) = read_multipart_data reqd >>= fun result -> match result with | Error (`Msg msg) -> Middleware.http_response reqd ~title:"Error" - ~data:("Couldn't multipart: " ^ msg) + ~data:(`String ("Couldn't multipart: " ^ msg)) `Bad_request | Ok (m, assoc) -> ( let m, _r = to_map ~assoc m in @@ -1377,32 +1381,33 @@ struct Logs.err (fun m -> m "Error querying albatross: %s" msg); Middleware.http_response reqd ~title:"Error" - ~data:("Error querying albatross: " ^ msg) + ~data: + (`String ("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.Basic.to_string res) - `OK + ~data:res `OK | Error (`String res) -> Middleware.http_response reqd ~title:"Error" - ~data:(Yojson.Basic.to_string (`String res)) - `Internal_server_error)) + ~data:(`String res) `Internal_server_error)) reqd | _ -> Middleware.http_response reqd ~title:"Error" ~data: - (Fmt.str "Create volume: Unexpected fields. Got %s" - (Yojson.Basic.to_string (`Assoc json_dict))) + (`String + (Fmt.str "Create volume: Unexpected fields. Got %s" + (Yojson.Basic.to_string (`Assoc json_dict)))) `Bad_request) | _ -> Middleware.http_response reqd ~title:"Error" - ~data:"Create volume: expected a dictionary" `Bad_request) + ~data:(`String "Create volume: expected a dictionary") + `Bad_request) | _ -> Logs.warn (fun m -> m "couldn't find fields"); Middleware.http_response reqd ~title:"Error" - ~data:"Couldn't find fields" `Bad_request) + ~data:(`String "Couldn't find fields") `Bad_request) let download_volume albatross reqd ~json_dict (user : User_model.user) = match @@ -1415,7 +1420,7 @@ struct | Error msg -> Logs.err (fun m -> m "Error querying albatross: %s" msg); Middleware.http_response reqd ~title:"Error" - ~data:("Error querying albatross: " ^ msg) + ~data:(`String ("Error querying albatross: " ^ msg)) `Internal_server_error | Ok (_hdr, res) -> ( match Albatross_json.res res with @@ -1428,18 +1433,17 @@ struct file_content `OK |> Lwt.return | Error (`String res) -> - Middleware.http_response reqd ~title:"Error" - ~data:(Yojson.Basic.to_string (`String res)) + Middleware.http_response reqd ~title:"Error" ~data:(`String res) `Internal_server_error)) | _ -> Middleware.http_response reqd ~title:"Error" - ~data:"Couldn't find block name in json" `Bad_request + ~data:(`String "Couldn't find block name in json") `Bad_request let upload_to_volume albatross reqd ~json_dict:_ (user : User_model.user) = read_multipart_data reqd >>= function | Error (`Msg msg) -> Middleware.http_response reqd ~title:"Error" - ~data:("Couldn't multipart: " ^ msg) + ~data:(`String ("Couldn't multipart: " ^ msg)) `Bad_request | Ok (m, assoc) -> ( let m, _r = to_map ~assoc m in @@ -1472,32 +1476,33 @@ struct Logs.err (fun m -> m "Error querying albatross: %s" msg); Middleware.http_response reqd ~title:"Error" - ~data:("Error querying albatross: " ^ msg) + ~data: + (`String ("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.Basic.to_string res) - `OK + ~data:res `OK | Error (`String res) -> Middleware.http_response reqd ~title:"Error" - ~data:(Yojson.Basic.to_string (`String res)) - `Internal_server_error)) + ~data:(`String res) `Internal_server_error)) reqd | _ -> Middleware.http_response reqd ~title:"Error" ~data: - (Fmt.str "Upload to volume: Unexpected fields. Got %s" - (Yojson.Basic.to_string (`Assoc json_dict))) + (`String + (Fmt.str "Upload to volume: Unexpected fields. Got %s" + (Yojson.Basic.to_string (`Assoc json_dict)))) `Bad_request) | _ -> Middleware.http_response reqd ~title:"Error" - ~data:"Upload to volume: expected a dictionary" `Bad_request) + ~data:(`String "Upload to volume: expected a dictionary") + `Bad_request) | _ -> Logs.warn (fun m -> m "couldn't find fields"); Middleware.http_response reqd ~title:"Error" - ~data:"Couldn't find fields" `Bad_request) + ~data:(`String "Couldn't find fields") `Bad_request) let account_usage store albatross reqd ~json_dict:_ (user : User_model.user) = let now = Ptime.v (P.now_d_ps ()) in @@ -1562,17 +1567,18 @@ struct Store.update_user store updated_user >>= function | Ok () -> Middleware.http_response reqd ~title:"Success" - ~data:(User_model.token_to_json token |> Yojson.Basic.to_string) + ~data:(User_model.token_to_json token) `OK | Error (`Msg err) -> Logs.warn (fun m -> m "Storage error with %s" err); - Middleware.http_response reqd ~title:"Error" ~data:err + Middleware.http_response reqd ~title:"Error" ~data:(`String err) `Internal_server_error) | _ -> Middleware.http_response reqd ~title:"Error" ~data: - (Fmt.str "Create token: Unexpected fields. Got %s" - (Yojson.Basic.to_string (`Assoc json_dict))) + (`String + (Fmt.str "Create token: Unexpected fields. Got %s" + (Yojson.Basic.to_string (`Assoc json_dict)))) `Bad_request let delete_token store reqd ~json_dict (user : User_model.user) = @@ -1591,16 +1597,17 @@ struct Store.update_user store updated_user >>= function | Ok () -> Middleware.http_response reqd ~title:"Success" - ~data:"Token deleted succesfully" `OK + ~data:(`String "Token deleted succesfully") `OK | Error (`Msg err) -> Logs.warn (fun m -> m "Storage error with %s" err); - Middleware.http_response reqd ~title:"Error" ~data:err + Middleware.http_response reqd ~title:"Error" ~data:(`String err) `Internal_server_error) | _ -> Middleware.http_response reqd ~title:"Error" ~data: - (Fmt.str "Delete token: Unexpected fields. Got %s" - (Yojson.Basic.to_string (`Assoc json_dict))) + (`String + (Fmt.str "Delete token: Unexpected fields. Got %s" + (Yojson.Basic.to_string (`Assoc json_dict)))) `Bad_request let update_token store reqd ~json_dict (user : User_model.user) = @@ -1634,19 +1641,21 @@ struct Store.update_user store updated_user >>= function | Ok () -> Middleware.http_response reqd ~title:"Success" - ~data:"Token updated succesfully" `OK + ~data:(User_model.token_to_json updated_token) + `OK | Error (`Msg err) -> Logs.warn (fun m -> m "Storage error with %s" err); - Middleware.http_response reqd ~title:"Error" ~data:err + Middleware.http_response reqd ~title:"Error" ~data:(`String err) `Internal_server_error) | None -> - Middleware.http_response reqd ~title:"Error" ~data:"Token not found" - `Bad_request) + Middleware.http_response reqd ~title:"Error" + ~data:(`String "Token not found") `Bad_request) | _ -> Middleware.http_response reqd ~title:"Error" ~data: - (Fmt.str "Update token: Unexpected fields. Got %s" - (Yojson.Basic.to_string (`Assoc json_dict))) + (`String + (Fmt.str "Update token: Unexpected fields. Got %s" + (Yojson.Basic.to_string (`Assoc json_dict)))) `Bad_request let request_handler stack albatross js_file css_file imgs store @@ -1654,7 +1663,7 @@ struct Lwt.async (fun () -> let bad_request () = Middleware.http_response reqd ~title:"Error" - ~data:"Bad HTTP request method." `Bad_request + ~data:(`String "Bad HTTP request method.") `Bad_request in let req = Httpaf.Reqd.request reqd in let path = @@ -1741,7 +1750,9 @@ struct (close_sessions ~to_logout_cookie store reqd) | _ -> Middleware.http_response reqd ~title:"Error" - ~data:"An error occured. Please refresh and try again" + ~data: + (`String + "An error occured. Please refresh and try again") `Bad_request) | "/volumes" -> check_meth `GET (fun () -> @@ -1854,7 +1865,7 @@ struct Utils.Status.code = 404; title = "Page not found"; success = false; - data = "This page cannot be found."; + data = `String "This page cannot be found."; } in Lwt.return diff --git a/user_model.ml b/user_model.ml index 4ace8fe0..d402d753 100644 --- a/user_model.ml +++ b/user_model.ml @@ -40,7 +40,7 @@ let week = 604800 (* a week = 7 days * 24 hours * 60 minutes * 60 seconds *) let session_cookie = "molly_session" let csrf_cookie = "molly_csrf" -let cookie_to_json (cookie : cookie) : Yojson.Basic.t = +let cookie_to_json (cookie : cookie) = `Assoc [ ("name", `String cookie.name); @@ -174,7 +174,7 @@ let cookie_of_json = function ("invalid json for cookie, expected a dict: " ^ Yojson.Basic.to_string js)) -let token_to_json t : Yojson.Basic.t = +let token_to_json t = `Assoc [ ("token_type", `String t.token_type); @@ -277,7 +277,7 @@ let token_of_json = function ("invalid json for token: expected a dict: " ^ Yojson.Basic.to_string js)) -let user_to_json (u : user) : Yojson.Basic.t = +let user_to_json (u : user) = `Assoc [ ("name", `String u.name); diff --git a/utils.ml b/utils.ml index 9e3425aa..55c033de 100644 --- a/utils.ml +++ b/utils.ml @@ -80,7 +80,7 @@ module Email = struct end module Status = struct - type t = { code : int; title : string; data : string; success : bool } + type t = { code : int; title : string; data : Yojson.Basic.t; success : bool } let to_json (status : t) : string = `Assoc @@ -88,7 +88,7 @@ module Status = struct ("status", `Int status.code); ("title", `String status.title); ("success", `Bool status.success); - ("data", `String status.data); + ("data", status.data); ] |> Yojson.Basic.to_string end From c0caddb493426ee00154b1c134d10918675289a7 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Sun, 8 Dec 2024 15:39:20 +0100 Subject: [PATCH 09/23] convert session close request method from get to post --- assets/main.js | 31 +++++++++++++++++++++++++++- unikernel.ml | 54 ++++++++++++++++++++++++++++++++----------------- user_account.ml | 30 +++++++++++++-------------- 3 files changed, 81 insertions(+), 34 deletions(-) diff --git a/assets/main.js b/assets/main.js index a6d9a65b..9920d45a 100644 --- a/assets/main.js +++ b/assets/main.js @@ -483,7 +483,7 @@ async function closeSessions() { try { buttonLoading(sessionButton, true, "Closing sessions..") const molly_csrf = document.getElementById("molly-csrf").value; - const response = await fetch('/account/sessions/close', { + const response = await fetch('/api/account/sessions/close', { method: 'POST', body: JSON.stringify( { @@ -506,6 +506,35 @@ async function closeSessions() { } } +async function closeSession(session_value) { + const sessionButton = document.getElementById(`session-button-${session_value}`); + try { + buttonLoading(sessionButton, true, "Closing session..") + const molly_csrf = document.getElementById("molly-csrf").value; + const response = await fetch('/api/account/session/close', { + method: 'POST', + body: JSON.stringify( + { + session_value, + molly_csrf, + }), + headers: { 'Content-Type': 'application/json' } + }); + + const data = await response.json(); + if (response.status === 200) { + postAlert("bg-primary-300", data.data); + setTimeout(() => window.location.reload(), 1000); + } else { + postAlert("bg-secondary-300", data.data); + buttonLoading(sessionButton, false, "Close session") + } + } catch (error) { + postAlert("bg-secondary-300", error); + buttonLoading(sessionButton, false, "Close session") + } +} + async function logout() { const logoutButton = document.getElementById("logout-button"); try { diff --git a/unikernel.ml b/unikernel.ml index b38b730e..e8d86abc 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -689,7 +689,7 @@ struct (Dashboard.dashboard_layout ~csrf user ~page_title:"Account | Mollymawk" ~content: - (User_account.user_account_layout ~csrf user + (User_account.user_account_layout user ~active_cookie_value now) ~icon:"/images/robur.png" ()) ~header_list:[ ("X-MOLLY-CSRF", csrf) ] @@ -840,6 +840,36 @@ struct ~icon:"/images/robur.png" ()) `Unauthorized) + let close_session store reqd ~json_dict (user : User_model.user) = + Logs.warn (fun m -> m "We got here"); + match Utils.Json.(get "session_value" json_dict) with + | Some (`String session_value) -> ( + let now = Ptime.v (P.now_d_ps ()) in + let cookies = + List.filter + (fun (cookie : User_model.cookie) -> + not (String.equal cookie.value session_value)) + user.cookies + in + let updated_user = + User_model.update_user user ~cookies ~updated_at:now () + in + Store.update_user store updated_user >>= function + | Ok () -> + Middleware.http_response reqd ~title:"Success" + ~data:(`String "Session closed succesfully") `OK + | Error (`Msg err) -> + Logs.warn (fun m -> m "Storage error with %s" err); + Middleware.http_response reqd ~title:"Error" ~data:(`String err) + `Internal_server_error) + | _ -> + Middleware.http_response reqd ~title:"Error" + ~data: + (`String + (Fmt.str "Close session: Unexpected fields. Got %s" + (Yojson.Basic.to_string (`Assoc json_dict)))) + `Bad_request + let users store reqd ~json_dict:_ (user : User_model.user) = let now = Ptime.v (P.now_d_ps ()) in generate_csrf_token store user now reqd >>= function @@ -1730,7 +1760,7 @@ struct check_meth `POST (fun () -> authenticate ~check_csrf:true store reqd (update_password store reqd)) - | "/account/sessions/close" -> + | "/api/account/sessions/close" -> check_meth `POST (fun () -> authenticate ~check_csrf:true store reqd (close_sessions store reqd)) @@ -1738,22 +1768,10 @@ struct check_meth `POST (fun () -> authenticate ~check_csrf:true store reqd (close_sessions ~logout:true store reqd)) - | path when String.starts_with ~prefix:"/account/session/close/" path -> - check_meth `GET (fun () -> - match - String.split_on_char '/' - (String.sub path 23 (String.length path - 23)) - with - (* TODO: Find a way to do CSRF verification here or change to Post request*) - | [ to_logout_cookie ] -> - authenticate store reqd - (close_sessions ~to_logout_cookie store reqd) - | _ -> - Middleware.http_response reqd ~title:"Error" - ~data: - (`String - "An error occured. Please refresh and try again") - `Bad_request) + | "/api/account/session/close" -> + check_meth `POST (fun () -> + authenticate ~check_csrf:true store reqd + (close_session store reqd)) | "/volumes" -> check_meth `GET (fun () -> authenticate store reqd (volumes store !albatross reqd)) diff --git a/user_account.ml b/user_account.ml index cfd88061..68f6c9e0 100644 --- a/user_account.ml +++ b/user_account.ml @@ -1,4 +1,4 @@ -let user_account_layout ~csrf (user : User_model.user) ~active_cookie_value +let user_account_layout (user : User_model.user) ~active_cookie_value current_time = Tyxml_html.( section @@ -304,21 +304,21 @@ let user_account_layout ~csrf (user : User_model.user) ~active_cookie_value (String.equal cookie.value active_cookie_value) then - a - ~a: - [ - a_href - ("account/session/close/" - ^ cookie.value ^ "/" ^ csrf); - a_class + div + [ + Utils.button_component + ~attribs: [ - "hover:text-secondary-800 \ - text-secondary-500 \ - transition-colors \ - cursor-pointer"; - ]; - ] - [ txt "Close session" ] + a_id + ("session-button-" + ^ cookie.value); + a_onclick + ("closeSession('" + ^ cookie.value ^ "')"); + ] + ~content:(txt "Close session") + ~btn_type:`Danger_outlined (); + ] else div []); ]; ]) From 64cbbfdce802de254673df2fac67845b28d5fb9e Mon Sep 17 00:00:00 2001 From: PizieDust Date: Mon, 9 Dec 2024 14:54:00 +0100 Subject: [PATCH 10/23] remove comment --- unikernel.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/unikernel.ml b/unikernel.ml index e8d86abc..26c90c09 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -841,7 +841,6 @@ struct `Unauthorized) let close_session store reqd ~json_dict (user : User_model.user) = - Logs.warn (fun m -> m "We got here"); match Utils.Json.(get "session_value" json_dict) with | Some (`String session_value) -> ( let now = Ptime.v (P.now_d_ps ()) in From 4cfd629d57a4a245e322c7cd6849c06a3067b1e4 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Mon, 9 Dec 2024 16:12:17 +0100 Subject: [PATCH 11/23] refactor authenticate function --- storage.ml | 32 +++++++++ unikernel.ml | 179 ++++++++++++++++++++++----------------------------- 2 files changed, 110 insertions(+), 101 deletions(-) diff --git a/storage.ml b/storage.ml index 0f3d52ea..487a854e 100644 --- a/storage.ml +++ b/storage.ml @@ -176,6 +176,38 @@ module Make (BLOCK : Mirage_block.S) = struct | None -> None) store.users + let increment_token_usage store (token : User_model.token) + (user : User_model.user) = + let token = { token with usage_count = token.usage_count + 1 } in + let tokens = + List.map + (fun (token' : User_model.token) -> + if String.equal token.value token'.value then token else token') + user.tokens + in + let updated_user = User_model.update_user user ~tokens () in + update_user store updated_user >>= function + | Ok () -> Lwt.return (Ok ()) + | Error (`Msg err) -> + Logs.err (fun m -> m "Error with storage: %s" err); + Lwt.return (Error (`Msg err)) + + let update_cookie_usage store (cookie : User_model.cookie) + (user : User_model.user) reqd = + let cookie = { cookie with user_agent = Middleware.user_agent reqd } in + let cookies = + List.map + (fun (cookie' : User_model.cookie) -> + if String.equal cookie.value cookie'.value then cookie else cookie') + user.cookies + in + let updated_user = User_model.update_user user ~cookies () in + update_user store updated_user >>= function + | Ok () -> Lwt.return (Ok ()) + | Error (`Msg err) -> + Logs.err (fun m -> m "Error with storage: %s" err); + Lwt.return (Error (`Msg err)) + let count_users store = List.length store.users let find_email_verification_token store uuid = diff --git a/unikernel.ml b/unikernel.ml index 26c90c09..707dfc8c 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -141,9 +141,8 @@ struct in go (Map.empty, []) m - let authenticate ?(email_verified = true) ?(check_admin = false) - ?(api_meth = false) ?(check_csrf = false) store reqd f = - let now = Ptime.v (P.now_d_ps ()) in + let process_session_request ?(json_dict = []) ?form_csrf ~api_meth + ~check_admin ~email_verified ~current_time f store reqd = let middlewares ?(form_csrf = None) user = (if check_admin then [ Middleware.is_user_admin_middleware api_meth user ] else []) @@ -151,119 +150,97 @@ struct [ Middleware.email_verified_middleware user ] else []) @ Option.fold ~none:[] - ~some:(fun csrf -> [ Middleware.csrf_verification user now csrf ]) + ~some:(fun csrf -> + [ Middleware.csrf_verification user current_time csrf ]) form_csrf @ [ Middleware.auth_middleware user ] in - let handle_csrf () = - if check_csrf then - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> - Lwt.return (Ok (Some (form_csrf, json_dict))) - | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) - else Lwt.return (Ok None) - in - let process_request ?(json_dict = []) ?form_csrf () = - match Middleware.session_cookie_value reqd with - | Error (`Msg err) -> - Logs.err (fun m -> - m "auth-middleware: No molly-session in cookie header. %s" err); - Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true - ~with_error:true ~msg:"No session cookie found in request." reqd () - | Ok cookie_value -> ( - match Store.find_by_cookie store cookie_value with - | None -> + match Middleware.session_cookie_value reqd with + | Error (`Msg err) -> + Logs.err (fun m -> + m "auth-middleware: No molly-session in cookie header. %s" err); + Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true + ~with_error:true ~msg:"No session cookie found in request." reqd () + | Ok cookie_value -> ( + match Store.find_by_cookie store cookie_value with + | None -> + Logs.err (fun m -> + m "auth-middleware: Failed to find user with key %s" + cookie_value); + Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true + ~with_error:true ~msg:"No user account found." reqd () + | Some (user, cookie) -> + if not (User_model.is_valid_cookie cookie current_time) then ( Logs.err (fun m -> - m "auth-middleware: Failed to find user with key %s" + m + "auth-middleware: Session value doesn't match user session \ + %s" cookie_value); Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true - ~with_error:true ~msg:"No user account found." reqd () - | Some (user, cookie) -> - if not (User_model.is_valid_cookie cookie now) then ( - Logs.err (fun m -> - m - "auth-middleware: Session value doesn't match user \ - session %s" - cookie_value); - Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true - ~with_error:true ~msg:"Session cookie is no longer valid." - reqd ()) - else - Middleware.apply_middleware - (middlewares ~form_csrf user) - (fun reqd -> - let cookie = - { cookie with user_agent = Middleware.user_agent reqd } - in - let cookies = - List.map - (fun (cookie' : User_model.cookie) -> - if String.equal cookie_value cookie'.value then cookie - else cookie') - user.cookies - in - let updated_user = - User_model.update_user user ~cookies () - in - Store.update_user store updated_user >>= function - | Ok () -> f ~json_dict user - | Error (`Msg err) -> - Logs.err (fun m -> m "Error with storage: %s" err); - Middleware.http_response reqd ~title:"Error" - ~data:(`String err) `Not_found) - reqd) - in - match (Middleware.api_authentication reqd, api_meth) with - | Some token_value, true -> ( - extract_json_body reqd >>= function - | Ok json_dict -> ( - match Store.find_by_api_token store token_value with - | Some (user, token) -> - if User_model.is_valid_token token now then ( - let token = - { token with usage_count = token.usage_count + 1 } - in - let tokens = - List.map - (fun (token' : User_model.token) -> - if String.equal token_value token'.value then token - else token') - user.tokens - in - let updated_user = User_model.update_user user ~tokens () in - Store.update_user store updated_user >>= function + ~with_error:true ~msg:"Session cookie is no longer valid." reqd + ()) + else + Middleware.apply_middleware + (middlewares ~form_csrf user) + (fun reqd -> + Store.update_cookie_usage store cookie user reqd >>= function | Ok () -> f ~json_dict user | Error (`Msg err) -> Logs.err (fun m -> m "Error with storage: %s" err); Middleware.http_response reqd ~title:"Error" ~data:(`String err) `Not_found) - else - Middleware.http_response reqd ~title:"Error" - ~data: - (`String - "Authorization token has expired. Please generate a \ - new token from your account dashboard.") - `Not_found - | None -> - Middleware.http_response reqd ~title:"Error" - ~data: - (`String - ("Invalid authorization token. User not found for token " - ^ token_value)) - `Not_found) - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(`String (String.escaped msg)) - `Bad_request) - | _ -> ( - handle_csrf () >>= function - | Ok None -> process_request () - | Ok (Some (form_csrf, json_dict)) -> - process_request ~json_dict ~form_csrf () + reqd) + + let process_api_request ~json_dict ~token_value ~current_time f store reqd = + match Store.find_by_api_token store token_value with + | Some (user, token) -> + if User_model.is_valid_token token current_time then + Store.increment_token_usage store token user >>= function + | Ok () -> f ~json_dict user + | Error (`Msg err) -> + Middleware.http_response reqd ~title:"Error" ~data:(`String err) + `Not_found + else + Middleware.http_response reqd ~title:"Error" + ~data: + (`String + "Authorization token has expired. Please generate a new token \ + from your account dashboard.") + `Not_found + | None -> + Middleware.http_response reqd ~title:"Error" + ~data: + (`String + ("Invalid authorization token. User not found for token " + ^ token_value)) + `Not_found + + let authenticate ?(email_verified = true) ?(check_admin = false) + ?(api_meth = false) ?(check_csrf = false) store reqd f = + let current_time = Ptime.v (P.now_d_ps ()) in + match (Middleware.api_authentication reqd, api_meth) with + | Some token_value, true -> ( + extract_json_body reqd >>= function + | Ok json_dict -> + process_api_request ~json_dict ~token_value ~current_time f store + reqd | Error (`Msg msg) -> Middleware.http_response reqd ~title:"Error" ~data:(`String (String.escaped msg)) `Bad_request) + | _ -> + if check_csrf then + extract_csrf_token reqd >>= function + | Ok (form_csrf, json_dict) -> + process_session_request ~check_admin ~email_verified ~current_time + ~json_dict ~form_csrf ~api_meth f store reqd + | Error (`Msg msg) -> + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped msg)) + `Bad_request + else + process_session_request ~check_admin ~email_verified ~current_time + ~api_meth f store reqd let reply reqd ?(content_type = "text/plain") ?(header_list = []) data status = From 689a63bc5678a0771248000e30f25f16765f1219 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Mon, 9 Dec 2024 16:18:13 +0100 Subject: [PATCH 12/23] prefix some api routes with / --- assets/main.js | 6 +++--- unikernel.ml | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/assets/main.js b/assets/main.js index 9920d45a..1fd439dc 100644 --- a/assets/main.js +++ b/assets/main.js @@ -186,7 +186,7 @@ async function deployUnikernel() { formData.append("arguments", arguments) formData.append("molly_csrf", molly_csrf) try { - const response = await fetch("/unikernel/create", { + const response = await fetch("/api/unikernel/create", { method: 'POST', body: formData }) @@ -219,7 +219,7 @@ async function deployUnikernel() { async function restartUnikernel(name) { try { const molly_csrf = document.getElementById("molly-csrf").value; - const response = await fetch(`/unikernel/restart/${name}`, { + const response = await fetch(`/api/unikernel/restart/${name}`, { method: 'POST', body: JSON.stringify({ "name": name, "molly_csrf": molly_csrf }), headers: { 'Content-Type': 'application/json' } @@ -242,7 +242,7 @@ async function restartUnikernel(name) { async function destroyUnikernel(name) { try { const molly_csrf = document.getElementById("molly-csrf").value; - const response = await fetch(`/unikernel/destroy/${name}`, { + const response = await fetch(`/api/unikernel/destroy/${name}`, { method: 'POST', body: JSON.stringify({ "name": name, "molly_csrf": molly_csrf }), headers: { 'Content-Type': 'application/json' } diff --git a/unikernel.ml b/unikernel.ml index 707dfc8c..c8c1cec9 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -1835,10 +1835,10 @@ struct | "/unikernel/deploy" -> check_meth `GET (fun () -> authenticate store reqd (deploy_form store reqd)) - | "api/unikernel/destroy" -> + | "/api/unikernel/destroy" -> check_meth `POST (fun () -> authenticate store reqd (unikernel_destroy !albatross reqd)) - | "api/unikernel/restart" -> + | "/api/unikernel/restart" -> check_meth `POST (fun () -> authenticate ~check_csrf:true store reqd (unikernel_restart !albatross reqd)) @@ -1849,7 +1849,7 @@ struct in authenticate store reqd (unikernel_console !albatross unikernel_name reqd)) - | "api/unikernel/create" -> + | "/api/unikernel/create" -> check_meth `POST (fun () -> authenticate ~check_csrf:true store reqd (unikernel_create !albatross reqd)) From 35da9aea257a8d68952b767ef941b27e594f40dc Mon Sep 17 00:00:00 2001 From: PizieDust Date: Mon, 9 Dec 2024 16:55:32 +0100 Subject: [PATCH 13/23] escape errors --- unikernel.ml | 109 ++++++++++++++++++++++++++++++++------------------- 1 file changed, 69 insertions(+), 40 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index c8c1cec9..91019ea3 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -188,7 +188,8 @@ struct | Error (`Msg err) -> Logs.err (fun m -> m "Error with storage: %s" err); Middleware.http_response reqd ~title:"Error" - ~data:(`String err) `Not_found) + ~data:(`String (String.escaped err)) + `Not_found) reqd) let process_api_request ~json_dict ~token_value ~current_time f store reqd = @@ -609,7 +610,8 @@ struct | Error (`Msg msg) -> Logs.warn (fun m -> m "%s : Storage error with %s" key msg); Middleware.http_response reqd ~title:"Error" - ~data:(`String msg) `Internal_server_error)) + ~data:(`String (String.escaped msg)) + `Internal_server_error)) | _ -> Logs.warn (fun m -> m "%s: Failed to parse JSON - no UUID found" key); Middleware.http_response reqd ~title:"Error" @@ -736,7 +738,8 @@ struct ~data:(`String "Updated password successfully") `OK | Error (`Msg err) -> Logs.warn (fun m -> m "Storage error with %s" err); - Middleware.http_response reqd ~title:"Error" ~data:(`String err) + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped err)) `Internal_server_error) | _ -> Middleware.http_response reqd ~title:"Error" @@ -756,7 +759,8 @@ struct | Ok () -> redirect | Error (`Msg err) -> Logs.warn (fun m -> m "Storage error with %s" err); - Middleware.http_response reqd ~title:"Error" ~data:(`String err) + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped err)) `Internal_server_error let close_sessions ?to_logout_cookie ?(logout = false) store reqd ~json_dict:_ @@ -836,7 +840,8 @@ struct ~data:(`String "Session closed succesfully") `OK | Error (`Msg err) -> Logs.warn (fun m -> m "Storage error with %s" err); - Middleware.http_response reqd ~title:"Error" ~data:(`String err) + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped err)) `Internal_server_error) | _ -> Middleware.http_response reqd ~title:"Error" @@ -943,8 +948,9 @@ struct | Ok (_hdr, res) -> ( match Albatross_json.res res with | Ok res -> Middleware.http_response reqd ~title:"Success" ~data:res `OK - | Error (`String res) -> - Middleware.http_response reqd ~title:"Error" ~data:(`String res) + | Error (`String err) -> + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped err)) `Internal_server_error) let unikernel_info_one albatross store name reqd ~json_dict:_ @@ -1023,8 +1029,9 @@ struct match Albatross_json.res res with | Ok res -> Middleware.http_response reqd ~title:"Success" ~data:res `OK - | Error (`String res) -> - Middleware.http_response reqd ~title:"Error" ~data:(`String res) + | Error (`String err) -> + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped err)) `Internal_server_error)) | _ -> Middleware.http_response reqd ~title:"Error" @@ -1046,8 +1053,9 @@ struct match Albatross_json.res res with | Ok res -> Middleware.http_response reqd ~title:"Success" ~data:res `OK - | Error (`String res) -> - Middleware.http_response reqd ~title:"Error" ~data:(`String res) + | Error (`String err) -> + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped err)) `Internal_server_error)) | _ -> Middleware.http_response reqd ~title:"Error" @@ -1093,13 +1101,15 @@ struct | Ok res -> Middleware.http_response reqd ~title:"Success" ~data:res `OK - | Error (`String res) -> + | Error (`String err) -> Middleware.http_response reqd ~title:"Error" - ~data:(`String res) `Internal_server_error)) + ~data:(`String (String.escaped err)) + `Internal_server_error)) | Error (`Msg err) -> Logs.warn (fun m -> m "couldn't decode data %s" err); Middleware.http_response reqd ~title:"Error" - ~data:(`String err) `Internal_server_error) + ~data:(`String (String.escaped err)) + `Internal_server_error) reqd | _ -> Logs.warn (fun m -> m "couldn't find fields"); @@ -1119,7 +1129,6 @@ struct let console_output = List.map Albatross_json.console_data_to_json console_output in - Lwt.return (reply reqd ~content_type:"application/json" (Yojson.Basic.to_string (`List console_output)) @@ -1282,10 +1291,13 @@ struct policy: %s" err); Middleware.http_response reqd ~title:"Error" - ~data:(`String ("error with root policy: " ^ err)) + ~data: + (`String + ("error with root policy: " ^ String.escaped err)) `Internal_server_error) | Error (`Msg err) -> - Middleware.http_response reqd ~title:"Error" ~data:(`String err) + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped err)) `Bad_request) | None -> Middleware.http_response reqd ~title:"Error" @@ -1330,17 +1342,20 @@ struct Albatross.query albatross ~domain:user.name ~name:block_name (`Block_cmd `Block_remove) >>= function - | Error msg -> - Logs.err (fun m -> m "Error querying albatross: %s" msg); + | Error err -> + Logs.err (fun m -> + m "Error querying albatross: %s" (String.escaped err)); Middleware.http_response reqd ~title:"Error" - ~data:(`String ("Error querying albatross: " ^ msg)) + ~data: + (`String ("Error querying albatross: " ^ String.escaped err)) `Internal_server_error | Ok (_hdr, res) -> ( match Albatross_json.res res with | Ok res -> Middleware.http_response reqd ~title:"Success" ~data:res `OK - | Error (`String res) -> - Middleware.http_response reqd ~title:"Error" ~data:(`String res) + | Error (`String err) -> + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped err)) `Internal_server_error)) | _ -> Middleware.http_response reqd ~title:"Error" @@ -1383,21 +1398,25 @@ struct (`Block_add (block_size, block_compressed, Some block_data))) >>= function - | Error msg -> + | Error err -> Logs.err (fun m -> - m "Error querying albatross: %s" msg); + m "Error querying albatross: %s" + (String.escaped err)); Middleware.http_response reqd ~title:"Error" ~data: - (`String ("Error querying albatross: " ^ msg)) + (`String + ("Error querying albatross: " + ^ String.escaped err)) `Internal_server_error | Ok (_hdr, res) -> ( match Albatross_json.res res with | Ok res -> Middleware.http_response reqd ~title:"Success" ~data:res `OK - | Error (`String res) -> + | Error (`String err) -> Middleware.http_response reqd ~title:"Error" - ~data:(`String res) `Internal_server_error)) + ~data:(`String (String.escaped err)) + `Internal_server_error)) reqd | _ -> Middleware.http_response reqd ~title:"Error" @@ -1423,10 +1442,12 @@ struct Albatross.query albatross ~domain:user.name ~name:block_name (`Block_cmd (`Block_dump compression_level)) >>= function - | Error msg -> - Logs.err (fun m -> m "Error querying albatross: %s" msg); + | Error err -> + Logs.err (fun m -> + m "Error querying albatross: %s" (String.escaped err)); Middleware.http_response reqd ~title:"Error" - ~data:(`String ("Error querying albatross: " ^ msg)) + ~data: + (`String ("Error querying albatross: " ^ String.escaped err)) `Internal_server_error | Ok (_hdr, res) -> ( match Albatross_json.res res with @@ -1438,8 +1459,9 @@ struct ~header_list:[ ("Content-Disposition", disposition) ] file_content `OK |> Lwt.return - | Error (`String res) -> - Middleware.http_response reqd ~title:"Error" ~data:(`String res) + | Error (`String err) -> + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped err)) `Internal_server_error)) | _ -> Middleware.http_response reqd ~title:"Error" @@ -1478,21 +1500,25 @@ struct (`Block_cmd (`Block_set (block_compressed, block_data))) >>= function - | Error msg -> + | Error err -> Logs.err (fun m -> - m "Error querying albatross: %s" msg); + m "Error querying albatross: %s" + (String.escaped err)); Middleware.http_response reqd ~title:"Error" ~data: - (`String ("Error querying albatross: " ^ msg)) + (`String + ("Error querying albatross: " + ^ String.escaped err)) `Internal_server_error | Ok (_hdr, res) -> ( match Albatross_json.res res with | Ok res -> Middleware.http_response reqd ~title:"Success" ~data:res `OK - | Error (`String res) -> + | Error (`String err) -> Middleware.http_response reqd ~title:"Error" - ~data:(`String res) `Internal_server_error)) + ~data:(`String (String.escaped err)) + `Internal_server_error)) reqd | _ -> Middleware.http_response reqd ~title:"Error" @@ -1577,7 +1603,8 @@ struct `OK | Error (`Msg err) -> Logs.warn (fun m -> m "Storage error with %s" err); - Middleware.http_response reqd ~title:"Error" ~data:(`String err) + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped err)) `Internal_server_error) | _ -> Middleware.http_response reqd ~title:"Error" @@ -1606,7 +1633,8 @@ struct ~data:(`String "Token deleted succesfully") `OK | Error (`Msg err) -> Logs.warn (fun m -> m "Storage error with %s" err); - Middleware.http_response reqd ~title:"Error" ~data:(`String err) + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped err)) `Internal_server_error) | _ -> Middleware.http_response reqd ~title:"Error" @@ -1651,7 +1679,8 @@ struct `OK | Error (`Msg err) -> Logs.warn (fun m -> m "Storage error with %s" err); - Middleware.http_response reqd ~title:"Error" ~data:(`String err) + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped err)) `Internal_server_error) | None -> Middleware.http_response reqd ~title:"Error" From d4e4912c80fb465acb55d8c7aab06ff274cf47d2 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Tue, 10 Dec 2024 11:13:45 +0100 Subject: [PATCH 14/23] check token only on specific routes --- unikernel.ml | 29 ++++++++++++++++++++--------- 1 file changed, 20 insertions(+), 9 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index 91019ea3..667c2f15 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -217,9 +217,10 @@ struct `Not_found let authenticate ?(email_verified = true) ?(check_admin = false) - ?(api_meth = false) ?(check_csrf = false) store reqd f = + ?(api_meth = false) ?(check_csrf = false) ?(check_token = false) store + reqd f = let current_time = Ptime.v (P.now_d_ps ()) in - match (Middleware.api_authentication reqd, api_meth) with + match (Middleware.api_authentication reqd, check_token) with | Some token_value, true -> ( extract_json_body reqd >>= function | Ok json_dict -> @@ -229,6 +230,13 @@ struct Middleware.http_response reqd ~title:"Error" ~data:(`String (String.escaped msg)) `Bad_request) + | Some _token_value, false -> + Middleware.http_response reqd ~title:"Error" + ~data: + (`String + "This endpoint cannot be accessed via the API. Please use the \ + web dashboard.") + `Bad_request | _ -> if check_csrf then extract_csrf_token reqd >>= function @@ -1782,19 +1790,21 @@ struct authenticate store reqd (volumes store !albatross reqd)) | "/api/volume/delete" -> check_meth `POST (fun () -> - authenticate ~check_csrf:true ~api_meth:true store reqd + authenticate ~check_token:true ~check_csrf:true ~api_meth:true + store reqd (delete_volume !albatross reqd)) | "/api/volume/create" -> check_meth `POST (fun () -> - authenticate ~check_csrf:true store reqd + authenticate ~check_token:true ~check_csrf:true store reqd (create_volume !albatross reqd)) | "/api/volume/download" -> check_meth `POST (fun () -> - authenticate ~check_csrf:true ~api_meth:true store reqd + authenticate ~check_token:true ~check_csrf:true ~api_meth:true + store reqd (download_volume !albatross reqd)) | "/api/volume/upload" -> check_meth `POST (fun () -> - authenticate ~check_csrf:true store reqd + authenticate ~check_token:true ~check_csrf:true store reqd (upload_to_volume !albatross reqd)) | "/tokens" -> check_meth `GET (fun () -> @@ -1866,10 +1876,11 @@ struct authenticate store reqd (deploy_form store reqd)) | "/api/unikernel/destroy" -> check_meth `POST (fun () -> - authenticate store reqd (unikernel_destroy !albatross reqd)) + authenticate ~check_token:true store reqd + (unikernel_destroy !albatross reqd)) | "/api/unikernel/restart" -> check_meth `POST (fun () -> - authenticate ~check_csrf:true store reqd + authenticate ~check_token:true ~check_csrf:true store reqd (unikernel_restart !albatross reqd)) | path when String.starts_with ~prefix:"/unikernel/console/" path -> check_meth `GET (fun () -> @@ -1880,7 +1891,7 @@ struct (unikernel_console !albatross unikernel_name reqd)) | "/api/unikernel/create" -> check_meth `POST (fun () -> - authenticate ~check_csrf:true store reqd + authenticate ~check_token:true ~check_csrf:true store reqd (unikernel_create !albatross reqd)) | _ -> let error = From d4c1112c475758655147116501ac3d73840c90be Mon Sep 17 00:00:00 2001 From: Robur Team Date: Wed, 11 Dec 2024 15:18:06 +0000 Subject: [PATCH 15/23] refactor authenticate --- middleware.ml | 15 ---- unikernel.ml | 194 ++++++++++++++++++++++++++------------------------ 2 files changed, 102 insertions(+), 107 deletions(-) diff --git a/middleware.ml b/middleware.ml index d0234d51..f06e2ec9 100644 --- a/middleware.ml +++ b/middleware.ml @@ -139,25 +139,10 @@ let session_cookie_value reqd = m "auth-middleware: No molly-session in cookie header."); Error (`Msg "User not found") -let auth_middleware user handler reqd = - if user.User_model.active then handler reqd - else - redirect_to_page ~path:"/sign-in" ~clear_session:true ~with_error:true - ~msg:"User account is deactivated." reqd () - let email_verified_middleware user handler reqd = if User_model.is_email_verified user then handler reqd else redirect_to_verify_email reqd () -let is_user_admin_middleware api_meth user handler reqd = - if user.User_model.super_user && user.active then handler reqd - else - redirect_to_error ~title:"Unauthorized" - ~data: - (`String - "You don't have the necessary permissions to access this service.") - `Unauthorized 401 api_meth reqd () - let csrf_cookie_verification form_csrf reqd = match cookie User_model.csrf_cookie reqd with | Some cookie -> ( diff --git a/unikernel.ml b/unikernel.ml index 667c2f15..d1ee9f12 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -141,115 +141,125 @@ struct in go (Map.empty, []) m - let process_session_request ?(json_dict = []) ?form_csrf ~api_meth - ~check_admin ~email_verified ~current_time f store reqd = - let middlewares ?(form_csrf = None) user = - (if check_admin then [ Middleware.is_user_admin_middleware api_meth user ] - else []) - @ (if email_verified && false (* TODO *) then + let process_session_request ?(json_dict = []) ?form_csrf + ~email_verified f reqd user = + let current_time = Ptime.v (P.now_d_ps ()) in + let middlewares ~form_csrf user = + (if email_verified && false (* TODO *) then [ Middleware.email_verified_middleware user ] else []) @ Option.fold ~none:[] ~some:(fun csrf -> [ Middleware.csrf_verification user current_time csrf ]) form_csrf - @ [ Middleware.auth_middleware user ] in - match Middleware.session_cookie_value reqd with - | Error (`Msg err) -> - Logs.err (fun m -> - m "auth-middleware: No molly-session in cookie header. %s" err); - Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true - ~with_error:true ~msg:"No session cookie found in request." reqd () - | Ok cookie_value -> ( - match Store.find_by_cookie store cookie_value with - | None -> - Logs.err (fun m -> - m "auth-middleware: Failed to find user with key %s" - cookie_value); - Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true - ~with_error:true ~msg:"No user account found." reqd () - | Some (user, cookie) -> - if not (User_model.is_valid_cookie cookie current_time) then ( - Logs.err (fun m -> - m - "auth-middleware: Session value doesn't match user session \ - %s" - cookie_value); - Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true - ~with_error:true ~msg:"Session cookie is no longer valid." reqd - ()) - else - Middleware.apply_middleware - (middlewares ~form_csrf user) - (fun reqd -> - Store.update_cookie_usage store cookie user reqd >>= function - | Ok () -> f ~json_dict user - | Error (`Msg err) -> - Logs.err (fun m -> m "Error with storage: %s" err); - Middleware.http_response reqd ~title:"Error" - ~data:(`String (String.escaped err)) - `Not_found) - reqd) + Middleware.apply_middleware + (middlewares ~form_csrf user) + (fun reqd -> f ~json_dict user) reqd - let process_api_request ~json_dict ~token_value ~current_time f store reqd = - match Store.find_by_api_token store token_value with - | Some (user, token) -> + let authenticate_user ~check_admin ~check_token store reqd = + let ( let* ) = Result.bind in + let current_time = Ptime.v (P.now_d_ps ()) in + let user_is_active user = + if user.User_model.active then Ok () else Error "User account is deactivated" + in + let user_is_admin user = + if (check_admin && user.User_model.super_user) || not check_admin then + Ok () + else + Error "You don't have the necessary permissions to access this service." + in + let check_cookie reqd = + match Middleware.session_cookie_value reqd with + | Error (`Msg err) -> + Error (`Cookie, "No molly-session in cookie header. %s" ^ err) + | Ok cookie_value -> + match Store.find_by_cookie store cookie_value with + | None -> + Error (`Cookie, "Failed to find user with cookie " ^ cookie_value) + | Some (user, cookie) -> + if User_model.is_valid_cookie cookie current_time then + match + let* () = user_is_active user in + user_is_admin user + with + | Error msg -> Error (`Cookie, msg) + | Ok () -> Ok (`Cookie (user, cookie)) + else + Error (`Cookie, "Session value doesn't match user session " ^ cookie_value) + in + let valid_token token_value = + match Store.find_by_api_token store token_value with + | Some (user, token) -> if User_model.is_valid_token token current_time then - Store.increment_token_usage store token user >>= function - | Ok () -> f ~json_dict user - | Error (`Msg err) -> - Middleware.http_response reqd ~title:"Error" ~data:(`String err) - `Not_found + Ok (user, token) else - Middleware.http_response reqd ~title:"Error" - ~data: - (`String - "Authorization token has expired. Please generate a new token \ - from your account dashboard.") - `Not_found - | None -> - Middleware.http_response reqd ~title:"Error" - ~data: - (`String - ("Invalid authorization token. User not found for token " - ^ token_value)) - `Not_found - + Error (`Token, "Token value is not valid " ^ token_value) + | None -> + Error (`Token, "Failed to find user with token " ^ token_value) + in + if check_token then + match Middleware.api_authentication reqd with + | Some token_value -> ( + let* (user, token) = valid_token token_value in + match + let* () = user_is_active user in + user_is_admin user + with + | Ok () -> Ok (`Token (user, token)) + | Error msg -> Error (`Token, msg)) + | None -> check_cookie reqd + else + check_cookie reqd + let authenticate ?(email_verified = true) ?(check_admin = false) ?(api_meth = false) ?(check_csrf = false) ?(check_token = false) store reqd f = - let current_time = Ptime.v (P.now_d_ps ()) in - match (Middleware.api_authentication reqd, check_token) with - | Some token_value, true -> ( - extract_json_body reqd >>= function - | Ok json_dict -> - process_api_request ~json_dict ~token_value ~current_time f store - reqd - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(`String (String.escaped msg)) - `Bad_request) - | Some _token_value, false -> + match authenticate_user ~check_admin ~check_token store reqd with + | Error (`Cookie, msg) -> + Logs.err (fun m -> m "authenticate: %s" msg); + if api_meth then Middleware.http_response reqd ~title:"Error" - ~data: - (`String - "This endpoint cannot be accessed via the API. Please use the \ - web dashboard.") - `Bad_request - | _ -> - if check_csrf then - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> - process_session_request ~check_admin ~email_verified ~current_time - ~json_dict ~form_csrf ~api_meth f store reqd + ~data:(`String msg) `Bad_request + else + Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true + ~with_error:true ~msg reqd () + | Error (`Token, msg) -> + Logs.err (fun m -> m "authenticate: %s" msg); + Middleware.http_response reqd ~title:"Error" + ~data:(`String msg) `Bad_request + | Ok `Token (user, token) -> ( + Store.increment_token_usage store token user >>= function + | Error (`Msg err) -> + Middleware.http_response reqd ~title:"Error" ~data:(`String err) + `Internal_server_error + | Ok () -> + extract_json_body reqd >>= function + | Ok json_dict -> f ~json_dict user | Error (`Msg msg) -> Middleware.http_response reqd ~title:"Error" ~data:(`String (String.escaped msg)) - `Bad_request - else - process_session_request ~check_admin ~email_verified ~current_time - ~api_meth f store reqd + `Bad_request) + | Ok `Cookie (user, cookie) -> + Store.update_cookie_usage store cookie user reqd >>= function + | Error (`Msg err) -> + Logs.err (fun m -> m "Error with storage: %s" err); + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped err)) + `Internal_server_error + | Ok () -> + if check_csrf then + extract_csrf_token reqd >>= function + | Ok (form_csrf, json_dict) -> + process_session_request ~email_verified + ~json_dict ~form_csrf f reqd user + | Error (`Msg msg) -> + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped msg)) + `Bad_request + else + process_session_request ~email_verified + f reqd user let reply reqd ?(content_type = "text/plain") ?(header_list = []) data status = From 6d26df9ac83c6750de41d2bbe3855f63d79ac4fc Mon Sep 17 00:00:00 2001 From: "Automated ocamlformat GitHub action, developed by robur.coop" Date: Wed, 11 Dec 2024 15:21:27 +0000 Subject: [PATCH 16/23] formatted code --- unikernel.ml | 131 +++++++++++++++++++++++++-------------------------- 1 file changed, 65 insertions(+), 66 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index d1ee9f12..7f727340 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -141,13 +141,13 @@ struct in go (Map.empty, []) m - let process_session_request ?(json_dict = []) ?form_csrf - ~email_verified f reqd user = + let process_session_request ?(json_dict = []) ?form_csrf ~email_verified f + reqd user = let current_time = Ptime.v (P.now_d_ps ()) in let middlewares ~form_csrf user = (if email_verified && false (* TODO *) then - [ Middleware.email_verified_middleware user ] - else []) + [ Middleware.email_verified_middleware user ] + else []) @ Option.fold ~none:[] ~some:(fun csrf -> [ Middleware.csrf_verification user current_time csrf ]) @@ -155,15 +155,17 @@ struct in Middleware.apply_middleware (middlewares ~form_csrf user) - (fun reqd -> f ~json_dict user) reqd + (fun reqd -> f ~json_dict user) + reqd let authenticate_user ~check_admin ~check_token store reqd = let ( let* ) = Result.bind in let current_time = Ptime.v (P.now_d_ps ()) in let user_is_active user = - if user.User_model.active then Ok () else Error "User account is deactivated" + if user.User_model.active then Ok () + else Error "User account is deactivated" in - let user_is_admin user = + let user_is_admin user = if (check_admin && user.User_model.super_user) || not check_admin then Ok () else @@ -173,8 +175,8 @@ struct match Middleware.session_cookie_value reqd with | Error (`Msg err) -> Error (`Cookie, "No molly-session in cookie header. %s" ^ err) - | Ok cookie_value -> - match Store.find_by_cookie store cookie_value with + | Ok cookie_value -> ( + match Store.find_by_cookie store cookie_value with | None -> Error (`Cookie, "Failed to find user with cookie " ^ cookie_value) | Some (user, cookie) -> @@ -186,80 +188,77 @@ struct | Error msg -> Error (`Cookie, msg) | Ok () -> Ok (`Cookie (user, cookie)) else - Error (`Cookie, "Session value doesn't match user session " ^ cookie_value) + Error + ( `Cookie, + "Session value doesn't match user session " ^ cookie_value + )) in let valid_token token_value = match Store.find_by_api_token store token_value with | Some (user, token) -> - if User_model.is_valid_token token current_time then - Ok (user, token) - else - Error (`Token, "Token value is not valid " ^ token_value) - | None -> - Error (`Token, "Failed to find user with token " ^ token_value) + if User_model.is_valid_token token current_time then Ok (user, token) + else Error (`Token, "Token value is not valid " ^ token_value) + | None -> Error (`Token, "Failed to find user with token " ^ token_value) in if check_token then match Middleware.api_authentication reqd with | Some token_value -> ( - let* (user, token) = valid_token token_value in - match - let* () = user_is_active user in - user_is_admin user - with - | Ok () -> Ok (`Token (user, token)) - | Error msg -> Error (`Token, msg)) + let* user, token = valid_token token_value in + match + let* () = user_is_active user in + user_is_admin user + with + | Ok () -> Ok (`Token (user, token)) + | Error msg -> Error (`Token, msg)) | None -> check_cookie reqd - else - check_cookie reqd - + else check_cookie reqd + let authenticate ?(email_verified = true) ?(check_admin = false) ?(api_meth = false) ?(check_csrf = false) ?(check_token = false) store reqd f = match authenticate_user ~check_admin ~check_token store reqd with | Error (`Cookie, msg) -> - Logs.err (fun m -> m "authenticate: %s" msg); - if api_meth then - Middleware.http_response reqd ~title:"Error" - ~data:(`String msg) `Bad_request - else - Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true - ~with_error:true ~msg reqd () + Logs.err (fun m -> m "authenticate: %s" msg); + if api_meth then + Middleware.http_response reqd ~title:"Error" ~data:(`String msg) + `Bad_request + else + Middleware.redirect_to_page ~path:"/sign-in" ~clear_session:true + ~with_error:true ~msg reqd () | Error (`Token, msg) -> - Logs.err (fun m -> m "authenticate: %s" msg); - Middleware.http_response reqd ~title:"Error" - ~data:(`String msg) `Bad_request - | Ok `Token (user, token) -> ( + Logs.err (fun m -> m "authenticate: %s" msg); + Middleware.http_response reqd ~title:"Error" ~data:(`String msg) + `Bad_request + | Ok (`Token (user, token)) -> ( Store.increment_token_usage store token user >>= function - | Error (`Msg err) -> - Middleware.http_response reqd ~title:"Error" ~data:(`String err) - `Internal_server_error - | Ok () -> - extract_json_body reqd >>= function - | Ok json_dict -> f ~json_dict user - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(`String (String.escaped msg)) - `Bad_request) - | Ok `Cookie (user, cookie) -> - Store.update_cookie_usage store cookie user reqd >>= function - | Error (`Msg err) -> - Logs.err (fun m -> m "Error with storage: %s" err); + | Error (`Msg err) -> + Middleware.http_response reqd ~title:"Error" ~data:(`String err) + `Internal_server_error + | Ok () -> ( + extract_json_body reqd >>= function + | Ok json_dict -> f ~json_dict user + | Error (`Msg msg) -> Middleware.http_response reqd ~title:"Error" - ~data:(`String (String.escaped err)) - `Internal_server_error - | Ok () -> - if check_csrf then - extract_csrf_token reqd >>= function - | Ok (form_csrf, json_dict) -> - process_session_request ~email_verified - ~json_dict ~form_csrf f reqd user - | Error (`Msg msg) -> - Middleware.http_response reqd ~title:"Error" - ~data:(`String (String.escaped msg)) - `Bad_request - else - process_session_request ~email_verified - f reqd user + ~data:(`String (String.escaped msg)) + `Bad_request)) + | Ok (`Cookie (user, cookie)) -> ( + Store.update_cookie_usage store cookie user reqd >>= function + | Error (`Msg err) -> + Logs.err (fun m -> m "Error with storage: %s" err); + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped err)) + `Internal_server_error + | Ok () -> + if check_csrf then + extract_csrf_token reqd >>= function + | Ok (form_csrf, json_dict) -> + process_session_request ~email_verified ~json_dict ~form_csrf + f reqd user + | Error (`Msg msg) -> + Middleware.http_response reqd ~title:"Error" + ~data:(`String (String.escaped msg)) + `Bad_request + else process_session_request ~email_verified f reqd user) let reply reqd ?(content_type = "text/plain") ?(header_list = []) data status = From 722d493b47030d60972e42c5ac1144ce2c4ba492 Mon Sep 17 00:00:00 2001 From: PixieDust <111846546+PizieDust@users.noreply.github.com> Date: Wed, 11 Dec 2024 17:30:17 +0100 Subject: [PATCH 17/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 7f727340..80cab866 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -1900,7 +1900,7 @@ struct (unikernel_console !albatross unikernel_name reqd)) | "/api/unikernel/create" -> check_meth `POST (fun () -> - authenticate ~check_token:true ~check_csrf:true store reqd + authenticate ~check_token:true ~check_csrf:true ~api_meth:true store reqd (unikernel_create !albatross reqd)) | _ -> let error = From 9b8d433db6fa380982a3839b8cfa08ebc6d77848 Mon Sep 17 00:00:00 2001 From: PixieDust <111846546+PizieDust@users.noreply.github.com> Date: Wed, 11 Dec 2024 17:30:26 +0100 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 80cab866..af39ab1e 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -1889,7 +1889,7 @@ struct (unikernel_destroy !albatross reqd)) | "/api/unikernel/restart" -> check_meth `POST (fun () -> - authenticate ~check_token:true ~check_csrf:true store reqd + authenticate ~check_token:true ~check_csrf:true ~api_meth:true store reqd (unikernel_restart !albatross reqd)) | path when String.starts_with ~prefix:"/unikernel/console/" path -> check_meth `GET (fun () -> From 39cae02e3f5f30e7c40049a6815c9909d80339eb Mon Sep 17 00:00:00 2001 From: PixieDust <111846546+PizieDust@users.noreply.github.com> Date: Wed, 11 Dec 2024 17:30:35 +0100 Subject: [PATCH 19/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 af39ab1e..dc047fe8 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -1804,7 +1804,7 @@ struct (delete_volume !albatross reqd)) | "/api/volume/create" -> check_meth `POST (fun () -> - authenticate ~check_token:true ~check_csrf:true store reqd + authenticate ~check_token:true ~check_csrf:true ~api_meth:true store reqd (create_volume !albatross reqd)) | "/api/volume/download" -> check_meth `POST (fun () -> From 2233a3afee0e4dd3e7544988531e9f7621e8b5c9 Mon Sep 17 00:00:00 2001 From: PixieDust <111846546+PizieDust@users.noreply.github.com> Date: Wed, 11 Dec 2024 17:30:46 +0100 Subject: [PATCH 20/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 dc047fe8..4e91682c 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -1885,7 +1885,7 @@ struct authenticate store reqd (deploy_form store reqd)) | "/api/unikernel/destroy" -> check_meth `POST (fun () -> - authenticate ~check_token:true store reqd + authenticate ~check_token:true ~api_meth:true store reqd (unikernel_destroy !albatross reqd)) | "/api/unikernel/restart" -> check_meth `POST (fun () -> From 8d76b8be75e11d57d92a54ade47d89809ff58d9d Mon Sep 17 00:00:00 2001 From: PixieDust <111846546+PizieDust@users.noreply.github.com> Date: Wed, 11 Dec 2024 17:30:54 +0100 Subject: [PATCH 21/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 4e91682c..7b385f4d 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -1813,7 +1813,7 @@ struct (download_volume !albatross reqd)) | "/api/volume/upload" -> check_meth `POST (fun () -> - authenticate ~check_token:true ~check_csrf:true store reqd + authenticate ~check_token:true ~check_csrf:true ~api_meth:true store reqd (upload_to_volume !albatross reqd)) | "/tokens" -> check_meth `GET (fun () -> From 0b5ad47d195bcd5215070bbf97a5b7ad8693c80a Mon Sep 17 00:00:00 2001 From: "Automated ocamlformat GitHub action, developed by robur.coop" Date: Wed, 11 Dec 2024 16:33:55 +0000 Subject: [PATCH 22/23] formatted code --- unikernel.ml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index 7b385f4d..a81a3a6d 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -1804,7 +1804,8 @@ struct (delete_volume !albatross reqd)) | "/api/volume/create" -> check_meth `POST (fun () -> - authenticate ~check_token:true ~check_csrf:true ~api_meth:true store reqd + authenticate ~check_token:true ~check_csrf:true ~api_meth:true + store reqd (create_volume !albatross reqd)) | "/api/volume/download" -> check_meth `POST (fun () -> @@ -1813,7 +1814,8 @@ struct (download_volume !albatross reqd)) | "/api/volume/upload" -> check_meth `POST (fun () -> - authenticate ~check_token:true ~check_csrf:true ~api_meth:true store reqd + authenticate ~check_token:true ~check_csrf:true ~api_meth:true + store reqd (upload_to_volume !albatross reqd)) | "/tokens" -> check_meth `GET (fun () -> @@ -1889,7 +1891,8 @@ struct (unikernel_destroy !albatross reqd)) | "/api/unikernel/restart" -> check_meth `POST (fun () -> - authenticate ~check_token:true ~check_csrf:true ~api_meth:true store reqd + authenticate ~check_token:true ~check_csrf:true ~api_meth:true + store reqd (unikernel_restart !albatross reqd)) | path when String.starts_with ~prefix:"/unikernel/console/" path -> check_meth `GET (fun () -> @@ -1900,7 +1903,8 @@ struct (unikernel_console !albatross unikernel_name reqd)) | "/api/unikernel/create" -> check_meth `POST (fun () -> - authenticate ~check_token:true ~check_csrf:true ~api_meth:true store reqd + authenticate ~check_token:true ~check_csrf:true ~api_meth:true + store reqd (unikernel_create !albatross reqd)) | _ -> let error = From 2d28fd3a091140f059bb4d9e63cffb859f24a410 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Wed, 11 Dec 2024 17:37:26 +0100 Subject: [PATCH 23/23] unused variable --- unikernel.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unikernel.ml b/unikernel.ml index a81a3a6d..2a455f88 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -155,7 +155,7 @@ struct in Middleware.apply_middleware (middlewares ~form_csrf user) - (fun reqd -> f ~json_dict user) + (fun _reqd -> f ~json_dict user) reqd let authenticate_user ~check_admin ~check_token store reqd =