swrup/geochan
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

set up user session on login

Browse source
This commit is contained in:
pena 2021-11-07 10:21:01 +01:00 • committed by Swrup
parent b2ecec7808
commit c7aa8aaad7
4 changed files with 27 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/login.eml.html
View file

@ -2,7 +2,7 @@ let f ?nick ?password request =
% begin match nick, password with % begin match nick, password with
% | Some nick, Some password -> % | Some nick, Some password ->
% begin match User.login ~nick ~password with % begin match User.login ~nick ~password request with
% | Error e -> % | Error e ->
Error: <%s e %> Error: <%s e %>
% | Ok () -> % | Ok () ->

25
src/permap.ml
View file

@ -6,7 +6,7 @@ let get_title content =
with with
| Failure _e -> "Permap" | Failure _e -> "Permap"
let render ?title content = let render ?title content request =
let title = let title =
match title with match title with
| None -> get_title content | None -> get_title content
@ -15,14 +15,15 @@ let render ?title content =
Dream.html Dream.html
@@ Template.render_unsafe ~title:(Dream.html_escape title) @@ Template.render_unsafe ~title:(Dream.html_escape title)
~content:(Dream.html_escape content) ~content:(Dream.html_escape content)
request
let render_unsafe ?title content = let render_unsafe ?title content request =
let title = let title =
match title with match title with
| None -> get_title content | None -> get_title content
| Some title -> title | Some title -> title
in in
Dream.html @@ Template.render_unsafe ~title ~content Dream.html @@ Template.render_unsafe ~title ~content request
let asset_loader _root path _request = let asset_loader _root path _request =
match Content.read ("assets/" ^ path) with match Content.read ("assets/" ^ path) with
@ -34,32 +35,32 @@ let page path =
| None -> None | None -> None
| Some page -> Some (Omd.of_string page |> Omd.to_html) | Some page -> Some (Omd.of_string page |> Omd.to_html)
let page_of_name name = let page_of_name name request =
match page name with match page name with
| None -> Dream.empty `Not_Found | None -> Dream.empty `Not_Found
| Some content -> render_unsafe content | Some content -> render_unsafe content request
let homepage _request = page_of_name "index" let homepage request = page_of_name "index" request
let register_get request = render_unsafe (Register.f request) let register_get request = render_unsafe (Register.f request) request
let register_post request = let register_post request =
match%lwt Dream.form request with match%lwt Dream.form request with
| `Ok [ ("email", email); ("nick", nick); ("password", password) ] -> | `Ok [ ("email", email); ("nick", nick); ("password", password) ] ->
render_unsafe (Register.f ~nick ~email ~password request) render_unsafe (Register.f ~nick ~email ~password request) request
| _ -> assert false | _ -> assert false
let login_get request = render_unsafe (Login.f request) let login_get request = render_unsafe (Login.f request) request
let login_post request = let login_post request =
match%lwt Dream.form request with match%lwt Dream.form request with
| `Ok [ ("nick", nick); ("password", password) ] -> | `Ok [ ("nick", nick); ("password", password) ] ->
render_unsafe (Login.f ~nick ~password request) render_unsafe (Login.f ~nick ~password request) request
| _ -> assert false | _ -> assert false
let user _request = render_unsafe (User.list ()) let user request = render_unsafe (User.list ()) request
let user_profile request = render_unsafe (User.profile request) let user_profile request = render_unsafe (User.profile request) request
let () = let () =
Dream.run ~interface:"0.0.0.0" Dream.run ~interface:"0.0.0.0"

9
src/template.eml.html
View file

@ -1,4 +1,4 @@
let render_unsafe ~title ~content = let render_unsafe ~title ~content request =
<!DOCTYPE html> <!DOCTYPE html>
<html lang="en"> <html lang="en">
<head> <head>
@ -20,12 +20,19 @@ let render_unsafe ~title ~content =
<li class="nav-item"> <li class="nav-item">
<a class="nav-link" href="/">Home</a> <a class="nav-link" href="/">Home</a>
</li> </li>
% begin match Dream.session "nick" request with
% | None ->
<li class="nav-item"> <li class="nav-item">
<a class="nav-link" href="/register">Register</a> <a class="nav-link" href="/register">Register</a>
</li> </li>
<li class="nav-item"> <li class="nav-item">
<a class="nav-link" href="/login">Login</a> <a class="nav-link" href="/login">Login</a>
</li> </li>
% | Some nick ->
<li class="nav-item">
<a class="nav-link" href="/profile"><%s! nick %></a>
</li>
% end;
<li class="nav-item"> <li class="nav-item">
<a class="nav-link" href="/user">Users</a> <a class="nav-link" href="/user">Users</a>
</li> </li>

6
src/user.ml
View file

@ -18,7 +18,7 @@ let () =
Dream.warning (fun log -> Dream.warning (fun log ->
log "can't create table user: %s" (Sqlite3.Rc.to_string e) ) log "can't create table user: %s" (Sqlite3.Rc.to_string e) )
let login ~nick ~password = let login ~nick ~password request =
let open Sqlite3_utils in let open Sqlite3_utils in
let good_password = let good_password =
Db.with_db (fun db -> Db.with_db (fun db ->
@ -28,6 +28,10 @@ let login ~nick ~password =
match good_password with match good_password with
| Ok [ [| Data.TEXT good_password |] ] -> | Ok [ [| Data.TEXT good_password |] ] ->
if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then
let _ =
let%lwt () = Dream.invalidate_session request in
Dream.put_session "nick" nick request
in
Ok () Ok ()
else else
Error "wrong password" Error "wrong password"