WIP Session login

lib/authorization.ml

@@ -13,36 +13,51 @@ let authenticate handler = fun req ->
     let headers = ["WWW-Authenticate", Printf.sprintf "Basic realm=\"%s\"" realm] in
     Dream.respond ~headers ~status:`Unauthorized "Forbidden!"
   in
-  match Dream.header "Authorization" req with
+  match Dream.session "username" req with
-  | None -> unauthorized ()
+  | Some username ->
-  | Some data -> match String.split_on_char ' ' data with
+    let* user_info = Dream.sql req (Model.user username) in
-     | [ "Basic" ; user_pass ] ->
+    begin match user_info with
-       (match Base64.decode user_pass with
+      | Ok (Some (user_id, user_info)) ->
-       | Error `Msg msg ->
+        handler (Dream.with_local user_info_local (user_id, user_info) req)
-         Log.info (fun m -> m "Invalid user / pasword encoding in %S: %S" data msg);
+      | Ok None ->
-         Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
+        Log.warn (fun m -> m "User %S from session doesn't exist" username);
-       | Ok user_pass -> match String.split_on_char ':' user_pass with
+        let* () = Dream.invalidate_session req in
-         | [] | [_] ->
+        Dream.respond ~status:`Internal_Server_Error "Internal server error"
-           Log.info (fun m -> m "Invalid user / pasword encoding in %S" data);
+      | Error e ->
+        Log.warn (fun m -> m "Error getting user: %a" Model.pp_error e);
+        Dream.respond ~status:`Internal_Server_Error "Internal server error"
+    end
+  | None ->
+    match Dream.header "Authorization" req with
+    | None -> unauthorized ()
+    | Some data -> match String.split_on_char ' ' data with
+      | [ "Basic" ; user_pass ] ->
+        (match Base64.decode user_pass with
+         | Error `Msg msg ->
+           Log.info (fun m -> m "Invalid user / pasword encoding in %S: %S" data msg);
            Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
-         | user :: password ->
+         | Ok user_pass -> match String.split_on_char ':' user_pass with
-           let pass = String.concat ":" password in
+           | [] | [_] ->
-           let* user_info = Dream.sql req (Model.user user) in
+             Log.info (fun m -> m "Invalid user / pasword encoding in %S" data);
-           match user_info with
+             Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
-           | Ok (Some (id, user_info)) ->
+           | user :: password ->
-             if Builder_web_auth.verify_password pass user_info
+             let pass = String.concat ":" password in
-             then handler (Dream.with_local user_info_local (id, user_info) req)
+             let* user_info = Dream.sql req (Model.user user) in
-             else unauthorized ()
+             match user_info with
-           | Ok None ->
+             | Ok (Some (id, user_info)) ->
-             let _ : _ Builder_web_auth.user_info =
+               if Builder_web_auth.verify_password pass user_info
-               Builder_web_auth.hash ~username:user ~password:pass ~restricted:true () in
+               then handler (Dream.with_local user_info_local (id, user_info) req)
-             unauthorized ()
+               else unauthorized ()
-           | Error e ->
+             | Ok None ->
-             Log.warn (fun m -> m "Error getting user: %a" Model.pp_error e);
+               let _ : _ Builder_web_auth.user_info =
-             Dream.respond ~status:`Internal_Server_Error "Internal server error")
+                 Builder_web_auth.hash ~username:user ~password:pass ~restricted:true () in
-     | _ ->
+               unauthorized ()
-       Log.warn (fun m -> m "Error retrieving authorization %S" data);
+             | Error e ->
-       Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
+               Log.warn (fun m -> m "Error getting user: %a" Model.pp_error e);
+               Dream.respond ~status:`Internal_Server_Error "Internal server error")
+      | _ ->
+        Log.warn (fun m -> m "Error retrieving authorization %S" data);
+        Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
 
 let authorized req job_name =
   match Dream.local user_info_local req with

lib/builder_web.ml

@@ -103,7 +103,9 @@ let add_routes datadir =
     |> if_error "Error getting jobs"
       ~log:(fun e -> Log.warn (fun m -> m "Error getting jobs: %a" pp_error e))
     >>= fun jobs ->
-    Views.builder jobs |> string_of_html |> Dream.html |> Lwt_result.ok
+    let username = Dream.session "username" req in
+    Views.builder username (Dream.csrf_token req) jobs
+    |> string_of_html |> Dream.html |> Lwt_result.ok
   in
 
   let job req =
@@ -273,16 +275,61 @@ let add_routes datadir =
       >>= fun () -> Dream.respond "" |> Lwt_result.ok
   in
 
+  let login req =
+    let username = Dream.session "username" req in
+    Views.login username (Dream.csrf_token req) |> string_of_html |> Dream.html
+  in
+
+  let do_login req =
+    let* form = Dream.form req in
+    (match form with
+     | `Ok [ "password", password; "user", username ] ->
+       Lwt.return (Ok (username, password))
+     | _ ->
+       Lwt.return (Error ("Bad request", `Bad_Request))) >>= fun (username, password) ->
+    Dream.sql req (Model.user username)
+    |> if_error "Internal server error" >>= fun user_info ->
+    match user_info with
+    | Some (_user_id, user_info) ->
+      if Builder_web_auth.verify_password password user_info
+      then
+        let* () = Dream.invalidate_session req in
+        let* () = Dream.put_session "username" user_info.Builder_web_auth.username req in
+        Dream.redirect req "/" |> Lwt_result.ok
+      else
+        Dream.redirect req "/login" |> Lwt_result.ok
+    | None ->
+      let _ = Builder_web_auth.hash ~username ~password ~restricted:true () in
+      Dream.redirect req "/login" |> Lwt_result.ok
+  in
+
+  let do_logout req =
+    let* form = Dream.form req in
+    match form with
+    | `Ok [] ->
+      let* () = Dream.invalidate_session req in
+      Dream.redirect req "/"
+    | _ ->
+      Log.warn (fun m -> m "Bad logout");
+      Dream.redirect req "/"
+  in
+
   let w f req = or_error_response (f req) in
 
-  Dream.router [
+  Dream.pipeline [
-    Dream.get "/" (w builder);
+    Dream.sql_sessions;
-    Dream.get "/job/:job/" (w job);
+    Dream.router [
-    Dream.get "/job/:job/build/latest/**" (w redirect_latest);
+      Dream.get "/" (w builder);
-    Dream.get "/job/:job/build/:build/" (w job_build);
+      Dream.get "/job/:job/" (w job);
-    Dream.get "/job/:job/build/:build/f/**" (w job_build_file);
+      Dream.get "/job/:job/build/latest/**" (w redirect_latest);
-    Dream.get "/hash" (w hash);
+      Dream.get "/job/:job/build/:build/" (w job_build);
-    Dream.get "/compare/:build_left/:build_right/opam-switch" (w compare_opam);
+      Dream.get "/job/:job/build/:build/f/**" (w job_build_file);
-    Dream.post "/upload" (Authorization.authenticate (w upload));
+      Dream.get "/hash" (w hash);
-    Dream.post "/job/:job/upload" (Authorization.authenticate (w upload_binary));
+      Dream.get "/compare/:build_left/:build_right/opam-switch" (w compare_opam);
+      Dream.post "/upload" (Authorization.authenticate (w upload));
+      Dream.post "/job/:job/upload" (Authorization.authenticate (w upload_binary));
+      Dream.get "/login" login;
+      Dream.post "/login" (w do_login);
+      Dream.post "/logout" do_logout;
+    ];
   ]

lib/views.ml

@@ -5,6 +5,11 @@ let pp_ptime = Ptime.pp_human ()
 let txtf fmt = Fmt.kstrf txt fmt
 let a_titlef fmt = Fmt.kstrf a_title fmt
 
+let form ~csrf_token ?a children =
+  form ?a
+    (input ~a:[a_name "dream.csrf"; a_input_type `Hidden; a_value csrf_token] () ::
+     children)
+
 let check_icon result =
   match result with
   | Builder.Exited 0 ->
@@ -95,10 +100,21 @@ let artifact ?(basename=false) job_name build { Builder_db.filepath; localpath =
 
 
 
-let builder jobs =
+let builder username csrf_token jobs =
   layout ~title:"Builder Web"
     [ h1 [txt "Builder web"];
-      form ~a:[a_action "/hash"; a_method `Get]
+      begin match username with
+        | Some username ->
+          form ~csrf_token ~a:[a_method `Post; a_action "/logout"]
+            [
+              p [
+                txtf "Logged in as %s." username;
+              ];
+              input ~a:[a_input_type `Submit; a_value "Log out!"] ();
+            ];
+        | None -> txt ""
+      end;
+      form ~csrf_token ~a:[a_action "/hash"; a_method `Get]
         [
           label [
             txt "Search artifact by SHA256";
@@ -305,3 +321,16 @@ let compare_opam job_left job_right
         [txt "Unchanged packages"];
       code (packages same);
     ]
+
+let login _username csrf_token =
+  layout ~title:"Login" [
+    h1 [txt "Please login"];
+    form ~csrf_token ~a:[a_method `Post; a_action "/login"]
+      [
+        label ~a:[a_label_for "user"] [txt "User name"];
+        input ~a:[a_name "user"] ();
+        label ~a:[a_label_for "password"] [txt "Password"];
+        input ~a:[a_input_type `Password; a_name "password"] ();
+        input ~a:[a_input_type `Submit; a_value "Log in!"] ();
+      ]
+  ]