diff --git a/src/babillard.ml b/src/babillard.ml index 2da4019..32efce5 100644 --- a/src/babillard.ml +++ b/src/babillard.ml @@ -1,4 +1,5 @@ open Db +include Bindings exception Invalid_post of string @@ -37,22 +38,6 @@ type post = | Op of thread_data * reply | Reply of reply -let ( let** ) o f = - match o with - | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - | Ok None -> Error "db error" - | Ok (Some x) -> f x - -let ( let* ) o f = - match o with - | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - | Ok x -> f x - -let ( let+ ) o f = - match o with - | Error e -> Error (Format.sprintf "%s" e) - | Ok x -> f x - module Q = struct let create_post_user_table = Caqti_request.exec Caqti_type.unit @@ -374,18 +359,18 @@ let upload_post post = (id, parent_id, date, nick, comment, image, tags, citations) in - let* _res_post_id = Db.exec Q.upload_post_id (post_id, nick) in - let* _res_comment = Db.exec Q.upload_post_comment (post_id, comment) in - let* _res_date = Db.exec Q.upload_post_date (post_id, date) in - let* _res_thread = Db.exec Q.upload_to_thread (parent_id, post_id) in - let* _res_image = + let^ _res_post_id = Db.exec Q.upload_post_id (post_id, nick) in + let^ _res_comment = Db.exec Q.upload_post_comment (post_id, comment) in + let^ _res_date = Db.exec Q.upload_post_date (post_id, date) in + let^ _res_thread = Db.exec Q.upload_to_thread (parent_id, post_id) in + let^ _res_image = match image with | None -> Ok () | Some (image_name, image_content, alt) -> Db.exec Q.upload_post_image (post_id, image_name, image_content, alt) in - let* _res_parent = Db.exec Q.upload_post_parent (post_id, parent_id) in - let* _res_tags = + let^ _res_parent = Db.exec Q.upload_post_parent (post_id, parent_id) in + let^ _res_tags = match List.find_opt Result.is_error (List.map (fun tag -> Db.exec Q.upload_post_tag (post_id, tag)) tags) @@ -394,7 +379,7 @@ let upload_post post = | Some _ -> assert false | None -> Ok () in - let* _res_citations = + let^ _res_citations = match List.find_opt Result.is_error (List.map @@ -410,11 +395,11 @@ let upload_post post = | Some thread_data -> ( match thread_data with | { board; subject; lng; lat } -> - let* _res_board = + let^ _res_board = Db.exec Q.upload_thread_board (post_id, int_of_board board) in - let* _res_gps = Db.exec Q.upload_post_gps (post_id, lat, lng) in - let* _res_subject = Db.exec Q.upload_post_subject (post_id, subject) in + let^ _res_gps = Db.exec Q.upload_post_gps (post_id, lat, lng) in + let^ _res_subject = Db.exec Q.upload_post_subject (post_id, subject) in Ok post_id ) let build_reply ~comment ?image ~tags ?parent_id nick = @@ -466,7 +451,7 @@ let build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick = Error "Invalid subject" else let thread_data = { board; subject; lng; lat } in - let+ reply = + let* reply = match image with | Some image -> build_reply ~comment ~image ~tags nick | None -> build_reply ~comment ~tags nick @@ -475,14 +460,14 @@ let build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick = Ok op let make_reply ~comment ?image ~tags ~parent_id nick = - let+ reply = build_reply ~comment ?image ~tags ~parent_id nick in + let* reply = build_reply ~comment ?image ~tags ~parent_id nick in let post = Reply reply in upload_post post let make_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick = - let+ op = build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick in + let* op = build_op ~comment ?image ~tags ~subject ~lat ~lng ~board nick in upload_post op let get_post_image_content post_id = - let** content = Db.find_opt Q.get_post_image_content post_id in + let^? content = Db.find_opt Q.get_post_image_content post_id in Ok content diff --git a/src/bindings.ml b/src/bindings.ml new file mode 100644 index 0000000..e0b7585 --- /dev/null +++ b/src/bindings.ml @@ -0,0 +1,17 @@ +(* let bindings for early return when encountering an error *) +(* see https://ocaml.org/releases/4.13/htmlman/bindingops.html *) +let ( let^? ) o f = + match o with + | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) + | Ok None -> Error "db error" + | Ok (Some x) -> f x + +let ( let^ ) o f = + match o with + | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) + | Ok x -> f x + +let ( let* ) o f = + match o with + | Error e -> Error (Format.sprintf "%s" e) + | Ok x -> f x diff --git a/src/dune b/src/dune index 1b2fd2a..4efcc9c 100644 --- a/src/dune +++ b/src/dune @@ -1,6 +1,7 @@ (executable (public_name permap) (modules + bindings newthread_page thread_page babillard diff --git a/src/pp_babillard.ml b/src/pp_babillard.ml index 273d411..7c8760f 100644 --- a/src/pp_babillard.ml +++ b/src/pp_babillard.ml @@ -1,14 +1,15 @@ +include Bindings include Babillard open Db let view_post ?is_thread_preview post_id = - let* nick = Db.find Q.get_post_nick post_id in - let* comment = Db.find Q.get_post_comment post_id in - let* date = Db.find Q.get_post_date post_id in - let* image_info = Db.find_opt Q.get_post_image_info post_id in + let^ nick = Db.find Q.get_post_nick post_id in + let^ comment = Db.find Q.get_post_comment post_id in + let^ date = Db.find Q.get_post_date post_id in + let^ image_info = Db.find_opt Q.get_post_image_info post_id in - let* tags = Db.fold Q.get_post_tags (fun tag acc -> tag :: acc) post_id [] in - let* replies = + let^ tags = Db.fold Q.get_post_tags (fun tag acc -> tag :: acc) post_id [] in + let^ replies = Db.fold Q.get_post_replies (fun reply_id acc -> reply_id :: acc) post_id [] in @@ -108,8 +109,8 @@ let view_post ?is_thread_preview post_id = Ok post_view let preview_thread thread_id = - let+ post = view_post ~is_thread_preview:() thread_id in - let** subject = Db.find_opt Q.get_post_subject thread_id in + let* post = view_post ~is_thread_preview:() thread_id in + let^? subject = Db.find_opt Q.get_post_subject thread_id in let thread_preview = Format.sprintf {| @@ -125,9 +126,9 @@ let preview_thread thread_id = Ok thread_preview let view_thread thread_id = - let** _ = Db.find_opt Q.is_thread thread_id in - let** subject = Db.find_opt Q.get_post_subject thread_id in - let* thread_posts = Db.fold Q.get_thread_posts List.cons thread_id [] in + let^? _ = Db.find_opt Q.is_thread thread_id in + let^? subject = Db.find_opt Q.get_post_subject thread_id in + let^ thread_posts = Db.fold Q.get_thread_posts List.cons thread_id [] in (*order by date *) let dates = List.map (fun post_id -> Db.find Q.get_post_date post_id) thread_posts @@ -175,13 +176,13 @@ let view_thread thread_id = Ok thread_view ) let get_markers board = - let* thread_id_list = + let^ thread_id_list = Db.fold Q.list_threads List.cons (int_of_board board) [] in let markers_res = List.map (fun thread_id -> - let** lat, lng = Db.find_opt Q.get_post_gps thread_id in + let^? lat, lng = Db.find_opt Q.get_post_gps thread_id in match preview_thread thread_id with | Ok content -> Ok (lat, lng, content, thread_id) | Error e -> Error e ) diff --git a/src/user.ml b/src/user.ml index a6f453c..06f6330 100644 --- a/src/user.ml +++ b/src/user.ml @@ -1,3 +1,4 @@ +include Bindings open Db type t = @@ -8,19 +9,6 @@ type t = ; avatar : string } -(* ('a option, string) result *) -let ( let** ) o f = - match o with - | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - | Ok None -> Error "db error" - | Ok (Some x) -> f x - -(* ('a, string) result *) -let ( let* ) o f = - match o with - | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - | Ok x -> f x - module Q = struct let create_user_table = Caqti_request.exec Caqti_type.unit @@ -84,7 +72,7 @@ let () = Dream.warning (fun log -> log "can't create table") let login ~nick ~password request = - let** good_password = Db.find_opt Q.get_password nick in + let^? good_password = Db.find_opt Q.get_password nick in if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then let _ = let%lwt () = Dream.invalidate_session request in @@ -120,15 +108,15 @@ let register ~email ~nick ~password = if not valid then Error "Something is wrong" else - let** nb = Db.find_opt Q.is_already_user (nick, email) in + let^? nb = Db.find_opt Q.is_already_user (nick, email) in match nb with | 0 -> - let* () = Db.exec Q.inser_new_user (nick, password, email, ("", "")) in + let^ () = Db.exec Q.inser_new_user (nick, password, email, ("", "")) in Ok () | _ -> Error "nick or email already exists" let list () = - let* users = Db.fold Q.list_nicks (fun nick acc -> nick :: acc) () [] in + let^ users = Db.fold Q.list_nicks (fun nick acc -> nick :: acc) () [] in Ok (Format.asprintf "