diff --git a/src/app.ml b/src/app.ml index 543afc7..2936611 100644 --- a/src/app.ml +++ b/src/app.ml @@ -19,12 +19,13 @@ let config_dir = | Some config_dir -> config_dir let config = - let filename = Filename.concat config_dir "config.scfg" in - if not @@ Sys.file_exists filename then [] + let filename = Fpath.add_seg config_dir "config.scfg" in + let filename_str = Fpath.to_string filename in + if not @@ Sys.file_exists filename_str then [] else begin - Dream.log "config file: %s" filename; + Dream.log "config file: %s" filename_str; match Scfg.Parse.from_file filename with - | Error e -> failwith e + | Error (`Msg e) -> failwith e | Ok config -> config end @@ -33,7 +34,7 @@ let open_registration = | None -> true | Some open_registration -> ( match Scfg.Query.get_param 0 open_registration with - | Error e -> failwith e + | Error (`Msg e) -> failwith e | Ok "true" -> true | Ok "false" -> false | Ok _unknown -> @@ -46,7 +47,7 @@ let port = | None -> 8080 | Some port -> ( match Scfg.Query.get_param 0 port with - | Error e -> failwith e + | Error (`Msg e) -> failwith e | Ok n -> ( try let n = int_of_string n in @@ -62,7 +63,10 @@ let hostname = match Scfg.Query.get_dir "hostname" config with | None -> default_hostname | Some hostname -> - Result.fold ~error:failwith ~ok:Fun.id (Scfg.Query.get_param 0 hostname) + Result.fold + ~error:(fun (`Msg e) -> failwith e) + ~ok:Fun.id + (Scfg.Query.get_param 0 hostname) let () = Dream.log "hostname: %s" hostname @@ -71,7 +75,7 @@ let log = | None -> true | Some log -> ( match Scfg.Query.get_param 0 log with - | Error e -> failwith e + | Error (`Msg e) -> failwith e | Ok "true" -> true | Ok "false" -> false | Ok _unknown -> failwith "invalid `log` value in configuration file" ) @@ -84,7 +88,7 @@ let about = | None -> default_about | Some about -> ( match Scfg.Query.get_param 0 about with - | Error e -> failwith e + | Error (`Msg e) -> failwith e | Ok about -> about ) let random_state = Random.State.make_self_init () diff --git a/src/db.ml b/src/db.ml index 6295420..ca88f29 100644 --- a/src/db.ml +++ b/src/db.ml @@ -3,15 +3,16 @@ open Caqti_request.Infix let db_root = App.data_dir let () = - match Bos.OS.Dir.create (Fpath.v db_root) with - | Ok true -> Dream.log "created %s" db_root - | Ok false -> Dream.log "%s already exists" db_root + match Bos.OS.Dir.create db_root with + | Ok true -> Dream.log "created %s" (Fpath.to_string db_root) + | Ok false -> Dream.log "%s already exists" (Fpath.to_string db_root) | Error (`Msg _) -> - Dream.warning (fun log -> log "error when creating %s" db_root) + Dream.warning (fun log -> + log "error when creating %s" (Fpath.to_string db_root) ) -let db = Filename.concat db_root (App.App_id.application ^ ".db") +let db = Fpath.add_seg db_root (App.App_id.application ^ ".db") -let db_uri = Format.sprintf "sqlite3://%s" db +let db_uri = Format.sprintf "sqlite3://%s" (Fpath.to_string db) module Db = (val Caqti_blocking.connect (Uri.of_string db_uri) |> Caqti_blocking.or_fail) diff --git a/src/dune b/src/dune index db008b0..b35e495 100644 --- a/src/dune +++ b/src/dune @@ -33,7 +33,8 @@ tyxml tyxml.functor uri - uuidm) + uuidm + unix) (preprocess (pps lwt_ppx))) diff --git a/src/island.ml b/src/island.ml index ad37b85..013bfac 100644 --- a/src/island.ml +++ b/src/island.ml @@ -61,8 +61,8 @@ let get request = let js = script ~a: - [ a_mime_type "text/javascript" - ; a_src "/assets/js/island_client.js" + [ (*a_mime_type "text/javascript" ; *) + a_src "/assets/js/island_client.js" ; a_defer () ] (txt "") diff --git a/src/user.ml b/src/user.ml index 8c3ed39..1ada3bd 100644 --- a/src/user.ml +++ b/src/user.ml @@ -32,37 +32,36 @@ module Q = struct let is_already_user = Db.find - @@ (tup2 string string ->! int) + @@ (t2 string string ->! int) "SELECT EXISTS(SELECT 1 FROM user WHERE nick=? OR email=?)" let upload_user = Db.exec - @@ (tup4 string string string string ->. unit) + @@ (t4 string string string string ->. unit) "INSERT INTO user VALUES (?, ?, ?, ?)" let list_nicks = Db.collect_list @@ (unit ->* string) "SELECT nick FROM user" let get_user = Db.find - @@ (string ->! tup4 string string string string) + @@ (string ->! t4 string string string string) "SELECT * FROM user WHERE user_id=?" let update_bio = Db.exec - @@ (tup2 string string ->. unit) "UPDATE user SET bio=? WHERE user_id=?" + @@ (t2 string string ->. unit) "UPDATE user SET bio=? WHERE user_id=?" let update_nick = Db.exec - @@ (tup2 string string ->. unit) "UPDATE user SET nick=? WHERE user_id=?" + @@ (t2 string string ->. unit) "UPDATE user SET nick=? WHERE user_id=?" let update_email = Db.exec - @@ (tup2 string string ->. unit) "UPDATE user SET email=? WHERE user_id=?" + @@ (t2 string string ->. unit) "UPDATE user SET email=? WHERE user_id=?" let update_password = Db.exec - @@ (tup2 string string ->. unit) - "UPDATE user SET password=? WHERE user_id=?" + @@ (t2 string string ->. unit) "UPDATE user SET password=? WHERE user_id=?" let get_email = Db.find @@ (string ->! string) "SELECT email FROM user WHERE user_id=?" @@ -71,11 +70,11 @@ module Q = struct Db.exec @@ (string ->. unit) "DELETE FROM user WHERE user_id=?" let upload_banished = - Db.exec @@ (tup2 string string ->. unit) "INSERT INTO banished VALUES (?,?)" + Db.exec @@ (t2 string string ->. unit) "INSERT INTO banished VALUES (?,?)" let get_banished = Db.find - @@ (tup2 string string ->! tup2 string string) + @@ (t2 string string ->! t2 string string) "SELECT * FROM banished WHERE nick=? OR email=?" end @@ -102,10 +101,12 @@ let login ~login ~password request = let try_password user_id = let* good_password = Q.get_password user_id in if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then + (* TODO lwt + await them *) let _unit_lwt = Dream.invalidate_session request in - let _unit_lwt = Dream.put_session "user_id" user_id request in + let _unit_lwt = Dream.set_session_field request "user_id" user_id in let* nick = get_nick user_id in - let _unit_lwt = Dream.put_session "nick" nick request in + let _unit_lwt = Dream.set_session_field request "nick" nick in Ok () else if is_banished login then Error (`Forbidden, "YOU ARE BANISHED") else Error (`Forbidden, "wrong password") @@ -157,12 +158,12 @@ let list () = | s -> Format.fprintf fmt {|