From a00a48822c7c980e35677d34bb37205a295017a0 Mon Sep 17 00:00:00 2001 From: Ushitora Anqou Date: Sat, 9 Mar 2024 23:46:17 +0900 Subject: [PATCH] wip: temporary support for OCaml 5.0 --- Dockerfile | 15 +-- e2e/src/common.ml | 2 + e2e/src/dune | 8 +- e2e/src/main.ml | 10 +- e2e/src/waq_2_ws.ml | 37 ------- e2e/src/waq_4_reblog.ml | 61 ----------- e2e/src/waq_6_rel.ml | 158 ----------------------------- e2e/src/waq_8_delete.ml | 49 --------- lib/controller/api_v1/streaming.ml | 7 +- lib/dune | 9 +- lib/streaming.ml | 10 ++ lib_blurhash/test/dune | 2 +- lib_httpq/bare_server.ml | 4 +- lib_httpq/dune | 4 +- lib_httpq/server.ml | 2 + test_e2e/{dune => _dune} | 6 +- waq.opam | 12 ++- 17 files changed, 59 insertions(+), 337 deletions(-) delete mode 100644 e2e/src/waq_2_ws.ml delete mode 100644 e2e/src/waq_4_reblog.ml delete mode 100644 e2e/src/waq_6_rel.ml delete mode 100644 e2e/src/waq_8_delete.ml rename test_e2e/{dune => _dune} (72%) diff --git a/Dockerfile b/Dockerfile index 51149e3..6c2a5b9 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,5 +1,4 @@ -FROM ocaml/opam:debian-11-ocaml-4.14 -# NOTE: ocaml/opam:ubuntu-22.04-ocaml-4.14 can't fetch Dune 3.7. I don't know why. +FROM ocaml/opam:debian-11-ocaml-5.0 ENV DEBIAN_FRONTEND=noninteractive @@ -11,11 +10,11 @@ RUN apt-get update && apt-get install -y \ USER opam WORKDIR /home/opam/waq -RUN opam update && opam install alcotest-lwt +RUN opam-2.1 update && opam-2.1 install alcotest-lwt COPY --chown=opam waq.opam . -RUN opam install . --deps-only +RUN opam-2.1 install . --deps-only COPY --chown=opam . . -RUN eval $(opam env) && opam install . --deps-only && dune build +RUN eval $(opam-2.1 env) && opam-2.1 install . --deps-only && dune build bin/main.exe FROM debian:11-slim @@ -31,9 +30,3 @@ USER waq:waq WORKDIR /waq/ COPY --from=0 /home/opam/waq/_build/default/bin/main.exe ./waq COPY --from=0 /home/opam/waq/static /static - -RUN if [ -n "$INSTALL_TMOLE" ]; then curl -s https://tunnelmole.com/sh/install-linux.sh | bash; fi - -CMD ["bash", "-c", "/waq/waq db:migrate && /waq/waq"] - -# docker build . -t waq && docker run -it -v $PWD/config:/waq/config waq [/bin/bash] diff --git a/e2e/src/common.ml b/e2e/src/common.ml index 8d33f53..00dfc2b 100644 --- a/e2e/src/common.ml +++ b/e2e/src/common.ml @@ -536,6 +536,7 @@ let fetch_access_token ~username = | `Assoc l -> l |> List.assoc "access_token" |> expect_string |> Lwt.return | _ -> assert false +(* let websocket ?mtx ~token kind ?target handler f = let open Websocket_lwt_unix in let target = @@ -607,6 +608,7 @@ let websocket_stack kind ~token ?num_msgs f = f pushf;%lwt match num_msgs with None -> pushf None | Some _ -> Lwt.return_unit) >|= fun () -> !recv_msgs + *) let expect_exc_lwt f = (try%lwt diff --git a/e2e/src/dune b/e2e/src/dune index 613a94b..cbf1da9 100644 --- a/e2e/src/dune +++ b/e2e/src/dune @@ -4,13 +4,13 @@ (pps lwt_ppx ppx_deriving.make ppx_yojson_conv)) (libraries cohttp - cohttp-lwt-unix + cohttp-eio httpq logq lwt lwt.unix waq - websocket - websocket-lwt-unix - websocket-lwt-unix.cohttp + ; websocket + ; websocket-lwt-unix + ; websocket-lwt-unix.cohttp yojson)) diff --git a/e2e/src/main.ml b/e2e/src/main.ml index 57b8723..0e1a442 100644 --- a/e2e/src/main.ml +++ b/e2e/src/main.ml @@ -20,17 +20,19 @@ let all_tests = ("waq-mstdn-13", Waq_mstdn_13_v2_search.f); *) ("waq-1", Waq_1.f); - ("waq-2", Waq_2_ws.f); ("waq-3", Waq_3.f); - ("waq-4", Waq_4_reblog.f); ("waq-5", Waq_5_fav.f); - ("waq-6", Waq_6_rel.f); ("waq-7", Waq_7_reblog.f); - ("waq-8", Waq_8_delete.f); (*("waq-9", Waq_9_ap.f);*) ("waq-10", Waq_10_mention.f); ("waq-11", Waq_11_marker.f); (* + ("waq-2", Waq_2_ws.f); + ("waq-4", Waq_4_reblog.f); + ("waq-8", Waq_8_delete.f); + ("waq-6", Waq_6_rel.f); + *) + (* (* ********** *) ("01-mention-waq-mstdn-waq", Waq_mstdn_11_mention.f_waq_mstdn_waq); ("01-mention-mstdn-waq-waq", Waq_mstdn_11_mention.f_mstdn_waq_waq); diff --git a/e2e/src/waq_2_ws.ml b/e2e/src/waq_2_ws.ml deleted file mode 100644 index 6625441..0000000 --- a/e2e/src/waq_2_ws.ml +++ /dev/null @@ -1,37 +0,0 @@ -open Common - -let f = - make_waq_scenario @@ fun waq_token -> - let got_uri = ref None in - let set_current_state, handler = - websocket_handler_state_machine ~init:`Init - ~states: - [ - (`Init, fun _ -> assert false); - ( `Recv, - fun l pushf -> - assert (List.assoc "stream" l = `List [ `String "user" ]); - assert (List.assoc "event" l |> expect_string = "update"); - let payload = List.assoc "payload" l |> expect_string in - let uri = - let l = Yojson.Safe.from_string payload |> expect_assoc in - List.assoc "uri" l |> expect_string - in - got_uri := Some uri; - pushf None;%lwt - Lwt.return `End ); - (`End, fun _ -> assert false); - ] - () - in - - let expected_uri = ref None in - let mtx = Lwt_mutex.create () in - websocket ~mtx `Waq ~token:waq_token handler (fun _pushf -> - let%lwt { uri; _ } = post `Waq ~token:waq_token () in - expected_uri := Some uri; - set_current_state `Recv; - Lwt.return_unit);%lwt - - assert (Option.get !got_uri = Option.get !expected_uri); - Lwt.return_unit diff --git a/e2e/src/waq_4_reblog.ml b/e2e/src/waq_4_reblog.ml deleted file mode 100644 index 8f44127..0000000 --- a/e2e/src/waq_4_reblog.ml +++ /dev/null @@ -1,61 +0,0 @@ -open Common - -let f = - make_waq_scenario @@ fun token -> - let expected_ids = ref [] in - let%lwt ws_recv_msgs = - websocket_stack `Waq ~token @@ fun _pushf -> - let%lwt { id = id1; reblog = None; reblogged = false; reblogs_count = 0; _ } - = - post `Waq ~token ~content:"Hello world" () - in - let%lwt { - id = id2; - reblogged = true; - reblog = Some { id = id1'; reblogged = true; reblog = None; _ }; - _; - } = - reblog `Waq ~token ~id:id1 - in - let%lwt { id = id2'; reblog = Some { id = id1''; _ }; _ } = - reblog `Waq ~token ~id:id1 - in - let%lwt { id = id2''; reblog = Some { id = id1'''; _ }; _ } = - reblog `Waq ~token ~id:id2 - in - assert (id1 = id1' && id1 = id1'' && id1 = id1'''); - assert (id2 = id2' && id2 = id2''); - expected_ids := [ id1; id2 ]; - - let%lwt { reblogs_count; _ } = get_status `Waq ~token id1 in - assert (reblogs_count = 1); - - Lwt.return_unit - in - - let ws_recv_msgs = - ws_recv_msgs |> List.map (Yojson.Safe.from_string |.> expect_assoc) - in - let ws_recv_ids, ws_recv_notfs = - ws_recv_msgs - |> List.fold_left - (fun (ws_recv_ids, ws_recv_notfs) l -> - let payload = - List.assoc "payload" l |> expect_string |> Yojson.Safe.from_string - in - match (List.assoc "stream" l, List.assoc "event" l) with - | `List [ `String "user" ], `String "update" -> - let s = payload |> status_of_yojson in - (s.id :: ws_recv_ids, ws_recv_notfs) - | `List [ `String "user" ], `String "notification" -> - let n = payload |> notification_of_yojson in - (ws_recv_ids, n :: ws_recv_notfs) - | _ -> (ws_recv_ids, ws_recv_notfs)) - ([], []) - in - - assert (List.sort compare !expected_ids = List.sort compare ws_recv_ids); - assert (ws_recv_notfs = []); - - Lwt.return_unit - [@@warning "-8"] diff --git a/e2e/src/waq_6_rel.ml b/e2e/src/waq_6_rel.ml deleted file mode 100644 index 03ef7f5..0000000 --- a/e2e/src/waq_6_rel.ml +++ /dev/null @@ -1,158 +0,0 @@ -open Common - -let expect_followers account_id expected_follower_ids = - let%lwt l = get_followers `Waq account_id in - let got = l |> List.map (fun (a : account) -> a.id) in - assert (got = expected_follower_ids); - Lwt.return_unit - -let expect_following account_id expected_follower_ids = - let%lwt l = get_following `Waq account_id in - let got = l |> List.map (fun (a : account) -> a.id) in - assert (got = expected_follower_ids); - Lwt.return_unit - -let f = - make_waq_scenario @@ fun token -> - (* Connect WebSocket *) - let%lwt ws_recv_msgs = - websocket_stack `Waq ~token @@ fun _pushf -> - let%lwt token' = fetch_access_token ~username:"user2" in - let%lwt user1_id, _, _ = lookup `Waq ~token:token' ~username:"user1" () in - let%lwt user2_id, _, _ = lookup `Waq ~token ~username:"user2" () in - let%lwt user3_id, _, _ = lookup `Waq ~token ~username:"user3" () in - - (* user1: Try to follow myself, which should be forbidden *) - (try%lwt - follow `Waq ~token user1_id;%lwt - assert false - with Httpq.Client.FetchFailure (Some (`Forbidden, _, _)) -> - Lwt.return_unit);%lwt - - (* user1: Follow @user2 *) - follow `Waq ~token user2_id;%lwt - expect_followers user2_id [ user1_id ];%lwt - expect_following user1_id [ user2_id ];%lwt - - (* user1: check relationship *) - (match%lwt get_relationships `Waq ~token [ user2_id; user3_id ] with - | [ rel2; rel3 ] -> - assert (rel2.id = user2_id); - assert (rel3.id = user3_id); - assert rel2.following; - assert (not rel2.followed_by); - Lwt.return_unit - | _ -> assert false);%lwt - - (* check accounts *) - let%lwt a = get_account `Waq user1_id in - assert (a.followers_count = 0); - assert (a.following_count = 1); - let%lwt a = get_account `Waq user2_id in - assert (a.followers_count = 1); - assert (a.following_count = 0); - - (* check notifications *) - (match%lwt get_notifications `Waq ~token:token' with - | [ { typ = "follow"; account = a; _ } ] -> - assert (a.id = user1_id); - Lwt.return_unit - | _ -> assert false);%lwt - - (* user2: follow @user1 *) - follow `Waq ~token:token' user1_id;%lwt - expect_followers user1_id [ user2_id ];%lwt - expect_following user2_id [ user1_id ];%lwt - - (* user1: check relationship *) - (match%lwt get_relationships `Waq ~token [ user2_id ] with - | [ rel ] -> - assert (rel.id = user2_id); - assert rel.following; - assert rel.followed_by; - Lwt.return_unit - | _ -> assert false);%lwt - - (* check accounts *) - let%lwt a = get_account `Waq user1_id in - assert (a.followers_count = 1); - assert (a.following_count = 1); - let%lwt a = get_account `Waq user2_id in - assert (a.followers_count = 1); - assert (a.following_count = 1); - - (* check notifications *) - (match%lwt get_notifications `Waq ~token with - | [ { typ = "follow"; account = a; _ } ] -> - assert (a.id = user2_id); - Lwt.return_unit - | _ -> assert false);%lwt - - (* user1: Unfollow @user2 *) - unfollow `Waq ~token user2_id;%lwt - expect_followers user2_id [];%lwt - expect_following user1_id [];%lwt - - (* user1: check relationship *) - (match%lwt get_relationships `Waq ~token [ user2_id ] with - | [ rel ] -> - assert (rel.id = user2_id); - assert (not rel.following); - assert rel.followed_by; - Lwt.return_unit - | _ -> assert false);%lwt - - (* check accounts *) - let%lwt a = get_account `Waq user1_id in - assert (a.followers_count = 1); - assert (a.following_count = 0); - let%lwt a = get_account `Waq user2_id in - assert (a.followers_count = 0); - assert (a.following_count = 1); - - (* user2: Unfollow @user1 *) - unfollow `Waq ~token:token' user1_id;%lwt - expect_followers user1_id [];%lwt - expect_following user2_id [];%lwt - - (* user1: check relationship *) - (match%lwt get_relationships `Waq ~token [ user2_id ] with - | [ rel ] -> - assert (rel.id = user2_id); - assert (not rel.following); - assert (not rel.followed_by); - Lwt.return_unit - | _ -> assert false);%lwt - - (* check accounts *) - let%lwt a = get_account `Waq user1_id in - assert (a.followers_count = 0); - assert (a.following_count = 0); - let%lwt a = get_account `Waq user2_id in - assert (a.followers_count = 0); - assert (a.following_count = 0); - - Lwt.return_unit - in - - let ws_notifications = - ws_recv_msgs - |> List.map (Yojson.Safe.from_string |.> expect_assoc) - |> List.filter_map (fun (l : (string * Yojson.Safe.t) list) -> - if - List.assoc "stream" l = `List [ `String "user" ] - && List.assoc "event" l = `String "notification" - then - Some - (List.assoc "payload" l |> expect_string - |> Yojson.Safe.from_string |> notification_of_yojson) - else None) - in - let%lwt got_notifications = get_notifications `Waq ~token in - assert ( - got_notifications - |> List.map (fun r -> r.id) - |> List.sort compare - = (ws_notifications |> List.map (fun r -> r.id) |> List.sort compare)); - - Lwt.return_unit diff --git a/e2e/src/waq_8_delete.ml b/e2e/src/waq_8_delete.ml deleted file mode 100644 index 1134114..0000000 --- a/e2e/src/waq_8_delete.ml +++ /dev/null @@ -1,49 +0,0 @@ -open Common - -let expect_no_status kind id = - try%lwt - get_status kind id |> ignore_lwt;%lwt - assert false - with Httpq.Client.FetchFailure (Some (`Not_found, _, _)) -> Lwt.return_unit - -let f = - make_waq_scenario @@ fun token -> - let%lwt token' = fetch_access_token ~username:"user2" in - let%lwt ws_recv_msgs = - websocket_stack `Waq ~token @@ fun _pushf -> - let%lwt { id; _ } = post `Waq ~token () in - let%lwt s = get_status `Waq id in - assert (s.id = id); - - (* Wrong delete *) - expect_exc_lwt (fun () -> delete_status `Waq ~token:token' id);%lwt - (* Should remain *) - get_status `Waq id |> ignore_lwt;%lwt - - (* Actual delete *) - let%lwt s = delete_status `Waq ~token id in - assert (s.id = id); - expect_no_status `Waq id;%lwt - - let%lwt { id; _ } = post `Waq ~token () in - let%lwt s = reblog `Waq ~token ~id in - delete_status `Waq ~token id |> ignore_lwt;%lwt - expect_no_status `Waq id;%lwt - expect_no_status `Waq s.id;%lwt - - Lwt.return_unit - in - let ws_delete_events = - ws_recv_msgs - |> List.map (Yojson.Safe.from_string |.> expect_assoc) - |> List.filter_map (fun (l : (string * Yojson.Safe.t) list) -> - if - List.assoc "stream" l = `List [ `String "user" ] - && List.assoc "event" l = `String "delete" - then Some (List.assoc "payload" l |> expect_string) - else None) - in - assert ( - List.sort compare ws_delete_events = List.sort compare [ "1"; "2"; "3" ]); - - Lwt.return_unit diff --git a/lib/controller/api_v1/streaming.ml b/lib/controller/api_v1/streaming.ml index a26273b..83abfe5 100644 --- a/lib/controller/api_v1/streaming.ml +++ b/lib/controller/api_v1/streaming.ml @@ -1,6 +1,7 @@ -open Lwt.Infix +(*open Lwt.Infix*) -let get req = +let get _req = + (* let%lwt access_token = let open Httpq.Server in req |> query_opt "access_token" >|= function @@ -29,3 +30,5 @@ let get req = loop () (* FIXME *) in Lwt.finalize loop (fun () -> Lwt.return @@ Streaming.remove key conn_id) + *) + assert false diff --git a/lib/dune b/lib/dune index 1218e07..130bce5 100644 --- a/lib/dune +++ b/lib/dune @@ -20,7 +20,14 @@ (libraries base64 blurhash - camlimages.all_formats + camlimages.core + camlimages.jpeg + camlimages.gif + camlimages.png + camlimages.tiff + camlimages.freetype + camlimages.exif + camlimages.xpm cstruct curl.lwt fpath diff --git a/lib/streaming.ml b/lib/streaming.ml index 104fdc0..9cbb46f 100644 --- a/lib/streaming.ml +++ b/lib/streaming.ml @@ -1,6 +1,10 @@ type stream = [ `User ] type key = int * stream + +(* type connection = [ `WebSocket of Httpq.Server.ws_conn ] +*) +type connection = unit type connection_id = int let connections : (key, (connection_id, connection) Hashtbl.t) Hashtbl.t = @@ -33,6 +37,11 @@ let remove (k : key) (id : connection_id) = Hashtbl.remove h id; if Hashtbl.length h = 0 then Hashtbl.remove connections k) +let push ~key ~event ?payload () = + ignore key; + ignore event; + ignore payload +(* let push ~(key : key) ~(event : string) ?payload () = match Hashtbl.find_opt connections key with | None -> () (* Just ignore *) @@ -53,3 +62,4 @@ let push ~(key : key) ~(event : string) ?payload () = ("payload", `String payload) :: l) in `Assoc l |> Yojson.Safe.to_string |> Httpq.Server.ws_send conn) + *) diff --git a/lib_blurhash/test/dune b/lib_blurhash/test/dune index 4c04b41..da516f3 100644 --- a/lib_blurhash/test/dune +++ b/lib_blurhash/test/dune @@ -1,3 +1,3 @@ (tests (names test_blurhash) - (libraries alcotest blurhash camlimages.all_formats)) + (libraries alcotest blurhash camlimages.core camlimages.png)) diff --git a/lib_httpq/bare_server.ml b/lib_httpq/bare_server.ml index e531211..4c633c0 100644 --- a/lib_httpq/bare_server.ml +++ b/lib_httpq/bare_server.ml @@ -2,7 +2,7 @@ open Util open Lwt.Infix module Request = struct - include Cohttp_lwt.Request + include Cohttp.Request let headers = headers |.> Cohttp.Header.to_list end @@ -37,6 +37,7 @@ let start_server port k callback = in Lwt.pick [ server; (k >>= fun () -> Lwt.task () |> fst) ] |> Lwt_main.run + (* type ws_conn = { mutable frames_out_fn : (Websocket.Frame.t option -> unit) option; mutable closed : bool; [@default false] @@ -96,3 +97,4 @@ let websocket (req : Request.t) f = (Printexc.get_backtrace ())); Lwt.return_unit); Lwt.return resp + *) diff --git a/lib_httpq/dune b/lib_httpq/dune index 9d26a93..81202df 100644 --- a/lib_httpq/dune +++ b/lib_httpq/dune @@ -22,7 +22,7 @@ sha unix uri - websocket - websocket-lwt-unix.cohttp + ; websocket + ; websocket-lwt-unix.cohttp x509 yojson)) diff --git a/lib_httpq/server.ml b/lib_httpq/server.ml index bd82ec3..663e496 100644 --- a/lib_httpq/server.ml +++ b/lib_httpq/server.ml @@ -238,6 +238,7 @@ let start_server ?(port = 8080) ?error_handler (handler : handler) k : unit = in aux true res + (* (* WebSocket *) type ws_conn = Bare_server.ws_conn @@ -248,6 +249,7 @@ let websocket (r : request) f = match r with | Request { bare_req; _ } -> Bare_server.websocket bare_req f >|= fun r -> BareResponse r + *) (* Middleware Router *) module Router = struct diff --git a/test_e2e/dune b/test_e2e/_dune similarity index 72% rename from test_e2e/dune rename to test_e2e/_dune index 613a94b..681ea5c 100644 --- a/test_e2e/dune +++ b/test_e2e/_dune @@ -10,7 +10,7 @@ lwt lwt.unix waq - websocket - websocket-lwt-unix - websocket-lwt-unix.cohttp + ; websocket + ; websocket-lwt-unix + ; websocket-lwt-unix.cohttp yojson)) diff --git a/waq.opam b/waq.opam index cf5138c..d786928 100644 --- a/waq.opam +++ b/waq.opam @@ -16,10 +16,11 @@ depends: [ "merlin" {with-dev-setup} "ocamlformat" {= "0.25.1" & with-dev-setup} "base64" - "camlimages" {= "5.0.4-1"} + "camlimages" "cmdliner" "cohttp" "cohttp-lwt-unix" + "cohttp-eio" "cppo" "cstruct" "dune" {>= "3.7"} @@ -32,7 +33,7 @@ depends: [ "mirage-crypto-rng" {<= "0.10.7"} "multipart_form" "multipart_form-lwt" - "ocaml" + "ocaml" {>= "5.0.0"} "ocurl" "pcre" "postgresql" @@ -46,7 +47,7 @@ depends: [ "uri" "uuidm" "websocket" - "websocket-lwt-unix" +# "websocket-lwt-unix" "x509" "xml-light" "yaml" @@ -68,3 +69,8 @@ build: [ ] ] dev-repo: "git+https://github.com/ushitora-anqou/waq.git" +pin-depends:[ + [ "cohttp.6.0.0~alpha2" "git+https://github.com/mirage/ocaml-cohttp.git#v6.0.0_beta2" ] + [ "cohttp-eio.6.0.0~alpha2" "git+https://github.com/mirage/ocaml-cohttp.git#v6.0.0_beta2" ] + [ "camlimages.5.0.5" "git+https://gitlab.com/camlspotter/camlimages.git#c3898f58d14af54d04d9cbc576bc5b1be7d98f6d" ] +]