diff --git a/bin/main.ml b/bin/main.ml
index d5930e5..6fc65b5 100644
--- a/bin/main.ml
+++ b/bin/main.ml
@@ -1,43 +1,46 @@
open Waq
open Util [@@warning "-33"]
-let server () =
- let _host, port = Config.(listen_host (), listen_port ()) in
+let server env =
+ let host, port = Config.(listen_host (), listen_port ()) in
let error_handler ~req ~status ~headers ~body =
let open Controller.Helper in
- let default () = Httpq.Server.respond ~status ~headers body in
+ let default () = Yume.Server.respond ~status ~headers body in
let main () =
- Httpq.Server.respond ~status ~headers
- ("
" ^ Httpq.Status.to_string status ^ "
")
+ Yume.Server.respond ~status ~headers
+ ("
" ^ Yume.Status.to_string status ^ "
")
in
req |> render ~default [ (text_html, main) ]
in
- Eio_main.run @@ fun env ->
- Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ ->
- Lwt_eio.run_lwt @@ fun () ->
- Httpq.Server.start_server ~port ~error_handler Router.handler @@ fun () ->
- Migration.verify_migration_status ();%lwt
- Logq.info (fun m -> m "Listening on 127.0.0.1:%d" port);
- Lwt.return_unit
-
-let db_migrate () =
- Eio_main.run @@ fun env ->
- Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ ->
- Lwt_eio.run_lwt @@ fun () -> Migration.migrate ()
+ Eio.Switch.run @@ fun sw ->
+ Job.Runner.start_global_runner ~sw;
+ let listen =
+ match
+ Eio.Net.getaddrinfo_stream ~service:(string_of_int port)
+ (Eio.Stdenv.net env) host
+ with
+ | [] -> `Tcp (Eio.Net.Ipaddr.V4.loopback, 8080)
+ | x :: _ -> x
+ in
+ Yume.Server.start_server env ~sw ~listen ~error_handler Router.handler
+ @@ fun _ ->
+ Migration.verify_migration_status ();
+ (match listen with
+ | `Tcp (ipaddr, port) ->
+ Logq.info (fun m ->
+ m "Listening on %s:%d" (Fmt.str "%a" Eio.Net.Ipaddr.pp ipaddr) port)
+ | _ -> Logq.info (fun m -> m "Listening on "));
+ ()
-let db_rollback () =
- Eio_main.run @@ fun env ->
- Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ ->
- Lwt_eio.run_lwt @@ fun () -> Migration.rollback ()
+let db_migrate () = Migration.migrate ()
+let db_rollback () = Migration.rollback ()
let db_reset () =
- Eio_main.run @@ fun env ->
- Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ ->
Lwt_eio.run_lwt @@ fun () ->
Db.debug_drop_all_tables_in_db ();%lwt
- Migration.migrate ();%lwt
+ Migration.migrate ();
if Config.debug_generate_test_users () then
(* Generate some users for tests *)
@@ -101,19 +104,17 @@ add_column ~table_name:"preview_cards" ~name:"blurhash" ~spec:"TEXT"
()
let oauth_generate_access_token username =
- Eio_main.run @@ fun env ->
- Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ ->
Lwt_eio.run_lwt @@ fun () ->
(* Generate a new OAuth application named "Web" *)
- let%lwt web =
+ let web =
Oauth_helper.generate_application ~name:"Web"
~redirect_uri:"urn:ietf:wg:oauth:2.0:oob" ~scopes:"read write follow push"
in
- let%lwt user =
- let%lwt a = Db.(e @@ Account.get_one ~username) in
+ let user =
+ let a = Db.(e @@ Account.get_one ~username) in
Db.(e @@ User.get_one ~account_id:a#id)
in
- let%lwt access_token =
+ let access_token =
Oauth_helper.generate_access_token ~scopes:"read write follow push"
~resource_owner_id:user#id ~app:web ()
in
@@ -131,8 +132,6 @@ let hidden_input f =
res
let user_register ?username ?display_name ?email ?password () =
- Eio_main.run @@ fun env ->
- Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ ->
Lwt_eio.run_lwt @@ fun () ->
let username =
match username with
@@ -174,27 +173,22 @@ let user_register ?username ?display_name ?email ?password () =
(u#id |> Model.User.ID.to_int);
Lwt.return_unit
-let account_fetch () =
- Eio_main.run @@ fun env ->
- Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ ->
- Lwt_eio.run_lwt @@ fun () ->
- let open Lwt.Infix in
- let%lwt accts = Db.(e Account.all) in
+let account_fetch env =
+ let accts = Db.(e Account.all) in
accts
- |> Lwt_list.iteri_s @@ fun i acct ->
+ |> List.iteri @@ fun i acct ->
Logq.info (fun m -> m "[%d/%d] %s" (i + 1) (List.length accts) acct#uri);
match acct#domain with
- | None -> Lwt.return_unit
+ | None -> ()
| Some domain -> (
- try%lwt
- Activity.fetch_person (`DomainUser (domain, acct#username))
- >|= Activity.model_account_of_person ~original:acct
- >>= Db.(e *< Account.save_one)
- |> ignore_lwt
+ try
+ Activity.fetch_person env (`DomainUser (domain, acct#username))
+ |> Activity.model_account_of_person ~original:acct
+ |> (fun a -> Db.(e (Account.save_one a)))
+ |> ignore
with e ->
Logq.err (fun m ->
- m "Couldn't fetch person: %s" (Printexc.to_string e));
- Lwt.return_unit)
+ m "Couldn't fetch person: %s" (Printexc.to_string e)))
let webpush_generate_vapid_key () =
let priv_key, pub_key = Webpush.Vapid.generate_keys () in
@@ -202,22 +196,19 @@ let webpush_generate_vapid_key () =
Printf.printf "vapid_public_key: \"%s\"\n" pub_key;
()
-let webpush_deliver username message =
- Eio_main.run @@ fun env ->
- Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ ->
- Lwt_eio.run_lwt @@ fun () ->
- match%lwt
- Db.(
- (e @@ Account.(get_one ~preload:[ `user [] ] ~username ~domain:None))
- |> maybe_no_row)
+let webpush_deliver env username message =
+ match
+ Db.(e @@ Account.(get_one ~preload:[ `user [] ] ~username ~domain:None))
with
- | None -> failwith "username is not found"
- | Some a -> (
+ | exception Sqlx.Error.NoRowFound -> failwith "username is not found"
+ | a -> (
match a#user with
| None -> failwith "username is not local"
- | Some u -> Webpush_helper.deliver ~user_id:u#id message)
+ | Some u -> Webpush_helper.deliver env ~user_id:u#id message)
let () =
+ Eio_main.run @@ fun env ->
+ Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ ->
(let file_name = Config.log_file_path () in
if file_name = "" then Logq.(add_reporter (make_stderr_reporter ~l:Debug))
else Logq.(add_reporter (make_file_reporter ~l:Debug ~file_name ())));
@@ -226,14 +217,14 @@ let () =
Config.to_list ()
|> List.iter (fun (k, v) -> Logq.debug (fun m -> m "Config %s = %s" k v));
- Crypto.initialize ();
+ Crypto.initialize env @@ fun () ->
Db.initialize ();
(* Parse command-line arguments and call a proper handler *)
let open Cmdliner in
Cmd.(
group
- ~default:Term.(const server $ const ())
+ ~default:Term.(const server $ const env)
(info "waq")
[
v (info "db:reset") Term.(const db_reset $ const ());
@@ -268,17 +259,17 @@ let () =
value
& opt (some string) None
& info ~docv:"PASSWORD" [ "password" ]));
- v (info "account:fetch") Term.(const account_fetch $ const ());
+ v (info "account:fetch") Term.(const account_fetch $ const env);
v
(info "webpush:generate_vapid_key")
Term.(const webpush_generate_vapid_key $ const ());
v (info "webpush:deliver")
Term.(
- const webpush_deliver
+ const webpush_deliver $ const env
$ Arg.(
required & pos 0 (some string) None & info ~docv:"USERNAME" [])
$ Arg.(
required & pos 1 (some string) None & info ~docv:"MESSAGE" []));
- v (info "server") Term.(const server $ const ());
+ v (info "server") Term.(const server $ const env);
])
|> Cmd.eval |> exit
diff --git a/e2e/src/common.ml b/e2e/src/common.ml
index 363e9f3..002c8aa 100644
--- a/e2e/src/common.ml
+++ b/e2e/src/common.ml
@@ -1,6 +1,69 @@
-include Lwt.Infix
-module Uri = Httpq.Uri
-module Ptime = Waq.Util.Ptime
+module Ptime = struct
+ include Ptime
+
+ let now () = Unix.gettimeofday () |> of_float_s |> Option.get
+ let to_int x = x |> to_span |> Span.to_int_s |> Option.get
+ let to_rfc3339 = to_rfc3339 ~tz_offset_s:0
+
+ let to_http_date (v : t) : string =
+ let string_of_week = function
+ | `Sun -> "Sun"
+ | `Mon -> "Mon"
+ | `Tue -> "Tue"
+ | `Wed -> "Wed"
+ | `Thu -> "Thu"
+ | `Fri -> "Fri"
+ | `Sat -> "Sat"
+ in
+ let string_of_month = function
+ | 1 -> "Jan"
+ | 2 -> "Feb"
+ | 3 -> "Mar"
+ | 4 -> "Apr"
+ | 5 -> "May"
+ | 6 -> "Jun"
+ | 7 -> "Jul"
+ | 8 -> "Aug"
+ | 9 -> "Sep"
+ | 10 -> "Oct"
+ | 11 -> "Nov"
+ | 12 -> "Dec"
+ | _ -> assert false
+ in
+ let (year, month, day_of_month), ((hour, minute, second), _) =
+ to_date_time v
+ in
+ let month = string_of_month month in
+ let day_name = weekday v |> string_of_week in
+ Printf.sprintf "%s, %02d %s %d %02d:%02d:%02d GMT" day_name day_of_month
+ month year hour minute second
+end
+
+module Uri = struct
+ include Uri
+
+ let getaddrinfo_port (u : t) =
+ let scheme = Uri.scheme u |> Option.get in
+ u |> Uri.port |> Option.fold ~none:scheme ~some:string_of_int
+
+ let http_host (u : t) =
+ let host = Uri.host u |> Option.get in
+ match Uri.port u with
+ | None -> host
+ | Some port -> host ^ ":" ^ string_of_int port
+
+ let path_query_fragment (u : t) =
+ let res = Uri.path u in
+ let res =
+ match Uri.verbatim_query u with None -> res | Some q -> res ^ "?" ^ q
+ in
+ let res =
+ match Uri.fragment u with None -> res | Some f -> res ^ "#" ^ f
+ in
+ res
+
+ let domain (u : t) = http_host u
+end
module Internal = struct
let kubectl_path = Sys.getenv "KUBECTL"
@@ -196,12 +259,77 @@ module Internal = struct
()
end
-let ( |.> ) f g a = a |> f |> g
-let ignore_lwt = Waq.Util.ignore_lwt
-let fetch = Httpq.Client.fetch
-let fetch_exn = Httpq.Client.fetch_exn
let ( ^/ ) a b = a ^ "/" ^ b
+let fetch env ?(headers = []) ?(meth = `GET) ?(body = "") ?(sign = None) url =
+ let open Yume in
+ let uri = Uri.of_string url in
+
+ (* NOTE: Ad-hoc scheme rewriting (https -> http) for localhost
+ for better dev experience *)
+ let uri =
+ match Uri.scheme uri with
+ | Some "https"
+ when [ Some "localhost"; Some "127.0.0.1" ] |> List.mem (Uri.host uri) ->
+ Uri.with_scheme uri (Some "http")
+ | _ -> uri
+ in
+
+ let meth_s = Method.to_string meth in
+ let headers =
+ let headers =
+ let add (k, v) headers =
+ if List.mem_assoc k headers then headers else (k, v) :: headers
+ in
+ headers
+ |> add (`Content_length, body |> String.length |> string_of_int)
+ |> add (`Connection, "close")
+ |> add (`Host, Uri.http_host uri)
+ |> add (`Date, Ptime.(now () |> to_http_date))
+ in
+ let headers =
+ match sign with
+ | None -> headers
+ | Some (priv_key, key_id, signed_headers) ->
+ Signature.sign ~priv_key ~key_id ~signed_headers ~headers ~meth
+ ~path:(Uri.path_query_fragment uri)
+ ~body:(Some body)
+ in
+ Headers.to_list headers
+ in
+ try
+ Eio.Switch.run @@ fun sw ->
+ let resp =
+ match meth with
+ | `GET | `DELETE ->
+ Client.request env ~sw ~headers ~meth (Uri.to_string uri)
+ | `POST | `PATCH ->
+ Client.request env ~sw ~headers ~body:(`Fixed body) ~meth
+ (Uri.to_string uri)
+ | _ -> failwith "Not implemented method"
+ in
+ let status = Client.Response.status resp in
+ Logq.debug (fun m ->
+ m "[fetch] %s %s --> %s" meth_s url
+ (Cohttp.Code.string_of_status status));
+ let headers = Client.Response.headers resp in
+ let body = Client.Response.drain resp in
+ Ok (status, headers, body)
+ with e ->
+ let backtrace = Printexc.get_backtrace () in
+ Logq.err (fun m ->
+ m "[fetch] %s %s: %s\n%s" meth_s url (Printexc.to_string e) backtrace);
+ Error ()
+
+exception FetchFailure of (Yume.Status.t * Yume.Headers.t * string) option
+
+let fetch_exn ?(headers = []) ?(meth = `GET) ?(body = "") ?(sign = None) env
+ (url : string) : string =
+ match fetch env ~headers ~meth ~body ~sign url with
+ | Ok (`OK, _, body) -> body
+ | Ok r -> raise (FetchFailure (Some r))
+ | _ -> raise (FetchFailure None)
+
let expect_string = function
| `String s -> s
| _ -> failwith "Expected string, got something different"
@@ -223,7 +351,9 @@ let expect_int = function
| _ -> failwith "Expected int, got something different"
let with_lock mtx f =
- match mtx with None -> f () | Some mtx -> Lwt_mutex.with_lock mtx f
+ match mtx with
+ | None -> f ()
+ | Some mtx -> Eio.Mutex.use_rw ~protect:true mtx f
let new_session f =
Internal.launch_waq @@ fun tokens ->
@@ -241,23 +371,18 @@ let make_waq_and_mstdn_scenario ?(timeout = 30.0) handler () : unit =
new_mastodon_session @@ fun mstdn_token ->
Logq.debug (fun m -> m "Access token for Mastodon: %s" mstdn_token);
Unix.sleep 10;
- Lwt_main.run
- @@ Lwt.pick
- [
- handler waq_token mstdn_token;
- (Lwt_unix.sleep timeout >>= fun () -> failwith "Timeout");
- ]
+ Eio_main.run @@ fun env ->
+ Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () ->
+ Eio.Time.with_timeout_exn env#clock timeout (fun () ->
+ handler env waq_token mstdn_token)
let make_waq_scenario ?(timeout = 30.0) handler () : unit =
new_session @@ fun waq_token ->
Logq.debug (fun m -> m "Access token for Waq: %s" waq_token);
Unix.sleep 1;
- Lwt_main.run
- @@ Lwt.pick
- [
- handler waq_token;
- (Lwt_unix.sleep timeout >>= fun () -> failwith "Timeout");
- ]
+ Eio_main.run @@ fun env ->
+ Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () ->
+ Eio.Time.with_timeout_exn env#clock timeout (fun () -> handler env waq_token)
let waq_server_name = Sys.getenv "E2E_TEST_WAQ_SERVER_NAME"
let waq_server_domain = Uri.(of_string waq_server_name |> domain)
@@ -271,7 +396,7 @@ let pp_json (s : string) =
Logq.debug (fun m -> m "%s" Yojson.Safe.(from_string s |> pretty_to_string))
[@@warning "-32"]
-let do_fetch ?token ?(meth = `GET) ?(body = "") kind target =
+let do_fetch env ?token ?(meth = `GET) ?(body = "") kind target =
let headers = [ (`Accept, "application/json") ] in
let headers =
match meth with
@@ -283,7 +408,7 @@ let do_fetch ?token ?(meth = `GET) ?(body = "") kind target =
| Some token -> (`Authorization, "Bearer " ^ token) :: headers
| None -> headers
in
- fetch_exn ~headers ~meth ~body (url kind target)
+ fetch_exn env ~headers ~meth ~body (url kind target)
type account = {
id : string;
@@ -351,7 +476,8 @@ type notification = {
type marker = { last_read_id : string; version : int; updated_at : string }
[@@deriving make, yojson]
-let update_credentials ~token kind ?display_name ?note ?avatar ?header ?bot () =
+let update_credentials env ~token kind ?display_name ?note ?avatar ?header ?bot
+ () =
let target = "/api/v1/accounts/update_credentials" in
let headers =
[
@@ -429,55 +555,54 @@ let update_credentials ~token kind ?display_name ?note ?avatar ?header ?bot () =
in
assert (List.length body <> 2);
let body = String.concat "\r\n" body in
- fetch_exn ~headers ~meth:`PATCH ~body (url kind target)
- >|= Yojson.Safe.from_string >|= account_of_yojson
+ fetch_exn env ~headers ~meth:`PATCH ~body (url kind target)
+ |> Yojson.Safe.from_string |> account_of_yojson
-let lookup_via_v1_accounts_lookup ~token kind ?domain ~username () =
+let lookup_via_v1_accounts_lookup env ~token kind ?domain ~username () =
let target =
let src = "/api/v1/accounts/lookup?acct=" in
match domain with
| None -> src ^ username
| Some domain -> src ^ username ^ "@" ^ domain
in
- let%lwt r = do_fetch ~token kind target in
+ let r = do_fetch env ~token kind target in
let a = r |> Yojson.Safe.from_string |> account_of_yojson in
- Lwt.return (a.id, a.username, a.acct)
+ (a.id, a.username, a.acct)
-let lookup_via_v1_accounts_search ?token kind ?domain ~username () =
+let lookup_via_v1_accounts_search env ?token kind ?domain ~username () =
let target =
let src = "/api/v1/accounts/search?resolve=true&q=@" in
match domain with
| None -> src ^ username
| Some domain -> src ^ username ^ "@" ^ domain
in
- let%lwt r = do_fetch ?token kind target in
+ let r = do_fetch env ?token kind target in
let l =
match Yojson.Safe.from_string r with
| `List [ `Assoc l ] -> l
| _ -> assert false
in
- Lwt.return
- ( l |> List.assoc "id" |> expect_string,
- l |> List.assoc "username" |> expect_string,
- l |> List.assoc "acct" |> expect_string )
+ ( l |> List.assoc "id" |> expect_string,
+ l |> List.assoc "username" |> expect_string,
+ l |> List.assoc "acct" |> expect_string )
-let search ?token kind q =
+let search env ?token kind q =
let queries = [ ("resolve", [ "true" ]); ("q", [ q ]) ] in
let u = Uri.of_string "/api/v2/search" in
let u = Uri.add_query_params u queries in
- let%lwt r = do_fetch ?token kind (Uri.to_string u) in
+ let r = do_fetch env ?token kind (Uri.to_string u) in
let l = Yojson.Safe.from_string r |> expect_assoc in
- Lwt.return
- ( List.assoc "accounts" l |> expect_list |> List.map account_of_yojson,
- List.assoc "statuses" l |> expect_list |> List.map status_of_yojson,
- List.assoc "hashtags" l |> expect_list )
-
-let lookup ~token kind ?domain ~username () =
- search ~token kind
- (domain
- |> Option.fold ~none:("@" ^ username) ~some:(fun domain ->
- "@" ^ username ^ "@" ^ domain))
- >|= function
+ ( List.assoc "accounts" l |> expect_list |> List.map account_of_yojson,
+ List.assoc "statuses" l |> expect_list |> List.map status_of_yojson,
+ List.assoc "hashtags" l |> expect_list )
+
+let lookup env ~token kind ?domain ~username () =
+ match
+ search env ~token kind
+ (domain
+ |> Option.fold ~none:("@" ^ username) ~some:(fun domain ->
+ "@" ^ username ^ "@" ^ domain))
+ with
| [ acct ], _, _ -> (acct.id, acct.username, acct.acct)
| accts, _, _ ->
Logq.err (fun m ->
@@ -487,92 +612,92 @@ let lookup ~token kind ?domain ~username () =
|> String.concat ", "));
assert false
-let get_account kind id =
- do_fetch kind ("/api/v1/accounts/" ^ id)
- >|= Yojson.Safe.from_string >|= account_of_yojson
+let get_account env kind id =
+ do_fetch env kind ("/api/v1/accounts/" ^ id)
+ |> Yojson.Safe.from_string |> account_of_yojson
-let get_relationships ~token kind account_ids =
+let get_relationships env ~token kind account_ids =
let target =
"/api/v1/accounts/relationships?"
^ (account_ids |> List.map (fun id -> "id[]=" ^ id) |> String.concat "&")
in
- do_fetch ~token kind target
- >|= Yojson.Safe.from_string >|= expect_list
- >|= List.map relationship_of_yojson
+ do_fetch env ~token kind target
+ |> Yojson.Safe.from_string |> expect_list
+ |> List.map relationship_of_yojson
-let get_followers ?token kind account_id =
- do_fetch ?token kind ("/api/v1/accounts/" ^ account_id ^ "/followers")
- >|= Yojson.Safe.from_string >|= expect_list >|= List.map account_of_yojson
+let get_followers env ?token kind account_id =
+ do_fetch env ?token kind ("/api/v1/accounts/" ^ account_id ^ "/followers")
+ |> Yojson.Safe.from_string |> expect_list |> List.map account_of_yojson
-let get_following ?token kind account_id =
- do_fetch ?token kind ("/api/v1/accounts/" ^ account_id ^ "/following")
- >|= Yojson.Safe.from_string >|= expect_list >|= List.map account_of_yojson
+let get_following env ?token kind account_id =
+ do_fetch env ?token kind ("/api/v1/accounts/" ^ account_id ^ "/following")
+ |> Yojson.Safe.from_string |> expect_list |> List.map account_of_yojson
-let get_notifications ?token kind =
- do_fetch ?token kind "/api/v1/notifications"
- >|= Yojson.Safe.from_string >|= expect_list
- >|= List.map notification_of_yojson
+let get_notifications env ?token kind =
+ do_fetch env ?token kind "/api/v1/notifications"
+ |> Yojson.Safe.from_string |> expect_list
+ |> List.map notification_of_yojson
let markers_of_yojson j =
let l = expect_assoc j in
( List.assoc_opt "home" l |> Option.map marker_of_yojson,
List.assoc_opt "notifications" l |> Option.map marker_of_yojson )
-let get_markers ?token kind timelines =
- do_fetch ?token kind
+let get_markers env ?token kind timelines =
+ do_fetch env ?token kind
("/api/v1/markers?"
^ (timelines |> List.map (fun s -> "timeline[]=" ^ s) |> String.concat "&")
)
- >|= Yojson.Safe.from_string >|= markers_of_yojson
+ |> Yojson.Safe.from_string |> markers_of_yojson
-let post_markers ?token kind values =
+let post_markers env ?token kind values =
let body =
values
|> List.map (fun (timeline, last_read_id) ->
(timeline, `Assoc [ ("last_read_id", `String last_read_id) ]))
|> fun l -> `Assoc l |> Yojson.Safe.to_string
in
- do_fetch ~meth:`POST ?token kind ~body "/api/v1/markers"
- >|= Yojson.Safe.from_string >|= markers_of_yojson
+ do_fetch env ~meth:`POST ?token kind ~body "/api/v1/markers"
+ |> Yojson.Safe.from_string |> markers_of_yojson
-let follow ~token kind account_id =
- let%lwt r =
- do_fetch ~meth:`POST ~token kind
+let follow env ~token kind account_id =
+ let r =
+ do_fetch env ~meth:`POST ~token kind
("/api/v1/accounts/" ^ account_id ^ "/follow")
in
assert (
Yojson.Safe.from_string r |> expect_assoc |> List.assoc "following"
|> expect_bool);
- Lwt.return_unit
+ ()
-let unfollow ~token kind account_id =
- do_fetch ~meth:`POST ~token kind
+let unfollow env ~token kind account_id =
+ do_fetch env ~meth:`POST ~token kind
("/api/v1/accounts/" ^ account_id ^ "/unfollow")
- |> ignore_lwt
+ |> ignore
-let get_status kind ?token status_id =
- do_fetch ?token kind ("/api/v1/statuses/" ^ status_id)
- >|= Yojson.Safe.from_string >|= status_of_yojson
+let get_status env kind ?token status_id =
+ do_fetch env ?token kind ("/api/v1/statuses/" ^ status_id)
+ |> Yojson.Safe.from_string |> status_of_yojson
-let get_account_statuses kind ?token ?(exclude_replies = false) account_id =
- do_fetch ?token kind
+let get_account_statuses env kind ?token ?(exclude_replies = false) account_id =
+ do_fetch env ?token kind
("/api/v1/accounts/" ^ account_id ^ "/statuses?exclude_replies="
^ string_of_bool exclude_replies)
- >|= Yojson.Safe.from_string >|= expect_list >|= List.map status_of_yojson
+ |> Yojson.Safe.from_string |> expect_list |> List.map status_of_yojson
-let get_status_context kind status_id =
- let%lwt r = do_fetch kind ("/api/v1/statuses/" ^ status_id ^ "/context") in
+let get_status_context env kind status_id =
+ let r = do_fetch env kind ("/api/v1/statuses/" ^ status_id ^ "/context") in
let l = Yojson.Safe.from_string r |> expect_assoc in
match l with
| [ ("ancestors", `List ancestors); ("descendants", `List descendants) ]
| [ ("descendants", `List descendants); ("ancestors", `List ancestors) ] ->
let ancestors = ancestors |> List.map status_of_yojson in
let descendants = descendants |> List.map status_of_yojson in
- Lwt.return (ancestors, descendants)
+ (ancestors, descendants)
| _ -> assert false
-let post ~token kind ?spoiler_text ?content ?in_reply_to_id ?(media_ids = []) ()
- =
+let post env ~token kind ?spoiler_text ?content ?in_reply_to_id
+ ?(media_ids = []) () =
let content = content |> Option.value ~default:"こんにちは、世界！" in
let body =
let l =
@@ -592,40 +717,42 @@ let post ~token kind ?spoiler_text ?content ?in_reply_to_id ?(media_ids = []) ()
in
`Assoc l |> Yojson.Safe.to_string
in
- do_fetch ~token ~meth:`POST ~body kind "/api/v1/statuses"
- >|= Yojson.Safe.from_string >|= status_of_yojson
+ do_fetch env ~token ~meth:`POST ~body kind "/api/v1/statuses"
+ |> Yojson.Safe.from_string |> status_of_yojson
-let delete_status ~token kind status_id =
- do_fetch ~token ~meth:`DELETE kind ("/api/v1/statuses/" ^ status_id)
- >|= Yojson.Safe.from_string >|= status_of_yojson
+let delete_status env ~token kind status_id =
+ do_fetch env ~token ~meth:`DELETE kind ("/api/v1/statuses/" ^ status_id)
+ |> Yojson.Safe.from_string |> status_of_yojson
-let reblog ~token kind ~id =
- do_fetch ~token ~meth:`POST kind ("/api/v1/statuses/" ^ id ^ "/reblog")
- >|= Yojson.Safe.from_string >|= status_of_yojson
+let reblog env ~token kind ~id =
+ do_fetch env ~token ~meth:`POST kind ("/api/v1/statuses/" ^ id ^ "/reblog")
+ |> Yojson.Safe.from_string |> status_of_yojson
-let unreblog ~token kind ~id =
- do_fetch ~token ~meth:`POST kind ("/api/v1/statuses/" ^ id ^ "/unreblog")
- >|= Yojson.Safe.from_string >|= status_of_yojson
+let unreblog env ~token kind ~id =
+ do_fetch env ~token ~meth:`POST kind ("/api/v1/statuses/" ^ id ^ "/unreblog")
+ |> Yojson.Safe.from_string |> status_of_yojson
-let fav ~token kind ~id =
- do_fetch ~token ~meth:`POST kind ("/api/v1/statuses/" ^ id ^ "/favourite")
- >|= Yojson.Safe.from_string >|= status_of_yojson
+let fav env ~token kind ~id =
+ do_fetch env ~token ~meth:`POST kind ("/api/v1/statuses/" ^ id ^ "/favourite")
+ |> Yojson.Safe.from_string |> status_of_yojson
-let unfav ~token kind ~id =
- do_fetch ~token ~meth:`POST kind ("/api/v1/statuses/" ^ id ^ "/unfavourite")
- >|= Yojson.Safe.from_string >|= status_of_yojson
+let unfav env ~token kind ~id =
+ do_fetch env ~token ~meth:`POST kind
+ ("/api/v1/statuses/" ^ id ^ "/unfavourite")
+ |> Yojson.Safe.from_string |> status_of_yojson
-let get_favourited_by ~token kind ~id =
- do_fetch ~token ~meth:`GET kind ("/api/v1/statuses/" ^ id ^ "/favourited_by")
- >|= Yojson.Safe.from_string >|= expect_list >|= List.map account_of_yojson
+let get_favourited_by env ~token kind ~id =
+ do_fetch env ~token ~meth:`GET kind
+ ("/api/v1/statuses/" ^ id ^ "/favourited_by")
+ |> Yojson.Safe.from_string |> expect_list |> List.map account_of_yojson
-let home_timeline ~token kind =
- do_fetch ~token kind "/api/v1/timelines/home" >|= fun r ->
+let home_timeline env ~token kind =
+ do_fetch env ~token kind "/api/v1/timelines/home" |> fun r ->
match Yojson.Safe.from_string r with `List l -> l | _ -> assert false
-let fetch_access_token ~username =
- let%lwt r =
- fetch_exn ~meth:`POST
+let fetch_access_token env ~username =
+ let r =
+ fetch_exn env ~meth:`POST
~headers:[ (`Content_type, "application/json") ]
~body:
{|{"client_name":"foo","redirect_uris":"http://example.com?origin=http://example.com"}|}
@@ -639,7 +766,7 @@ let fetch_access_token ~username =
| _ -> assert false
in
- let%lwt r =
+ let r =
let body =
Uri.encoded_of_query
[
@@ -653,7 +780,7 @@ let fetch_access_token ~username =
(* NOTE: The header "content-type: application/x-www-form-urlencoded"
should be specified explicitly like the following to send the POST
request body correctly via Tunnelmole. *)
- fetch
+ fetch env
~headers:[ (`Content_type, "application/x-www-form-urlencoded") ]
~meth:`POST ~body (waq "/oauth/authorize")
in
@@ -662,13 +789,13 @@ let fetch_access_token ~username =
| Ok (`Found, headers, _body) ->
(* 0123456789012345678901234
http://example.com?code=... *)
- headers |> List.assoc "location" |> Uri.of_string |> Uri.query
+ headers |> List.assoc `Location |> Uri.of_string |> Uri.query
|> List.assoc "code" |> List.hd
| _ -> assert false
in
- let%lwt r =
- fetch_exn ~meth:`POST
+ let r =
+ fetch_exn env ~meth:`POST
~headers:[ (`Content_type, "application/json") ]
~body:
(`Assoc
@@ -684,87 +811,84 @@ let fetch_access_token ~username =
(waq "/oauth/token")
in
match Yojson.Safe.from_string r with
- | `Assoc l -> l |> List.assoc "access_token" |> expect_string |> Lwt.return
+ | `Assoc l -> l |> List.assoc "access_token" |> expect_string
| _ -> assert false
-let websocket ?mtx ~token kind ?target handler f =
- let open Websocket_lwt_unix in
+let websocket env ?mtx ~token kind ?target handler f =
let target =
match target with
| Some target -> target
| None -> "/api/v1/streaming?stream=user"
in
- let uri = Uri.of_string (url kind target) in
- let%lwt endp = Resolver_lwt.resolve_uri ~uri Resolver_lwt_unix.system in
- let ctx = Lazy.force Conduit_lwt_unix.default_ctx in
- let%lwt client = Conduit_lwt_unix.endp_to_client ~ctx endp in
-
let extra_headers =
Cohttp.Header.of_list [ ("Sec-WebSocket-Protocol", token) ]
in
- let%lwt conn = connect ~extra_headers ~ctx client uri in
+ Eio.Switch.run @@ fun sw ->
+ let conn = Yume.Ws.Client.connect env ~sw ~extra_headers (url kind target) in
let close_sent = ref false in
let pushf msg =
match msg with
- | Some content -> write conn (Websocket.Frame.create ~content ())
- | None when !close_sent -> Lwt.return_unit
+ | Some content ->
+ Yume.Ws.Client.write conn (Websocket.Frame.create ~content ())
+ | None when !close_sent -> ()
| None ->
- write conn (Websocket.Frame.create ~opcode:Close ());%lwt
- Lwt.return (close_sent := true)
+ Yume.Ws.Client.write conn (Websocket.Frame.create ~opcode:Close ());
+ close_sent := true
in
let rec react () =
- match%lwt read conn with
+ match Yume.Ws.Client.read conn with
| { Websocket.Frame.opcode = Ping; _ } ->
- write conn (Websocket.Frame.create ~opcode:Pong ());%lwt
+ Yume.Ws.Client.write conn (Websocket.Frame.create ~opcode:Pong ());
react ()
| { opcode = Pong; _ } -> react ()
| { opcode = Text; content; _ } | { opcode = Binary; content; _ } ->
- with_lock mtx (fun () -> handler content pushf);%lwt
+ with_lock mtx (fun () -> handler content pushf);
react ()
| { opcode = Close; content; _ } ->
- if !close_sent then Lwt.return_unit
+ if !close_sent then ()
else if String.length content >= 2 then
- write conn
+ Yume.Ws.Client.write conn
(Websocket.Frame.create ~opcode:Close
~content:(String.sub content 0 2) ())
- else write conn (Websocket.Frame.close 1000);%lwt
- close_transport conn
- | _ -> close_transport conn
+ else Yume.Ws.Client.write conn (Websocket.Frame.close 1000);
+ Yume.Ws.Client.close_transport conn
+ | _ -> Yume.Ws.Client.close_transport conn
in
- Lwt.join [ with_lock mtx (fun () -> f pushf); react () ]
+ Eio.Fiber.both
+ (fun () -> react ())
+ (fun () -> with_lock mtx (fun () -> f pushf))
let websocket_handler_state_machine ~states ~init () =
let current = ref init in
let set_current v = current := v in
let handler content pushf =
let real_handler = states |> List.assoc !current in
- let%lwt next_state =
+ let next_state =
real_handler (content |> Yojson.Safe.from_string |> expect_assoc) pushf
in
set_current next_state;
- Lwt.return_unit
+ ()
in
(set_current, handler)
-let websocket_stack kind ~token ?num_msgs f =
+let websocket_stack env kind ~token ?num_msgs f =
let recv_msgs = ref [] in
let handler content pushf =
recv_msgs := content :: !recv_msgs;
match num_msgs with
| Some num_msgs when List.length !recv_msgs = num_msgs -> pushf None
- | _ -> Lwt.return_unit
+ | _ -> ()
in
- websocket kind ~token handler (fun pushf ->
- f pushf;%lwt
- match num_msgs with None -> pushf None | Some _ -> Lwt.return_unit)
- >|= fun () -> !recv_msgs
-
-let expect_exc_lwt f =
- (try%lwt
- let%lwt _ = f () in
- Lwt.return_false
- with _ -> Lwt.return_true)
- >|= fun b -> assert b
+ websocket env kind ~token handler (fun pushf ->
+ f pushf;
+ match num_msgs with None -> pushf None | Some _ -> ());
+ !recv_msgs
+
+let expect_exc f =
+ try
+ let _ = f () in
+ assert false
+ with _ -> ()
let test_image =
{|
diff --git a/e2e/src/common2.ml b/e2e/src/common2.ml
index 363c50c..84a4c58 100644
--- a/e2e/src/common2.ml
+++ b/e2e/src/common2.ml
@@ -11,25 +11,27 @@ type agent = {
let acct_of_agent ~(from : agent) (a : agent) =
if a.domain = from.domain then a.username else a.username ^ "@" ^ a.domain
-let lookup src = lookup src.kind ~token:src.token
-let follow src = follow src.kind ~token:src.token
-let post src = post src.kind ~token:src.token
-let search src = search src.kind ~token:src.token
-let reblog src = reblog src.kind ~token:src.token
-let unreblog src = unreblog src.kind ~token:src.token
+let lookup env src = lookup env src.kind ~token:src.token
+let follow env src = follow env src.kind ~token:src.token
+let post env src = post env src.kind ~token:src.token
+let search env src = search env src.kind ~token:src.token
+let reblog env src = reblog env src.kind ~token:src.token
+let unreblog env src = unreblog env src.kind ~token:src.token
-let home_timeline src =
- home_timeline src.kind ~token:src.token >|= List.map status_of_yojson
+let home_timeline env src =
+ home_timeline env src.kind ~token:src.token |> List.map status_of_yojson
-let delete_status src = delete_status src.kind ~token:src.token
-let get_status src = get_status src.kind ~token:src.token
-let get_notifications src = get_notifications src.kind ~token:src.token
-let update_credentials src = update_credentials src.kind ~token:src.token
+let delete_status env src = delete_status env src.kind ~token:src.token
+let get_status env src = get_status env src.kind ~token:src.token
+let get_notifications env src = get_notifications env src.kind ~token:src.token
-let websocket src ?target handler f =
- websocket src.kind ~token:src.token ?target handler f
+let update_credentials env src =
+ update_credentials env src.kind ~token:src.token
-let upload_media src ~filename ~data ~content_type =
+let websocket env src ?target handler f =
+ websocket env src.kind ~token:src.token ?target handler f
+
+let upload_media env src ~filename ~data ~content_type =
let target = "/api/v2/media" in
let headers =
[
@@ -56,22 +58,22 @@ let upload_media src ~filename ~data ~content_type =
in
assert (List.length body <> 2);
let body = String.concat "\r\n" body in
- fetch_exn ~headers ~meth:`POST ~body (url src.kind target)
- >|= Yojson.Safe.from_string >|= media_attachment_of_yojson
+ fetch_exn env ~headers ~meth:`POST ~body (url src.kind target)
+ |> Yojson.Safe.from_string |> media_attachment_of_yojson
-let lookup_agent src dst =
+let lookup_agent env src dst =
let domain = if src.domain = dst.domain then None else Some dst.domain in
- lookup src ~username:dst.username ?domain ()
+ lookup env src ~username:dst.username ?domain ()
-let follow_agent src dst =
- let%lwt id, _, _ = lookup_agent src dst in
- follow src id
+let follow_agent env src dst =
+ let id, _, _ = lookup_agent env src dst in
+ follow env src id
-let expect_no_status src id =
- try%lwt
- get_status src id |> ignore_lwt;%lwt
+let expect_no_status env src id =
+ try
+ get_status env src id |> ignore;
assert false
- with Httpq.Client.FetchFailure (Some (`Not_found, _, _)) -> Lwt.return_unit
+ with FetchFailure (Some (`Not_found, _, _)) -> ()
type runtime_context = {
waq_tokens : string array;
@@ -95,7 +97,8 @@ let generate_mstdn_agent ctxt =
let username = "mstdn" ^ string_of_int (i + 1) in
make_agent ~kind:`Mstdn ~token ~username ~domain:mstdn_server_domain
-let launch_waq ?(timeout = 30.0) (f : runtime_context -> unit Lwt.t) : unit =
+let launch_waq ?(timeout = 30.0)
+ (f : Eio_unix.Stdenv.base -> runtime_context -> unit) : unit =
Internal.launch_waq @@ fun waq_tokens ->
Logq.debug (fun m ->
m "Access token for Waq: [%s]"
@@ -105,11 +108,12 @@ let launch_waq ?(timeout = 30.0) (f : runtime_context -> unit Lwt.t) : unit =
~mstdn_num_used_tokens:0
in
Unix.sleep 10;
- Lwt.pick [ f ctxt; (Lwt_unix.sleep timeout >>= fun () -> failwith "Timeout") ]
- |> Lwt_main.run
+ Eio_main.run @@ fun env ->
+ Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () ->
+ Eio.Time.with_timeout_exn env#clock timeout (fun () -> f env ctxt)
-let launch_waq_and_mstdn ?(timeout = 30.0) (f : runtime_context -> unit Lwt.t) :
- unit =
+let launch_waq_and_mstdn ?(timeout = 30.0)
+ (f : Eio_unix.Stdenv.base -> runtime_context -> unit) : unit =
Internal.launch_waq @@ fun waq_tokens ->
Logq.debug (fun m ->
m "Access token for Waq: [%s]"
@@ -123,5 +127,6 @@ let launch_waq_and_mstdn ?(timeout = 30.0) (f : runtime_context -> unit Lwt.t) :
~mstdn_num_used_tokens:0
in
Unix.sleep 10;
- Lwt.pick [ f ctxt; (Lwt_unix.sleep timeout >>= fun () -> failwith "Timeout") ]
- |> Lwt_main.run
+ Eio_main.run @@ fun env ->
+ Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () ->
+ Eio.Time.with_timeout_exn env#clock timeout (fun () -> f env ctxt)
diff --git a/e2e/src/dune b/e2e/src/dune
index 613a94b..3bea1d8 100644
--- a/e2e/src/dune
+++ b/e2e/src/dune
@@ -1,16 +1,13 @@
(executable
(name main)
(preprocess
- (pps lwt_ppx ppx_deriving.make ppx_yojson_conv))
+ (pps ppx_deriving.make ppx_yojson_conv))
(libraries
- cohttp
- cohttp-lwt-unix
- httpq
+ eio
+ eio_main
+ lambdasoup
logq
- lwt
- lwt.unix
- waq
- websocket
- websocket-lwt-unix
- websocket-lwt-unix.cohttp
- yojson))
+ mirage-crypto-rng
+ mirage-crypto-rng-eio
+ yojson
+ yume))
diff --git a/e2e/src/main.ml b/e2e/src/main.ml
index 5faf7c3..9cfc7af 100644
--- a/e2e/src/main.ml
+++ b/e2e/src/main.ml
@@ -1,6 +1,3 @@
-module Uri = Httpq.Uri
-module Ptime = Waq.Util.Ptime
-
let all_tests =
[
("waq-mstdn-1", Waq_mstdn_1.f);
diff --git a/e2e/src/waq_1.ml b/e2e/src/waq_1.ml
index 140692e..728df4c 100644
--- a/e2e/src/waq_1.ml
+++ b/e2e/src/waq_1.ml
@@ -1,11 +1,11 @@
open Common
let f =
- make_waq_scenario @@ fun _token ->
- let%lwt access_token = fetch_access_token ~username:"user1" in
+ make_waq_scenario @@ fun env _token ->
+ let access_token = fetch_access_token env ~username:"user1" in
- let%lwt r =
- fetch_exn
+ let r =
+ fetch_exn env
~headers:[ (`Authorization, "Bearer " ^ access_token) ]
(waq "/api/v1/apps/verify_credentials")
in
@@ -14,8 +14,8 @@ let f =
| `Assoc l -> l |> List.assoc "name" |> expect_string = "foo"
| _ -> false);
- let%lwt r =
- fetch_exn
+ let r =
+ fetch_exn env
~headers:[ (`Authorization, "Bearer " ^ access_token) ]
(waq "/api/v1/accounts/verify_credentials")
in
@@ -29,11 +29,11 @@ let f =
|> expect_string = "public");
let account_id = l |> List.assoc "id" |> expect_string in
- let%lwt r = fetch_exn (waq "/api/v1/instance") in
+ let r = fetch_exn env (waq "/api/v1/instance") in
let l = Yojson.Safe.from_string r |> expect_assoc in
assert (l |> List.mem_assoc "uri");
- let%lwt r = get_account `Waq account_id in
+ let r = get_account env `Waq account_id in
assert (r.id = account_id);
assert (r.username = "user1");
assert (r.acct = "user1");
@@ -42,11 +42,11 @@ let f =
assert (r.followers_count = 0);
assert (r.following_count = 0);
- let%lwt a =
- update_credentials `Waq ~token:access_token ~display_name:"mod user1" ()
+ let a =
+ update_credentials env `Waq ~token:access_token ~display_name:"mod user1" ()
in
assert (a.display_name = "mod user1");
- let%lwt a = get_account `Waq account_id in
+ let a = get_account env `Waq account_id in
assert (a.display_name = "mod user1");
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_10_mention.ml b/e2e/src/waq_10_mention.ml
index d08edd8..30126fe 100644
--- a/e2e/src/waq_10_mention.ml
+++ b/e2e/src/waq_10_mention.ml
@@ -1,12 +1,12 @@
open Common
let f =
- make_waq_scenario @@ fun token ->
- let%lwt user1_id, _, _ = lookup `Waq ~token ~username:"user1" () in
- let%lwt token2 = fetch_access_token ~username:"user2" in
- let%lwt { id; _ } = post `Waq ~token ~content:"@user2 てすと" () in
+ make_waq_scenario @@ fun env token ->
+ let user1_id, _, _ = lookup env `Waq ~token ~username:"user1" () in
+ let token2 = fetch_access_token env ~username:"user2" in
+ let ({ id; _ } : status) = post env `Waq ~token ~content:"@user2 てすと" () in
- let%lwt ntfs = get_notifications `Waq ~token:token2 in
+ let ntfs = get_notifications env `Waq ~token:token2 in
(match ntfs with
| [
{
@@ -18,11 +18,11 @@ let f =
] ->
assert (account_id = user1_id);
assert (status_id = id);
- Lwt.return_unit
- | _ -> assert false);%lwt
+ ()
+ | _ -> assert false);
(* Handle invalid mentions correctly *)
- let%lwt _ = post `Waq ~token ~content:"@not_found_user test" () in
- home_timeline `Waq ~token |> ignore_lwt;%lwt
+ let _ = post env `Waq ~token ~content:"@not_found_user test" () in
+ home_timeline env `Waq ~token |> ignore;
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_11_marker.ml b/e2e/src/waq_11_marker.ml
index 745f281..62dd08d 100644
--- a/e2e/src/waq_11_marker.ml
+++ b/e2e/src/waq_11_marker.ml
@@ -1,18 +1,18 @@
open Common
let f =
- make_waq_scenario @@ fun token ->
- let%lwt Some { last_read_id = "0"; _ }, Some { last_read_id = "0"; _ } =
- get_markers ~token `Waq [ "home"; "notifications" ]
+ make_waq_scenario @@ fun env token ->
+ let Some { last_read_id = "0"; _ }, Some { last_read_id = "0"; _ } =
+ get_markers env ~token `Waq [ "home"; "notifications" ]
in
- let%lwt Some { last_read_id = "1"; _ }, None =
- post_markers ~token `Waq [ ("home", "1") ]
+ let Some { last_read_id = "1"; _ }, None =
+ post_markers env ~token `Waq [ ("home", "1") ]
in
- let%lwt None, Some { last_read_id = "2"; _ } =
- post_markers ~token `Waq [ ("notifications", "2") ]
+ let None, Some { last_read_id = "2"; _ } =
+ post_markers env ~token `Waq [ ("notifications", "2") ]
in
- let%lwt Some { last_read_id = "1"; _ }, Some { last_read_id = "2"; _ } =
- get_markers ~token `Waq [ "home"; "notifications" ]
+ let Some { last_read_id = "1"; _ }, Some { last_read_id = "2"; _ } =
+ get_markers env ~token `Waq [ "home"; "notifications" ]
in
- Lwt.return_unit
+ ()
[@@warning "-8"]
diff --git a/e2e/src/waq_2_ws.ml b/e2e/src/waq_2_ws.ml
index d47f877..24d7296 100644
--- a/e2e/src/waq_2_ws.ml
+++ b/e2e/src/waq_2_ws.ml
@@ -2,7 +2,7 @@ open Common
open struct
let f ~use_query_param =
- make_waq_scenario @@ fun waq_token ->
+ make_waq_scenario @@ fun env waq_token ->
let got_uri = ref None in
let set_current_state, handler =
websocket_handler_state_machine ~init:`Init
@@ -21,13 +21,13 @@ open struct
got_uri := Some uri;
(* Check that no event should be received once an unsubscribe message is sent. *)
- if%lwt Lwt.return (not use_query_param) then (
- pushf (Some {|{"type":"unsubscribe","stream":"user"}|});%lwt
- let%lwt _ = post `Waq ~token:waq_token () in
- Lwt_unix.sleep 5.0);%lwt
+ if not use_query_param then (
+ pushf (Some {|{"type":"unsubscribe","stream":"user"}|});
+ let _ = post env `Waq ~token:waq_token () in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 5.0);
- pushf None;%lwt
- Lwt.return `End );
+ pushf None;
+ `End );
(`End, fun _ -> assert false);
]
()
@@ -39,17 +39,16 @@ open struct
in
let expected_uri = ref None in
- let mtx = Lwt_mutex.create () in
- websocket ~mtx `Waq ~target ~token:waq_token handler (fun pushf ->
- if%lwt Lwt.return (not use_query_param) then
- pushf (Some {|{"type":"subscribe","stream":"user"}|});%lwt
- let%lwt { uri; _ } = post `Waq ~token:waq_token () in
+ let mtx = Eio.Mutex.create () in
+ websocket env ~mtx `Waq ~target ~token:waq_token handler (fun pushf ->
+ if not use_query_param then
+ pushf (Some {|{"type":"subscribe","stream":"user"}|});
+ let { uri; _ } = post env `Waq ~token:waq_token () in
expected_uri := Some uri;
- set_current_state `Recv;
- Lwt.return_unit);%lwt
+ set_current_state `Recv);
assert (Option.get !got_uri = Option.get !expected_uri);
- Lwt.return_unit
+ ()
end
let f1 = f ~use_query_param:true
diff --git a/e2e/src/waq_3.ml b/e2e/src/waq_3.ml
index bb88f31..dc06645 100644
--- a/e2e/src/waq_3.ml
+++ b/e2e/src/waq_3.ml
@@ -1,78 +1,78 @@
open Common
let f =
- make_waq_scenario @@ fun waq_token ->
- let%lwt waq_token' = fetch_access_token ~username:"user2" in
- let%lwt user1_id, _, _ = lookup `Waq ~token:waq_token ~username:"user1" () in
- let%lwt user2_id, _, _ = lookup `Waq ~token:waq_token ~username:"user2" () in
+ make_waq_scenario @@ fun env waq_token ->
+ let waq_token' = fetch_access_token env ~username:"user2" in
+ let user1_id, _, _ = lookup env `Waq ~token:waq_token ~username:"user1" () in
+ let user2_id, _, _ = lookup env `Waq ~token:waq_token ~username:"user2" () in
(* Follow @user2 *)
- follow `Waq ~token:waq_token user2_id;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ follow env `Waq ~token:waq_token user2_id;
+ Eio.Time.sleep env#clock 1.0;
(* Post by @user2 *)
- let%lwt { uri; id; _ } = post `Waq ~token:waq_token' () in
+ let { uri; id; _ } = post env `Waq ~token:waq_token' () in
(* check accounts *)
- let%lwt a = get_account `Waq user2_id in
+ let a = get_account env `Waq user2_id in
assert (a.statuses_count = 1);
(* Reply by me *)
- let%lwt { uri = uri2; id = id2; _ } =
- post `Waq ~token:waq_token ~in_reply_to_id:id ()
+ let { uri = uri2; id = id2; _ } =
+ post env `Waq ~token:waq_token ~in_reply_to_id:id ()
in
(* check accounts *)
- let%lwt a = get_account `Waq user1_id in
+ let a = get_account env `Waq user1_id in
assert (a.statuses_count = 1);
(* Reply again *)
- let%lwt { uri = uri3; _ } =
- post `Waq ~token:waq_token ~in_reply_to_id:id2 ()
+ let { uri = uri3; _ } =
+ post env `Waq ~token:waq_token ~in_reply_to_id:id2 ()
in
(* Get my home timeline and check *)
- (home_timeline `Waq ~token:waq_token >|= function
- | [ `Assoc l3; `Assoc l2; `Assoc l ] ->
- (* Check if the timeline is correct *)
- assert (uri = (l |> List.assoc "uri" |> expect_string));
- assert (id = (l2 |> List.assoc "in_reply_to_id" |> expect_string));
- assert (uri2 = (l2 |> List.assoc "uri" |> expect_string));
- assert (id2 = (l3 |> List.assoc "in_reply_to_id" |> expect_string));
- assert (uri3 = (l3 |> List.assoc "uri" |> expect_string));
- ()
- | _ -> assert false);%lwt
+ (match home_timeline env `Waq ~token:waq_token with
+ | [ `Assoc l3; `Assoc l2; `Assoc l ] ->
+ (* Check if the timeline is correct *)
+ assert (uri = (l |> List.assoc "uri" |> expect_string));
+ assert (id = (l2 |> List.assoc "in_reply_to_id" |> expect_string));
+ assert (uri2 = (l2 |> List.assoc "uri" |> expect_string));
+ assert (id2 = (l3 |> List.assoc "in_reply_to_id" |> expect_string));
+ assert (uri3 = (l3 |> List.assoc "uri" |> expect_string));
+ ()
+ | _ -> assert false);
(* Unfollow @user2 *)
- unfollow `Waq ~token:waq_token user2_id;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ unfollow env `Waq ~token:waq_token user2_id;
+ Eio.Time.sleep env#clock 1.0;
(* Get my home timeline and check again *)
- (home_timeline `Waq ~token:waq_token >|= function
- | [ `Assoc l3; `Assoc l2 ] ->
- (* Check if the timeline is correct *)
- assert (uri2 = (l2 |> List.assoc "uri" |> expect_string));
- assert (uri3 = (l3 |> List.assoc "uri" |> expect_string));
- ()
- | _ -> assert false);%lwt
+ (match home_timeline env `Waq ~token:waq_token with
+ | [ `Assoc l3; `Assoc l2 ] ->
+ (* Check if the timeline is correct *)
+ assert (uri2 = (l2 |> List.assoc "uri" |> expect_string));
+ assert (uri3 = (l3 |> List.assoc "uri" |> expect_string));
+ ()
+ | _ -> assert false);
(* Check status itself *)
- let%lwt s = get_status `Waq id in
+ let s = get_status env `Waq id in
assert (s.uri = uri);
(* Check the status's context *)
- let%lwt ancestors, descendants = get_status_context `Waq id2 in
+ let ancestors, descendants = get_status_context env `Waq id2 in
assert (ancestors |> List.map (fun r -> r.uri) = [ uri ]);
assert (descendants |> List.map (fun r -> r.uri) = [ uri3 ]);
(* Check account's statuses *)
- let%lwt statuses = get_account_statuses `Waq user1_id in
+ let statuses = get_account_statuses env `Waq user1_id in
assert ([ uri3; uri2 ] = (statuses |> List.map (fun s -> s.uri)));
- let%lwt statuses = get_account_statuses `Waq ~exclude_replies:true user1_id in
+ let statuses = get_account_statuses env `Waq ~exclude_replies:true user1_id in
assert (statuses = []);
- let%lwt statuses = get_account_statuses `Waq user2_id in
+ let statuses = get_account_statuses env `Waq user2_id in
assert ([ uri ] = (statuses |> List.map (fun s -> s.uri)));
- let%lwt statuses = get_account_statuses `Waq ~exclude_replies:true user2_id in
+ let statuses = get_account_statuses env `Waq ~exclude_replies:true user2_id in
assert ([ uri ] = (statuses |> List.map (fun s -> s.uri)));
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_4_reblog.ml b/e2e/src/waq_4_reblog.ml
index 8f44127..daed2a6 100644
--- a/e2e/src/waq_4_reblog.ml
+++ b/e2e/src/waq_4_reblog.ml
@@ -1,40 +1,41 @@
open Common
let f =
- make_waq_scenario @@ fun token ->
+ make_waq_scenario @@ fun env 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" ()
+ let ws_recv_msgs =
+ websocket_stack env `Waq ~token @@ fun _pushf ->
+ let { id = id1; reblog = None; reblogged = false; reblogs_count = 0; _ } =
+ post env `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
+ let {
+ id = id2;
+ reblogged = true;
+ reblog = Some { id = id1'; reblogged = true; reblog = None; _ };
+ _;
+ } =
+ reblog env `Waq ~token ~id:id1
in
- let%lwt { id = id2'; reblog = Some { id = id1''; _ }; _ } =
- reblog `Waq ~token ~id:id1
+ let { id = id2'; reblog = Some { id = id1''; _ }; _ } =
+ reblog env `Waq ~token ~id:id1
in
- let%lwt { id = id2''; reblog = Some { id = id1'''; _ }; _ } =
- reblog `Waq ~token ~id:id2
+ let { id = id2''; reblog = Some { id = id1'''; _ }; _ } =
+ reblog env `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
+ let { reblogs_count; _ } = get_status env `Waq ~token id1 in
assert (reblogs_count = 1);
- Lwt.return_unit
+ ()
+ [@@warning "-8"]
in
let ws_recv_msgs =
- ws_recv_msgs |> List.map (Yojson.Safe.from_string |.> expect_assoc)
+ ws_recv_msgs
+ |> List.map (fun x -> x |> Yojson.Safe.from_string |> expect_assoc)
in
let ws_recv_ids, ws_recv_notfs =
ws_recv_msgs
@@ -57,5 +58,4 @@ let f =
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_5_fav.ml b/e2e/src/waq_5_fav.ml
index fb1ed3d..2ad7496 100644
--- a/e2e/src/waq_5_fav.ml
+++ b/e2e/src/waq_5_fav.ml
@@ -1,23 +1,23 @@
open Common
let f =
- make_waq_scenario @@ fun token ->
- let%lwt user1_id, _, _ = lookup `Waq ~token ~username:"user1" () in
- let%lwt user2_id, _, _ = lookup `Waq ~token ~username:"user2" () in
- let%lwt user3_id, _, _ = lookup `Waq ~token ~username:"user3" () in
- let%lwt token2 = fetch_access_token ~username:"user2" in
- let%lwt token3 = fetch_access_token ~username:"user3" in
+ make_waq_scenario @@ fun env token ->
+ let user1_id, _, _ = lookup env `Waq ~token ~username:"user1" () in
+ let user2_id, _, _ = lookup env `Waq ~token ~username:"user2" () in
+ let user3_id, _, _ = lookup env `Waq ~token ~username:"user3" () in
+ let token2 = fetch_access_token env ~username:"user2" in
+ let token3 = fetch_access_token env ~username:"user3" in
- let%lwt { id; _ } = post `Waq ~token () in
- let%lwt { favourited; _ } = fav `Waq ~token ~id in
+ let ({ id; _ } : status) = post env `Waq ~token () in
+ let { favourited; _ } = fav env `Waq ~token ~id in
assert favourited;
- let%lwt { favourited; _ } = fav `Waq ~token:token2 ~id in
+ let { favourited; _ } = fav env `Waq ~token:token2 ~id in
assert favourited;
- let%lwt { favourited; favourites_count; _ } = fav `Waq ~token:token3 ~id in
+ let { favourited; favourites_count; _ } = fav env `Waq ~token:token3 ~id in
assert favourited;
assert (favourites_count = 3);
- let%lwt l = get_favourited_by `Waq ~token ~id in
+ let l = get_favourited_by env `Waq ~token ~id in
assert (List.length l = 3);
assert (
l |> List.find_opt (fun (a : account) -> a.id = user1_id) |> Option.is_some);
@@ -26,7 +26,7 @@ let f =
assert (
l |> List.find_opt (fun (a : account) -> a.id = user3_id) |> Option.is_some);
- (match%lwt get_notifications `Waq ~token with
+ (match get_notifications env `Waq ~token with
| [
{
typ = "favourite";
@@ -44,24 +44,21 @@ let f =
assert (account_id3 = user3_id);
assert (account_id2 = user2_id);
assert (status_id3 = id);
- assert (status_id2 = id);
- Lwt.return_unit
- | _ -> assert false);%lwt
+ assert (status_id2 = id)
+ | _ -> assert false);
- let%lwt { favourited; _ } = unfav `Waq ~token ~id in
+ let { favourited; _ } = unfav env `Waq ~token ~id in
assert (not favourited);
- let%lwt { favourited; _ } = unfav `Waq ~token:token2 ~id in
+ let { favourited; _ } = unfav env `Waq ~token:token2 ~id in
assert (not favourited);
- let%lwt { favourited; favourites_count; _ } = unfav `Waq ~token:token3 ~id in
+ let { favourited; favourites_count; _ } = unfav env `Waq ~token:token3 ~id in
assert (not favourited);
assert (favourites_count = 0);
- (match%lwt get_favourited_by `Waq ~token ~id with
- | [] -> Lwt.return_unit
- | _ -> assert false);%lwt
+ (match get_favourited_by env `Waq ~token ~id with
+ | [] -> ()
+ | _ -> assert false);
- (match%lwt get_notifications `Waq ~token with
- | [] -> Lwt.return_unit
- | _ -> assert false);%lwt
+ (match get_notifications env `Waq ~token with [] -> () | _ -> assert false);
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_6_rel.ml b/e2e/src/waq_6_rel.ml
index 03ef7f5..5db31ee 100644
--- a/e2e/src/waq_6_rel.ml
+++ b/e2e/src/waq_6_rel.ml
@@ -1,143 +1,142 @@
open Common
-let expect_followers account_id expected_follower_ids =
- let%lwt l = get_followers `Waq account_id in
+let expect_followers env account_id expected_follower_ids =
+ let l = get_followers env `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 expect_following env account_id expected_follower_ids =
+ let l = get_following env `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 ->
+ make_waq_scenario @@ fun env 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
+ let ws_recv_msgs =
+ websocket_stack env `Waq ~token @@ fun _pushf ->
+ let token' = fetch_access_token env ~username:"user2" in
+ let user1_id, _, _ = lookup env `Waq ~token:token' ~username:"user1" () in
+ let user2_id, _, _ = lookup env `Waq ~token ~username:"user2" () in
+ let user3_id, _, _ = lookup env `Waq ~token ~username:"user3" () in
(* user1: Try to follow myself, which should be forbidden *)
- (try%lwt
- follow `Waq ~token user1_id;%lwt
+ (try
+ follow env `Waq ~token user1_id;
assert false
- with Httpq.Client.FetchFailure (Some (`Forbidden, _, _)) ->
- Lwt.return_unit);%lwt
+ with FetchFailure (Some (`Forbidden, _, _)) -> ());
(* user1: Follow @user2 *)
- follow `Waq ~token user2_id;%lwt
- expect_followers user2_id [ user1_id ];%lwt
- expect_following user1_id [ user2_id ];%lwt
+ follow env `Waq ~token user2_id;
+ expect_followers env user2_id [ user1_id ];
+ expect_following env user1_id [ user2_id ];
(* user1: check relationship *)
- (match%lwt get_relationships `Waq ~token [ user2_id; user3_id ] with
+ (match get_relationships env `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
+ ()
+ | _ -> assert false);
(* check accounts *)
- let%lwt a = get_account `Waq user1_id in
+ let a = get_account env `Waq user1_id in
assert (a.followers_count = 0);
assert (a.following_count = 1);
- let%lwt a = get_account `Waq user2_id in
+ let a = get_account env `Waq user2_id in
assert (a.followers_count = 1);
assert (a.following_count = 0);
(* check notifications *)
- (match%lwt get_notifications `Waq ~token:token' with
+ (match get_notifications env `Waq ~token:token' with
| [ { typ = "follow"; account = a; _ } ] ->
assert (a.id = user1_id);
- Lwt.return_unit
- | _ -> assert false);%lwt
+ ()
+ | _ -> assert false);
(* user2: follow @user1 *)
- follow `Waq ~token:token' user1_id;%lwt
- expect_followers user1_id [ user2_id ];%lwt
- expect_following user2_id [ user1_id ];%lwt
+ follow env `Waq ~token:token' user1_id;
+ expect_followers env user1_id [ user2_id ];
+ expect_following env user2_id [ user1_id ];
(* user1: check relationship *)
- (match%lwt get_relationships `Waq ~token [ user2_id ] with
+ (match get_relationships env `Waq ~token [ user2_id ] with
| [ rel ] ->
assert (rel.id = user2_id);
assert rel.following;
assert rel.followed_by;
- Lwt.return_unit
- | _ -> assert false);%lwt
+ ()
+ | _ -> assert false);
(* check accounts *)
- let%lwt a = get_account `Waq user1_id in
+ let a = get_account env `Waq user1_id in
assert (a.followers_count = 1);
assert (a.following_count = 1);
- let%lwt a = get_account `Waq user2_id in
+ let a = get_account env `Waq user2_id in
assert (a.followers_count = 1);
assert (a.following_count = 1);
(* check notifications *)
- (match%lwt get_notifications `Waq ~token with
+ (match get_notifications env `Waq ~token with
| [ { typ = "follow"; account = a; _ } ] ->
assert (a.id = user2_id);
- Lwt.return_unit
- | _ -> assert false);%lwt
+ ()
+ | _ -> assert false);
(* user1: Unfollow @user2 *)
- unfollow `Waq ~token user2_id;%lwt
- expect_followers user2_id [];%lwt
- expect_following user1_id [];%lwt
+ unfollow env `Waq ~token user2_id;
+ expect_followers env user2_id [];
+ expect_following env user1_id [];
(* user1: check relationship *)
- (match%lwt get_relationships `Waq ~token [ user2_id ] with
+ (match get_relationships env `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
+ ()
+ | _ -> assert false);
(* check accounts *)
- let%lwt a = get_account `Waq user1_id in
+ let a = get_account env `Waq user1_id in
assert (a.followers_count = 1);
assert (a.following_count = 0);
- let%lwt a = get_account `Waq user2_id in
+ let a = get_account env `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
+ unfollow env `Waq ~token:token' user1_id;
+ expect_followers env user1_id [];
+ expect_following env user2_id [];
(* user1: check relationship *)
- (match%lwt get_relationships `Waq ~token [ user2_id ] with
+ (match get_relationships env `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
+ ()
+ | _ -> assert false);
(* check accounts *)
- let%lwt a = get_account `Waq user1_id in
+ let a = get_account env `Waq user1_id in
assert (a.followers_count = 0);
assert (a.following_count = 0);
- let%lwt a = get_account `Waq user2_id in
+ let a = get_account env `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.map (fun x -> x |> Yojson.Safe.from_string |> expect_assoc)
|> List.filter_map (fun (l : (string * Yojson.Safe.t) list) ->
if
List.assoc "stream" l = `List [ `String "user" ]
@@ -148,11 +147,11 @@ let f =
|> Yojson.Safe.from_string |> notification_of_yojson)
else None)
in
- let%lwt got_notifications = get_notifications `Waq ~token in
+ let got_notifications = get_notifications env `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_7_reblog.ml b/e2e/src/waq_7_reblog.ml
index 22325c2..3cbd34f 100644
--- a/e2e/src/waq_7_reblog.ml
+++ b/e2e/src/waq_7_reblog.ml
@@ -1,15 +1,15 @@
open Common
let f =
- make_waq_scenario @@ fun token ->
- let%lwt user2_id, _, _ = lookup `Waq ~token ~username:"user2" () in
- let%lwt token2 = fetch_access_token ~username:"user2" in
- let%lwt token3 = fetch_access_token ~username:"user3" in
- let%lwt { id; _ } = post `Waq ~token () in
- let%lwt _ = reblog `Waq ~token ~id in
- let%lwt _ = reblog `Waq ~token:token2 ~id in
+ make_waq_scenario @@ fun env token ->
+ let user2_id, _, _ = lookup env `Waq ~token ~username:"user2" () in
+ let token2 = fetch_access_token env ~username:"user2" in
+ let token3 = fetch_access_token env ~username:"user3" in
+ let ({ id; _ } : status) = post env `Waq ~token () in
+ let _ = reblog env `Waq ~token ~id in
+ let _ = reblog env `Waq ~token:token2 ~id in
- let%lwt ntfs = get_notifications `Waq ~token in
+ let ntfs = get_notifications env `Waq ~token in
(match ntfs with
| [
{
@@ -22,26 +22,26 @@ let f =
assert (account_id2 = user2_id);
assert (status_id2 = id);
assert (reblogs_count = 2);
- Lwt.return_unit
- | _ -> assert false);%lwt
+ ()
+ | _ -> assert false);
(* Wrong unreblog *)
- expect_exc_lwt (fun () -> unreblog `Waq ~token:token3 ~id);%lwt
- let%lwt { reblogs_count; _ } = get_status `Waq ~token id in
+ expect_exc (fun () -> unreblog env `Waq ~token:token3 ~id);
+ let { reblogs_count; _ } = get_status env `Waq ~token id in
assert (reblogs_count = 2);
(* Actual unreblogs *)
- let%lwt { id = unreblog_id; reblogs_count; reblogged; _ } =
- unreblog `Waq ~token:token2 ~id
+ let { id = unreblog_id; reblogs_count; reblogged; _ } =
+ unreblog env `Waq ~token:token2 ~id
in
assert (unreblog_id = id);
assert (reblogs_count = 1);
assert (not reblogged);
- let%lwt { id = unreblog_id; reblogs_count; reblogged; _ } =
- unreblog `Waq ~token ~id
+ let { id = unreblog_id; reblogs_count; reblogged; _ } =
+ unreblog env `Waq ~token ~id
in
assert (unreblog_id = id);
assert (reblogs_count = 0);
assert (not reblogged);
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_8_delete.ml b/e2e/src/waq_8_delete.ml
index 1134114..5bf0351 100644
--- a/e2e/src/waq_8_delete.ml
+++ b/e2e/src/waq_8_delete.ml
@@ -1,41 +1,41 @@
open Common
-let expect_no_status kind id =
- try%lwt
- get_status kind id |> ignore_lwt;%lwt
+let expect_no_status env kind id =
+ try
+ get_status env kind id |> ignore;
assert false
- with Httpq.Client.FetchFailure (Some (`Not_found, _, _)) -> Lwt.return_unit
+ with FetchFailure (Some (`Not_found, _, _)) -> ()
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
+ make_waq_scenario @@ fun env token ->
+ let token' = fetch_access_token env ~username:"user2" in
+ let ws_recv_msgs =
+ websocket_stack env `Waq ~token @@ fun _pushf ->
+ let ({ id; _ } : status) = post env `Waq ~token () in
+ let s = get_status env `Waq id in
assert (s.id = id);
(* Wrong delete *)
- expect_exc_lwt (fun () -> delete_status `Waq ~token:token' id);%lwt
+ expect_exc (fun () -> delete_status env `Waq ~token:token' id);
(* Should remain *)
- get_status `Waq id |> ignore_lwt;%lwt
+ get_status env `Waq id |> ignore;
(* Actual delete *)
- let%lwt s = delete_status `Waq ~token id in
+ let s = delete_status env `Waq ~token id in
assert (s.id = id);
- expect_no_status `Waq id;%lwt
+ expect_no_status env `Waq id;
- 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
+ let ({ id; _ } : status) = post env `Waq ~token () in
+ let s = reblog env `Waq ~token ~id in
+ delete_status env `Waq ~token id |> ignore;
+ expect_no_status env `Waq id;
+ expect_no_status env `Waq s.id;
- Lwt.return_unit
+ ()
in
let ws_delete_events =
ws_recv_msgs
- |> List.map (Yojson.Safe.from_string |.> expect_assoc)
+ |> List.map (fun x -> x |> Yojson.Safe.from_string |> expect_assoc)
|> List.filter_map (fun (l : (string * Yojson.Safe.t) list) ->
if
List.assoc "stream" l = `List [ `String "user" ]
@@ -46,4 +46,4 @@ let f =
assert (
List.sort compare ws_delete_events = List.sort compare [ "1"; "2"; "3" ]);
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_9_ap.ml b/e2e/src/waq_9_ap.ml
index 0ac8d30..ba9003a 100644
--- a/e2e/src/waq_9_ap.ml
+++ b/e2e/src/waq_9_ap.ml
@@ -1,8 +1,8 @@
open Common
let f =
- make_waq_scenario @@ fun _token ->
- let%lwt r = fetch_exn (waq "/users/user1/outbox") in
+ make_waq_scenario @@ fun env _token ->
+ let r = fetch_exn env (waq "/users/user1/outbox") in
let l = Yojson.Safe.from_string r |> expect_assoc in
assert (List.assoc "type" l |> expect_string = "OrderedCollection");
assert (List.assoc "totalItems" l |> expect_int = 0);
@@ -12,18 +12,18 @@ let f =
List.assoc "last" l |> expect_string
= waq "/users/user1/outbox?min_id=0&page=true");
- let%lwt r = fetch_exn (waq "/users/user1/following") in
+ let r = fetch_exn env (waq "/users/user1/following") in
let l = Yojson.Safe.from_string r |> expect_assoc in
assert (List.assoc "type" l |> expect_string = "OrderedCollection");
assert (List.assoc "totalItems" l |> expect_int = 0);
assert (
List.assoc "first" l |> expect_string = waq "/users/user1/following?page=1");
- let%lwt r = fetch_exn (waq "/users/user1/followers") in
+ let r = fetch_exn env (waq "/users/user1/followers") in
let l = Yojson.Safe.from_string r |> expect_assoc in
assert (List.assoc "type" l |> expect_string = "OrderedCollection");
assert (List.assoc "totalItems" l |> expect_int = 0);
assert (
List.assoc "first" l |> expect_string = waq "/users/user1/followers?page=1");
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_mstdn_1.ml b/e2e/src/waq_mstdn_1.ml
index 2017c5c..7765097 100644
--- a/e2e/src/waq_mstdn_1.ml
+++ b/e2e/src/waq_mstdn_1.ml
@@ -1,7 +1,7 @@
open Common
let f =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
(* Connect WebSocket *)
let ws_statuses = ref [] in
let _set_current_state, handler =
@@ -16,36 +16,36 @@ let f =
ws_statuses :=
(Yojson.Safe.from_string payload |> expect_assoc)
:: !ws_statuses;
- Lwt.return `Recv );
+ `Recv );
]
()
in
let uris = ref [] in
- websocket `Waq ~token:waq_token handler (fun pushf ->
+ websocket env `Waq ~token:waq_token handler (fun pushf ->
(* Lookup @mstdn1@mstdn_server_domain *)
- let%lwt mstdn1_id, username, acct =
- lookup `Waq ~token:waq_token ~username:"mstdn1"
+ let mstdn1_id, username, acct =
+ lookup env `Waq ~token:waq_token ~username:"mstdn1"
~domain:mstdn_server_domain ()
in
assert (username = "mstdn1");
assert (acct = "mstdn1@" ^ mstdn_server_domain);
(* Follow @mstdn1@mstdn_server_domain *)
- follow `Waq ~token:waq_token mstdn1_id;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ follow env `Waq ~token:waq_token mstdn1_id;
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Post by @mstdn1@mstdn_server_domain *)
- let%lwt { uri; _ } = post `Mstdn ~token:mstdn_token () in
+ let ({ uri; _ } : status) = post env `Mstdn ~token:mstdn_token () in
uris := uri :: !uris;
- Lwt_unix.sleep 1.0;%lwt
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Post by me *)
- let%lwt { uri = uri2; _ } = post `Waq ~token:waq_token () in
+ let ({ uri = uri2; _ } : status) = post env `Waq ~token:waq_token () in
uris := uri2 :: !uris;
- Lwt_unix.sleep 1.0;%lwt
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Get my home timeline and check *)
- (home_timeline `Waq ~token:waq_token >|= function
+ (home_timeline env `Waq ~token:waq_token |> function
| [ `Assoc l2; `Assoc l ] ->
(* Check if the timeline is correct *)
assert (uri = (l |> List.assoc "uri" |> expect_string));
@@ -55,21 +55,21 @@ let f =
Logq.err (fun m ->
m "unexpected home timeline %s"
(Yojson.Safe.to_string (`List res)));
- assert false);%lwt
+ assert false);
(* Unfollow @mstdn1@mstdn_server_domain *)
- unfollow `Waq ~token:waq_token mstdn1_id;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ unfollow env `Waq ~token:waq_token mstdn1_id;
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Get my home timeline and check again *)
- (home_timeline `Waq ~token:waq_token >|= function
+ (home_timeline env `Waq ~token:waq_token |> function
| [ `Assoc l2 ] ->
(* Check if the timeline is correct *)
assert (uri2 = (l2 |> List.assoc "uri" |> expect_string));
()
- | _ -> assert false);%lwt
+ | _ -> assert false);
- pushf None);%lwt
+ pushf None);
let expected_uris = List.sort compare !uris in
let got_uris =
@@ -79,4 +79,4 @@ let f =
in
assert (expected_uris = got_uris);
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_mstdn_10_attachment.ml b/e2e/src/waq_mstdn_10_attachment.ml
index 478b2ac..a8f79f7 100644
--- a/e2e/src/waq_mstdn_10_attachment.ml
+++ b/e2e/src/waq_mstdn_10_attachment.ml
@@ -1,33 +1,31 @@
open Common2
-let f (a0 : agent) (a1 : agent) =
+let f env (a0 : agent) (a1 : agent) =
(* a0: Follow a1 *)
- follow_agent a0 a1;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ follow_agent env a0 a1;
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* a1: Post with attachments *)
- let%lwt { id = media_id; _ } =
- upload_media a1 ~filename:"test0.png" ~data:test_image
+ let ({ id = media_id; _ } : media_attachment) =
+ upload_media env a1 ~filename:"test0.png" ~data:test_image
~content_type:"image/png"
in
- let%lwt { id = media_id2; _ } =
- upload_media a1 ~filename:"test1.png" ~data:test_image
+ let ({ id = media_id2; _ } : media_attachment) =
+ upload_media env a1 ~filename:"test1.png" ~data:test_image
~content_type:"image/png"
in
- let%lwt { uri; media_attachments; _ } =
- post a1 ~media_ids:[ media_id; media_id2 ] ()
+ let { uri; media_attachments; _ } =
+ post env a1 ~media_ids:[ media_id; media_id2 ] ()
in
assert (
media_attachments
|> List.map (fun (a : media_attachment) -> a.id)
= [ media_id; media_id2 ]);
- Lwt_unix.sleep 1.0;%lwt
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* a0: Get the post *)
- let%lwt a0_post =
- match%lwt search a0 uri with
- | _, [ s ], _ -> Lwt.return s
- | _ -> assert false
+ let a0_post =
+ match search env a0 uri with _, [ s ], _ -> s | _ -> assert false
in
(* a0: Check the post *)
@@ -35,10 +33,10 @@ let f (a0 : agent) (a1 : agent) =
assert (List.length ats = 2);
assert (ats |> List.for_all (fun (a : media_attachment) -> a.type_ = "image"));
- Lwt.return_unit
+ ()
let f_waq_mstdn =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
let a0 =
make_agent ~kind:`Waq ~token:waq_token ~username:"user1"
~domain:waq_server_domain
@@ -47,11 +45,11 @@ let f_waq_mstdn =
make_agent ~kind:`Mstdn ~token:mstdn_token ~username:"mstdn1"
~domain:mstdn_server_domain
in
- f a0 a1;%lwt
- Lwt.return_unit
+ f env a0 a1;
+ ()
let f_mstdn_waq =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
let a0 =
make_agent ~kind:`Mstdn ~token:mstdn_token ~username:"mstdn1"
~domain:mstdn_server_domain
@@ -60,12 +58,12 @@ let f_mstdn_waq =
make_agent ~kind:`Waq ~token:waq_token ~username:"user1"
~domain:waq_server_domain
in
- f a0 a1;%lwt
- Lwt.return_unit
+ f env a0 a1;
+ ()
let f_waq_waq =
- make_waq_scenario @@ fun token ->
- let%lwt token2 = fetch_access_token ~username:"user2" in
+ make_waq_scenario @@ fun env token ->
+ let token2 = fetch_access_token env ~username:"user2" in
let a0 =
make_agent ~kind:`Waq ~token ~username:"user1" ~domain:waq_server_domain
in
@@ -73,4 +71,4 @@ let f_waq_waq =
make_agent ~kind:`Waq ~token:token2 ~username:"user2"
~domain:waq_server_domain
in
- f a0 a1
+ f env a0 a1
diff --git a/e2e/src/waq_mstdn_11_mention.ml b/e2e/src/waq_mstdn_11_mention.ml
index a6584ad..52c6ffb 100644
--- a/e2e/src/waq_mstdn_11_mention.ml
+++ b/e2e/src/waq_mstdn_11_mention.ml
@@ -1,65 +1,65 @@
open Common2
-let f (a0 : agent) (a1 : agent) (a2 : agent) =
+let f env (a0 : agent) (a1 : agent) (a2 : agent) =
(* a0: Post with mentions *)
- let%lwt { uri; _ } =
- post a0
+ let { uri; _ } =
+ post env a0
~content:
(Printf.sprintf "@%s @%s てすと"
(acct_of_agent ~from:a0 a1)
(acct_of_agent ~from:a0 a2))
()
in
- Lwt_unix.sleep 10.0;%lwt
+ Eio.Time.sleep (Eio.Stdenv.clock env) 10.0;
(* a1: Check home timeline, which should be empty *)
- let%lwt [] = home_timeline a1 in
+ let [] = home_timeline env a1 in
(* a2: Check home timeline, which should be empty *)
- let%lwt [] = home_timeline a2 in
+ let [] = home_timeline env a2 in
(* a1: Check its notification *)
- let%lwt [ n ] =
- get_notifications a1
- >|= List.filter (fun (n : notification) -> n.typ = "mention")
+ let [ n ] =
+ get_notifications env a1
+ |> List.filter (fun (n : notification) -> n.typ = "mention")
in
assert ((Option.get n.status).uri = uri);
assert (n.account.acct = acct_of_agent ~from:a1 a0);
assert (List.length (Option.get n.status).mentions = 2);
(* a2: Check its notification *)
- let%lwt [ n ] = get_notifications a2 in
+ let [ n ] = get_notifications env a2 in
assert ((Option.get n.status).uri = uri);
assert (n.account.acct = acct_of_agent ~from:a2 a0);
assert (List.length (Option.get n.status).mentions = 2);
- Lwt.return_unit
+ ()
[@@warning "-8"]
let f_waq_mstdn_waq () =
- launch_waq_and_mstdn @@ fun ctxt ->
+ launch_waq_and_mstdn @@ fun env ctxt ->
let a0 = generate_waq_agent ctxt in
let a1 = generate_mstdn_agent ctxt in
let a2 = generate_waq_agent ctxt in
- f a0 a1 a2
+ f env a0 a1 a2
let f_mstdn_waq_waq () =
- launch_waq_and_mstdn @@ fun ctxt ->
+ launch_waq_and_mstdn @@ fun env ctxt ->
let a0 = generate_mstdn_agent ctxt in
let a1 = generate_waq_agent ctxt in
let a2 = generate_waq_agent ctxt in
- f a0 a1 a2
+ f env a0 a1 a2
let f_waq_waq_waq () =
- launch_waq @@ fun ctxt ->
+ launch_waq @@ fun env ctxt ->
let a0 = generate_waq_agent ctxt in
let a1 = generate_waq_agent ctxt in
let a2 = generate_waq_agent ctxt in
- f a0 a1 a2
+ f env a0 a1 a2
let f_mstdn_waq_mstdn () =
- launch_waq_and_mstdn @@ fun ctxt ->
+ launch_waq_and_mstdn @@ fun env ctxt ->
let a0 = generate_mstdn_agent ctxt in
let a1 = generate_waq_agent ctxt in
let a2 = generate_mstdn_agent ctxt in
- f a0 a1 a2
+ f env a0 a1 a2
diff --git a/e2e/src/waq_mstdn_12_summary.ml b/e2e/src/waq_mstdn_12_summary.ml
index f4c9673..179faa1 100644
--- a/e2e/src/waq_mstdn_12_summary.ml
+++ b/e2e/src/waq_mstdn_12_summary.ml
@@ -1,20 +1,20 @@
open Common2
-let f (a0 : agent) (a1 : agent) =
+let f env (a0 : agent) (a1 : agent) =
let spoiler_text = "すぽいらーてきすと" in
(* a0: Post with summary (spoiler_text) *)
- let%lwt { uri; _ } = post a0 ~spoiler_text () in
+ let { uri; _ } = post env a0 ~spoiler_text () in
(* a1: Check the post by lookup *)
- let%lwt _, [ s ], _ = search a1 uri in
+ let _, [ s ], _ = search env a1 uri in
assert (s.spoiler_text = spoiler_text);
- Lwt.return_unit
+ ()
[@@warning "-8"]
let f_mstdn_waq =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
let a0 =
make_agent ~kind:`Mstdn ~token:mstdn_token ~username:"mstdn1"
~domain:mstdn_server_domain
@@ -23,11 +23,11 @@ let f_mstdn_waq =
make_agent ~kind:`Waq ~token:waq_token ~username:"user1"
~domain:waq_server_domain
in
- f a0 a1;%lwt
- Lwt.return_unit
+ f env a0 a1;
+ ()
let f_waq_mstdn =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
let a0 =
make_agent ~kind:`Waq ~token:waq_token ~username:"user1"
~domain:waq_server_domain
@@ -36,12 +36,12 @@ let f_waq_mstdn =
make_agent ~kind:`Mstdn ~token:mstdn_token ~username:"mstdn1"
~domain:mstdn_server_domain
in
- f a0 a1;%lwt
- Lwt.return_unit
+ f env a0 a1;
+ ()
let f_waq_waq =
- make_waq_scenario @@ fun token ->
- let%lwt token2 = fetch_access_token ~username:"user2" in
+ make_waq_scenario @@ fun env token ->
+ let token2 = fetch_access_token env ~username:"user2" in
let a0 =
make_agent ~kind:`Waq ~token ~username:"user1" ~domain:waq_server_domain
in
@@ -49,5 +49,5 @@ let f_waq_waq =
make_agent ~kind:`Waq ~token:token2 ~username:"user2"
~domain:waq_server_domain
in
- f a0 a1;%lwt
- Lwt.return_unit
+ f env a0 a1;
+ ()
diff --git a/e2e/src/waq_mstdn_13_v2_search.ml b/e2e/src/waq_mstdn_13_v2_search.ml
index ecb950a..461c74b 100644
--- a/e2e/src/waq_mstdn_13_v2_search.ml
+++ b/e2e/src/waq_mstdn_13_v2_search.ml
@@ -1,24 +1,24 @@
open Common
let f =
- make_waq_and_mstdn_scenario @@ fun waq_token _mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token _mstdn_token ->
(* Lookup @user1 *)
- (match%lwt search `Waq "@user1" with
+ (match search env `Waq "@user1" with
| [ a ], _, _ ->
assert (a.acct = "user1");
- Lwt.return_unit
- | _ -> assert false);%lwt
+ ()
+ | _ -> assert false);
(* Lookup @mstdn1@mstdn_server_domain without token, which should fail *)
- (match%lwt search `Waq ("@mstdn1@" ^ mstdn_server_domain) with
- | [], _, _ -> Lwt.return_unit
- | _ -> assert false);%lwt
+ (match search env `Waq ("@mstdn1@" ^ mstdn_server_domain) with
+ | [], _, _ -> ()
+ | _ -> assert false);
(* With token, it will succeed *)
- (match%lwt
- search `Waq ~token:waq_token ("@mstdn1@" ^ mstdn_server_domain)
+ (match
+ search env `Waq ~token:waq_token ("@mstdn1@" ^ mstdn_server_domain)
with
- | [ _ ], _, _ -> Lwt.return_unit
- | _ -> assert false);%lwt
+ | [ _ ], _, _ -> ()
+ | _ -> assert false);
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_mstdn_14_preview_card.ml b/e2e/src/waq_mstdn_14_preview_card.ml
index 6e2e97c..a0dbc2c 100644
--- a/e2e/src/waq_mstdn_14_preview_card.ml
+++ b/e2e/src/waq_mstdn_14_preview_card.ml
@@ -1,35 +1,35 @@
open Common2
-let get_preview_card_from_a1 (a0 : agent) (a1 : agent) content =
+let get_preview_card_from_a1 env (a0 : agent) (a1 : agent) content =
(* a1: Follow a0 *)
- follow_agent a1 a0;%lwt
+ follow_agent env a1 a0;
(* a0: Post link *)
- let%lwt { uri; _ } = post a0 ~content () in
- Lwt_unix.sleep 2.0;%lwt
+ let { uri; _ } = post env a0 ~content () in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 2.0;
(* a1: Check the post. The post should have been fetched in advance because a1 follows a0. *)
- let%lwt _, [ s ], _ = search a1 uri in
- Lwt.return s
+ let _, [ s ], _ = search env a1 uri in
+ s
[@@warning "-8"]
-let f_case1 (a0 : agent) (a1 : agent) =
+let f_case1 env (a0 : agent) (a1 : agent) =
let url = "https://www.youtube.com/watch?v=OMv_EPMED8Y" in
- let%lwt s = get_preview_card_from_a1 a0 a1 url in
+ let s = get_preview_card_from_a1 env a0 a1 url in
assert (Option.is_some s.card);
let c = Option.get s.card in
assert (c.url = url);
- Lwt.return_unit
+ ()
-let f_case2 (a0 : agent) (a1 : agent) =
+let f_case2 env (a0 : agent) (a1 : agent) =
let content = "@" ^ acct_of_agent ~from:a0 a1 in
- let%lwt s = get_preview_card_from_a1 a0 a1 content in
+ let s = get_preview_card_from_a1 env a0 a1 content in
assert (List.length s.mentions = 1);
assert (Option.is_none s.card);
- Lwt.return_unit
+ ()
let f_mstdn_waq =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
let a0 =
make_agent ~kind:`Mstdn ~token:mstdn_token ~username:"mstdn1"
~domain:mstdn_server_domain
@@ -38,13 +38,13 @@ let f_mstdn_waq =
make_agent ~kind:`Waq ~token:waq_token ~username:"user1"
~domain:waq_server_domain
in
- f_case1 a0 a1;%lwt
- f_case2 a0 a1;%lwt
- Lwt.return_unit
+ f_case1 env a0 a1;
+ f_case2 env a0 a1;
+ ()
let f_waq_waq =
- make_waq_scenario @@ fun token ->
- let%lwt token2 = fetch_access_token ~username:"user2" in
+ make_waq_scenario @@ fun env token ->
+ let token2 = fetch_access_token env ~username:"user2" in
let a0 =
make_agent ~kind:`Waq ~token ~username:"user1" ~domain:waq_server_domain
in
@@ -52,6 +52,6 @@ let f_waq_waq =
make_agent ~kind:`Waq ~token:token2 ~username:"user2"
~domain:waq_server_domain
in
- f_case1 a0 a1;%lwt
- f_case2 a0 a1;%lwt
- Lwt.return_unit
+ f_case1 env a0 a1;
+ f_case2 env a0 a1;
+ ()
diff --git a/e2e/src/waq_mstdn_15_text.ml b/e2e/src/waq_mstdn_15_text.ml
index 97f748c..f20b7f9 100644
--- a/e2e/src/waq_mstdn_15_text.ml
+++ b/e2e/src/waq_mstdn_15_text.ml
@@ -1,24 +1,24 @@
open Common2
-let f (a0 : agent) (a1 : agent) =
+let f env (a0 : agent) (a1 : agent) =
let url = "https://www.youtube.com/watch?v=OMv_EPMED8Y" in
(* a1: Follow a0 *)
- follow_agent a1 a0;%lwt
+ follow_agent env a1 a0;
(* a0: Post link *)
- let%lwt { uri; _ } = post a0 ~content:url () in
- Lwt_unix.sleep 1.0;%lwt
+ let { uri; _ } = post env a0 ~content:url () in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* a1: Check the post. The post should have been fetched in advance because a1 follows a0. *)
- let%lwt _, [ s ], _ = search a1 uri in
+ let _, [ s ], _ = search env a1 uri in
assert (List.length Soup.(parse (Option.get s.content) $$ "a" |> to_list) = 1);
- Lwt.return_unit
+ ()
[@@warning "-8"]
let f_mstdn_waq =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
let a0 =
make_agent ~kind:`Mstdn ~token:mstdn_token ~username:"mstdn1"
~domain:mstdn_server_domain
@@ -27,11 +27,11 @@ let f_mstdn_waq =
make_agent ~kind:`Waq ~token:waq_token ~username:"user1"
~domain:waq_server_domain
in
- f a0 a1;%lwt
- Lwt.return_unit
+ f env a0 a1;
+ ()
let f_waq_mstdn =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
let a0 =
make_agent ~kind:`Waq ~token:waq_token ~username:"user1"
~domain:waq_server_domain
@@ -40,12 +40,12 @@ let f_waq_mstdn =
make_agent ~kind:`Mstdn ~token:mstdn_token ~username:"mstdn1"
~domain:mstdn_server_domain
in
- f a0 a1;%lwt
- Lwt.return_unit
+ f env a0 a1;
+ ()
let f_waq_waq =
- make_waq_scenario @@ fun token ->
- let%lwt token2 = fetch_access_token ~username:"user2" in
+ make_waq_scenario @@ fun env token ->
+ let token2 = fetch_access_token env ~username:"user2" in
let a0 =
make_agent ~kind:`Waq ~token ~username:"user1" ~domain:waq_server_domain
in
@@ -53,5 +53,5 @@ let f_waq_waq =
make_agent ~kind:`Waq ~token:token2 ~username:"user2"
~domain:waq_server_domain
in
- f a0 a1;%lwt
- Lwt.return_unit
+ f env a0 a1;
+ ()
diff --git a/e2e/src/waq_mstdn_16_cred.ml b/e2e/src/waq_mstdn_16_cred.ml
index f21fe15..97d9c37 100644
--- a/e2e/src/waq_mstdn_16_cred.ml
+++ b/e2e/src/waq_mstdn_16_cred.ml
@@ -2,48 +2,48 @@ open Common2
let strip_html_tags s = Soup.(s |> parse |> texts |> String.concat "")
-let f (a0 : agent) (a1 : agent) =
+let f env (a0 : agent) (a1 : agent) =
(* a0: Follow a1 *)
- follow_agent a0 a1;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ follow_agent env a0 a1;
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* a1: Update display name *)
let modified_display_name = "modified display name" in
- let%lwt a = update_credentials a1 ~display_name:modified_display_name () in
+ let a = update_credentials env a1 ~display_name:modified_display_name () in
assert (a.display_name = modified_display_name);
(* a1: Update credentials *)
assert (not a.bot);
- let%lwt old_avatar_url, old_header_url =
- search a0 (acct_of_agent ~from:a0 a1) >|= fun ([ a ], _, _) ->
+ let old_avatar_url, old_header_url =
+ search env a0 (acct_of_agent ~from:a0 a1) |> fun ([ a ], _, _) ->
(a.avatar, a.header)
in
let modified_note = "modified note" in
let modified_avatar = test_image in
let modified_header = test_image in
let modified_bot = true in
- let%lwt a =
- update_credentials a1 ~note:modified_note ~avatar:modified_avatar
+ let a =
+ update_credentials env a1 ~note:modified_note ~avatar:modified_avatar
~header:modified_header ~bot:modified_bot ()
in
assert (a.display_name = modified_display_name);
assert (strip_html_tags a.note = modified_note);
assert a.bot;
- Lwt_unix.sleep 1.0;%lwt
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* a0: Check a1's info *)
- let%lwt [ a ], _, _ = search a0 (acct_of_agent ~from:a0 a1) in
+ let [ a ], _, _ = search env a0 (acct_of_agent ~from:a0 a1) in
assert (a.display_name = modified_display_name);
assert (strip_html_tags a.note = modified_note);
assert (a.avatar <> old_avatar_url);
assert (a.header <> old_header_url);
assert a.bot;
- Lwt.return_unit
+ ()
[@@warning "-8"]
let f_mstdn_waq =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
let a0 =
make_agent ~kind:`Mstdn ~token:mstdn_token ~username:"mstdn1"
~domain:mstdn_server_domain
@@ -52,11 +52,11 @@ let f_mstdn_waq =
make_agent ~kind:`Waq ~token:waq_token ~username:"user1"
~domain:waq_server_domain
in
- f a0 a1;%lwt
- Lwt.return_unit
+ f env a0 a1;
+ ()
let f_waq_mstdn =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
let a0 =
make_agent ~kind:`Waq ~token:waq_token ~username:"user1"
~domain:waq_server_domain
@@ -65,12 +65,12 @@ let f_waq_mstdn =
make_agent ~kind:`Mstdn ~token:mstdn_token ~username:"mstdn1"
~domain:mstdn_server_domain
in
- f a0 a1;%lwt
- Lwt.return_unit
+ f env a0 a1;
+ ()
let f_waq_waq =
- make_waq_scenario @@ fun token ->
- let%lwt token2 = fetch_access_token ~username:"user2" in
+ make_waq_scenario @@ fun env token ->
+ let token2 = fetch_access_token env ~username:"user2" in
let a0 =
make_agent ~kind:`Waq ~token ~username:"user1" ~domain:waq_server_domain
in
@@ -78,5 +78,5 @@ let f_waq_waq =
make_agent ~kind:`Waq ~token:token2 ~username:"user2"
~domain:waq_server_domain
in
- f a0 a1;%lwt
- Lwt.return_unit
+ f env a0 a1;
+ ()
diff --git a/e2e/src/waq_mstdn_2.ml b/e2e/src/waq_mstdn_2.ml
index 3da378f..f6e7ee7 100644
--- a/e2e/src/waq_mstdn_2.ml
+++ b/e2e/src/waq_mstdn_2.ml
@@ -1,55 +1,55 @@
open Common
let f =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
(* Lookup me from mstdn_server_domain *)
- let%lwt aid, _, _ =
- lookup `Mstdn ~token:mstdn_token ~username:"user1" ~domain:waq_server_domain
- ()
+ let aid, _, _ =
+ lookup env `Mstdn ~token:mstdn_token ~username:"user1"
+ ~domain:waq_server_domain ()
in
(* Follow me from @mstdn1@mstdn_server_domain *)
- follow `Mstdn ~token:mstdn_token aid;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ follow env `Mstdn ~token:mstdn_token aid;
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Check notifications *)
- (match%lwt get_notifications `Waq ~token:waq_token with
+ (match get_notifications env `Waq ~token:waq_token with
| [ { typ = "follow"; account = a; _ } ] ->
- let%lwt id, _, _ =
- lookup `Waq ~token:waq_token ~username:"mstdn1"
+ let id, _, _ =
+ lookup env `Waq ~token:waq_token ~username:"mstdn1"
~domain:mstdn_server_domain ()
in
assert (a.id = id);
- Lwt.return_unit
- | _ -> assert false);%lwt
+ ()
+ | _ -> assert false);
(* Post by @mstdn1@mstdn_server_domain *)
- let%lwt { uri; _ } = post `Mstdn ~token:mstdn_token () in
- Lwt_unix.sleep 1.0;%lwt
+ let ({ uri; _ } : status) = post env `Mstdn ~token:mstdn_token () in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Post by me *)
- let%lwt { uri = uri2; _ } = post `Waq ~token:waq_token () in
- Lwt_unix.sleep 1.0;%lwt
+ let ({ uri = uri2; _ } : status) = post env `Waq ~token:waq_token () in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Get home timeline of @mstdn1@mstdn_server_domain and check *)
- (home_timeline `Mstdn ~token:mstdn_token >|= function
+ (home_timeline env `Mstdn ~token:mstdn_token |> function
| [ `Assoc l2; `Assoc l ] ->
(* Check if the timeline is correct *)
assert (uri = (List.assoc "uri" l |> expect_string));
assert (uri2 = (List.assoc "uri" l2 |> expect_string));
()
- | _ -> assert false);%lwt
+ | _ -> assert false);
(* Unfollow me from @mstdn1@mstdn_server_domain *)
- unfollow `Mstdn ~token:mstdn_token aid;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ unfollow env `Mstdn ~token:mstdn_token aid;
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Get home timeline of @mstdn1@mstdn_server_domain and check again *)
- (home_timeline `Mstdn ~token:mstdn_token >|= function
+ (home_timeline env `Mstdn ~token:mstdn_token |> function
| [ `Assoc l ] ->
(* Check if the timeline is correct *)
assert (uri = (List.assoc "uri" l |> expect_string));
()
- | _ -> assert false);%lwt
+ | _ -> assert false);
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_mstdn_3_reply.ml b/e2e/src/waq_mstdn_3_reply.ml
index 734b197..b75be0d 100644
--- a/e2e/src/waq_mstdn_3_reply.ml
+++ b/e2e/src/waq_mstdn_3_reply.ml
@@ -1,34 +1,34 @@
open Common
let f =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
(* Lookup me from mstdn_server_domain *)
- let%lwt aid, _, _ =
- lookup `Mstdn ~token:mstdn_token ~username:"user1" ~domain:waq_server_domain
- ()
+ let aid, _, _ =
+ lookup env `Mstdn ~token:mstdn_token ~username:"user1"
+ ~domain:waq_server_domain ()
in
(* Lookup @mstdn1@mstdn_server_domain *)
- let%lwt mstdn1_id, _username, _acct =
- lookup `Waq ~token:waq_token ~username:"mstdn1" ~domain:mstdn_server_domain
- ()
+ let mstdn1_id, _username, _acct =
+ lookup env `Waq ~token:waq_token ~username:"mstdn1"
+ ~domain:mstdn_server_domain ()
in
(* Follow @mstdn1@mstdn_server_domain *)
- follow `Waq ~token:waq_token mstdn1_id;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ follow env `Waq ~token:waq_token mstdn1_id;
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Follow me from @mstdn1@mstdn_server_domain *)
- follow `Mstdn ~token:mstdn_token aid;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ follow env `Mstdn ~token:mstdn_token aid;
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Post by me *)
- let%lwt { uri; _ } = post `Waq ~token:waq_token () in
- Lwt_unix.sleep 1.0;%lwt
+ let ({ uri; _ } : status) = post env `Waq ~token:waq_token () in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Get home timeline of @mstdn1@mstdn_server_domain and obtain the status's id *)
- let%lwt id =
- home_timeline `Mstdn ~token:mstdn_token >|= function
+ let id =
+ home_timeline env `Mstdn ~token:mstdn_token |> function
| [ `Assoc l ] ->
(* Check if the timeline is correct *)
assert (uri = (List.assoc "uri" l |> expect_string));
@@ -37,12 +37,14 @@ let f =
in
(* Reply by @mstdn1@mstdn_server_domain *)
- let%lwt { uri; _ } = post `Mstdn ~token:mstdn_token ~in_reply_to_id:id () in
- Lwt_unix.sleep 1.0;%lwt
+ let ({ uri; _ } : status) =
+ post env `Mstdn ~token:mstdn_token ~in_reply_to_id:id ()
+ in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Get home timeline of me and obtain the reply's id *)
- let%lwt id =
- home_timeline `Waq ~token:waq_token >|= function
+ let id =
+ home_timeline env `Waq ~token:waq_token |> function
| [ `Assoc l; `Assoc l2 ] ->
assert (uri = (List.assoc "uri" l |> expect_string));
assert (List.assoc "id" l2 = List.assoc "in_reply_to_id" l);
@@ -54,12 +56,14 @@ let f =
in
(* Reply by me *)
- let%lwt { uri; _ } = post `Waq ~token:waq_token ~in_reply_to_id:id () in
- Lwt_unix.sleep 1.0;%lwt
+ let ({ uri; _ } : status) =
+ post env `Waq ~token:waq_token ~in_reply_to_id:id ()
+ in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Get home timeline of @mstdn1@mstdn_server_domain and check *)
- let%lwt _ =
- home_timeline `Mstdn ~token:mstdn_token >|= function
+ let _ =
+ home_timeline env `Mstdn ~token:mstdn_token |> function
| [ `Assoc l; `Assoc l2; `Assoc _ ] ->
(* Check if the timeline is correct *)
assert (uri = (List.assoc "uri" l |> expect_string));
@@ -71,4 +75,4 @@ let f =
| _ -> assert false
in
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_mstdn_4_reblog.ml b/e2e/src/waq_mstdn_4_reblog.ml
index 648e3fe..03545ea 100644
--- a/e2e/src/waq_mstdn_4_reblog.ml
+++ b/e2e/src/waq_mstdn_4_reblog.ml
@@ -1,28 +1,28 @@
open Common
let f =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
(* Lookup me from mstdn_server_domain *)
- let%lwt aid, _, _ =
- lookup `Mstdn ~token:mstdn_token ~username:"user1" ~domain:waq_server_domain
- ()
+ let aid, _, _ =
+ lookup env `Mstdn ~token:mstdn_token ~username:"user1"
+ ~domain:waq_server_domain ()
in
(* Follow me from @mstdn1@mstdn_server_domain *)
- follow `Mstdn ~token:mstdn_token aid;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ follow env `Mstdn ~token:mstdn_token aid;
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Post by user2 *)
- let%lwt waq_token' = fetch_access_token ~username:"user2" in
- let%lwt { id; uri; _ } = post `Waq ~token:waq_token' () in
+ let waq_token' = fetch_access_token env ~username:"user2" in
+ let ({ id; uri; _ } : status) = post env `Waq ~token:waq_token' () in
(* Reblog by me (user1) *)
- let%lwt _ = reblog `Waq ~token:waq_token ~id in
- Lwt_unix.sleep 2.0;%lwt
+ let _ = reblog env `Waq ~token:waq_token ~id in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 2.0;
(* Get home timeline of @mstdn1@mstdn_server_domain *)
- let%lwt _ =
- home_timeline `Mstdn ~token:mstdn_token >|= function
+ let _ =
+ home_timeline env `Mstdn ~token:mstdn_token |> function
| [ `Assoc l ] ->
(* Check if the timeline is correct *)
let reblog_uri =
@@ -33,4 +33,4 @@ let f =
| _ -> assert false
in
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_mstdn_5_reblog.ml b/e2e/src/waq_mstdn_5_reblog.ml
index 035c6f6..eb4100e 100644
--- a/e2e/src/waq_mstdn_5_reblog.ml
+++ b/e2e/src/waq_mstdn_5_reblog.ml
@@ -1,30 +1,30 @@
open Common
let f =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
(* Lookup @mstdn1@mstdn_server_domain *)
- let%lwt mstdn1_id, _username, _acct =
- lookup `Waq ~token:waq_token ~username:"mstdn1" ~domain:mstdn_server_domain
- ()
+ let mstdn1_id, _username, _acct =
+ lookup env `Waq ~token:waq_token ~username:"mstdn1"
+ ~domain:mstdn_server_domain ()
in
(* Follow @mstdn1@mstdn_server_domain *)
- follow `Waq ~token:waq_token mstdn1_id;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ follow env `Waq ~token:waq_token mstdn1_id;
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Post by user1 *)
- let%lwt { uri; id = post_id; _ } = post `Waq ~token:waq_token () in
- Lwt_unix.sleep 1.0;%lwt
+ let ({ uri; id = post_id; _ } : status) = post env `Waq ~token:waq_token () in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Reblog the post by @mstdn1@locahost:3000 *)
- (match%lwt search `Mstdn ~token:mstdn_token uri with
+ (match search env `Mstdn ~token:mstdn_token uri with
| _, [ status ], _ ->
- reblog `Mstdn ~token:mstdn_token ~id:status.id |> ignore_lwt
- | _ -> assert false);%lwt
- Lwt_unix.sleep 1.0;%lwt
+ reblog env `Mstdn ~token:mstdn_token ~id:status.id |> ignore
+ | _ -> assert false);
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Check home timeline *)
- (home_timeline `Waq ~token:waq_token >|= function
+ (home_timeline env `Waq ~token:waq_token |> function
| [ `Assoc l1; `Assoc l2 ] ->
(* Check if the timeline is correct *)
assert (uri = (l2 |> List.assoc "uri" |> expect_string));
@@ -33,10 +33,10 @@ let f =
= (l1 |> List.assoc "reblog" |> expect_assoc |> List.assoc "uri"
|> expect_string));
()
- | _ -> assert false);%lwt
+ | _ -> assert false);
(* Check notifications *)
- (get_notifications `Waq ~token:waq_token >|= function
+ (get_notifications env `Waq ~token:waq_token |> function
| [
{
typ = "reblog";
@@ -47,6 +47,6 @@ let f =
] ->
assert (account_id = mstdn1_id);
assert (status_id = post_id)
- | _ -> assert false);%lwt
+ | _ -> assert false);
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_mstdn_6_fav.ml b/e2e/src/waq_mstdn_6_fav.ml
index 192f0b8..473dfc1 100644
--- a/e2e/src/waq_mstdn_6_fav.ml
+++ b/e2e/src/waq_mstdn_6_fav.ml
@@ -1,56 +1,58 @@
open Common
let f =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
(* Lookup @mstdn1@mstdn_server_domain *)
- let%lwt mstdn1_id, _username, _acct =
- lookup `Waq ~token:waq_token ~username:"mstdn1" ~domain:mstdn_server_domain
- ()
+ let mstdn1_id, _username, _acct =
+ lookup env `Waq ~token:waq_token ~username:"mstdn1"
+ ~domain:mstdn_server_domain ()
in
(* Follow @mstdn1@mstdn_server_domain *)
- follow `Waq ~token:waq_token mstdn1_id;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ follow env `Waq ~token:waq_token mstdn1_id;
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Get user1's id on mstdn_server_domain *)
- let%lwt mstdn_user1_id, _, _ =
- lookup `Mstdn ~token:mstdn_token ~username:"user1" ()
+ let mstdn_user1_id, _, _ =
+ lookup env `Mstdn ~token:mstdn_token ~username:"user1" ()
in
(* Post by @mstdn1@mstdn_server_domain *)
- let%lwt { id = mstdn_post_id; _ } = post `Mstdn ~token:mstdn_token () in
- Lwt_unix.sleep 1.0;%lwt
+ let ({ id = mstdn_post_id; _ } : status) =
+ post env `Mstdn ~token:mstdn_token ()
+ in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Get id of the post *)
- let%lwt id =
- home_timeline `Waq ~token:waq_token >|= function
+ let id =
+ home_timeline env `Waq ~token:waq_token |> function
| [ `Assoc l ] -> List.assoc "id" l |> expect_string
| _ -> assert false
in
(* Favourite the post by me *)
- let%lwt s = fav `Waq ~token:waq_token ~id in
- Lwt_unix.sleep 1.0;%lwt
+ let s = fav env `Waq ~token:waq_token ~id in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
assert s.favourited;
- let%lwt s = get_status `Waq ~token:waq_token id in
+ let s = get_status env `Waq ~token:waq_token id in
assert s.favourited;
(* Check if the post is favourited in mstdn_server_domain *)
- (match%lwt get_favourited_by `Mstdn ~token:mstdn_token ~id:mstdn_post_id with
+ (match get_favourited_by env `Mstdn ~token:mstdn_token ~id:mstdn_post_id with
| [ a ] ->
assert (a.id = mstdn_user1_id);
- Lwt.return_unit
- | _ -> assert false);%lwt
+ ()
+ | _ -> assert false);
(* Unfavourite the post *)
- let%lwt s = unfav `Waq ~token:waq_token ~id in
- Lwt_unix.sleep 1.0;%lwt
+ let s = unfav env `Waq ~token:waq_token ~id in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
assert (not s.favourited);
- let%lwt s = get_status `Waq ~token:waq_token id in
+ let s = get_status env `Waq ~token:waq_token id in
assert (not s.favourited);
(* Check if the post is unfavourited *)
- (match%lwt get_favourited_by `Mstdn ~token:mstdn_token ~id:mstdn_post_id with
- | [] -> Lwt.return_unit
- | _ -> assert false);%lwt
+ (match get_favourited_by env `Mstdn ~token:mstdn_token ~id:mstdn_post_id with
+ | [] -> ()
+ | _ -> assert false);
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_mstdn_7_fav.ml b/e2e/src/waq_mstdn_7_fav.ml
index 155dcd4..5116455 100644
--- a/e2e/src/waq_mstdn_7_fav.ml
+++ b/e2e/src/waq_mstdn_7_fav.ml
@@ -1,45 +1,47 @@
open Common
let f =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
(* Lookup me from mstdn_server_domain *)
- let%lwt aid, _, _ =
- lookup `Mstdn ~token:mstdn_token ~username:"user1" ~domain:waq_server_domain
- ()
+ let aid, _, _ =
+ lookup env `Mstdn ~token:mstdn_token ~username:"user1"
+ ~domain:waq_server_domain ()
in
(* Lookup @mstdn1@mstdn_server_domain *)
- let%lwt mstdn1_id, _username, _acct =
- lookup `Waq ~token:waq_token ~username:"mstdn1" ~domain:mstdn_server_domain
- ()
+ let mstdn1_id, _username, _acct =
+ lookup env `Waq ~token:waq_token ~username:"mstdn1"
+ ~domain:mstdn_server_domain ()
in
(* Follow me from @mstdn1@mstdn_server_domain *)
- follow `Mstdn ~token:mstdn_token aid;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ follow env `Mstdn ~token:mstdn_token aid;
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Post by me *)
- let%lwt { id = waq_status_id; _ } = post `Waq ~token:waq_token () in
- Lwt_unix.sleep 1.0;%lwt
+ let ({ id = waq_status_id; _ } : status) =
+ post env `Waq ~token:waq_token ()
+ in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Get id of the post *)
- let%lwt mstdn_status_id =
- home_timeline `Mstdn ~token:mstdn_token >|= function
+ let mstdn_status_id =
+ home_timeline env `Mstdn ~token:mstdn_token |> function
| [ `Assoc l ] -> List.assoc "id" l |> expect_string
| _ -> assert false
in
(* Favourite the post by @mstdn1@mstdn_server_domain *)
- let%lwt _ = fav `Mstdn ~token:mstdn_token ~id:mstdn_status_id in
- Lwt_unix.sleep 1.0;%lwt
+ let _ = fav env `Mstdn ~token:mstdn_token ~id:mstdn_status_id in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Check if the post is favourited *)
- (match%lwt get_favourited_by `Waq ~token:waq_token ~id:waq_status_id with
+ (match get_favourited_by env `Waq ~token:waq_token ~id:waq_status_id with
| [ a ] ->
assert (a.id = mstdn1_id);
- Lwt.return_unit
- | _ -> assert false);%lwt
+ ()
+ | _ -> assert false);
(* Check notification *)
- (match%lwt get_notifications `Waq ~token:waq_token with
+ (match get_notifications env `Waq ~token:waq_token with
| [
{
typ = "favourite";
@@ -52,16 +54,16 @@ let f =
assert (account_id = mstdn1_id);
assert (status_id = waq_status_id);
assert (account_id' = mstdn1_id);
- Lwt.return_unit
- | _ -> assert false);%lwt
+ ()
+ | _ -> assert false);
(* Unfavourite the post *)
- let%lwt _ = unfav `Mstdn ~token:mstdn_token ~id:mstdn_status_id in
- Lwt_unix.sleep 1.0;%lwt
+ let _ = unfav env `Mstdn ~token:mstdn_token ~id:mstdn_status_id in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* Check if the post is unfavourited *)
- (match%lwt get_favourited_by `Waq ~token:waq_token ~id:waq_status_id with
- | [] -> Lwt.return_unit
- | _ -> assert false);%lwt
+ (match get_favourited_by env `Waq ~token:waq_token ~id:waq_status_id with
+ | [] -> ()
+ | _ -> assert false);
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_mstdn_8_lookup_search.ml b/e2e/src/waq_mstdn_8_lookup_search.ml
index 7b5278a..fd91543 100644
--- a/e2e/src/waq_mstdn_8_lookup_search.ml
+++ b/e2e/src/waq_mstdn_8_lookup_search.ml
@@ -1,21 +1,21 @@
open Common
let f =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
(* Lookup @mstdn1@mstdn_server_domain *)
- let%lwt res1 =
- lookup `Waq ~token:waq_token ~username:"mstdn1" ~domain:mstdn_server_domain
- ()
+ let res1 =
+ lookup env `Waq ~token:waq_token ~username:"mstdn1"
+ ~domain:mstdn_server_domain ()
in
- let%lwt res2 =
- lookup_via_v1_accounts_search `Waq ~token:waq_token ~username:"mstdn1"
+ let res2 =
+ lookup_via_v1_accounts_search env `Waq ~token:waq_token ~username:"mstdn1"
~domain:mstdn_server_domain ()
in
- let%lwt res3 =
- lookup_via_v1_accounts_lookup `Waq ~token:waq_token ~username:"mstdn1"
+ let res3 =
+ lookup_via_v1_accounts_lookup env `Waq ~token:waq_token ~username:"mstdn1"
~domain:mstdn_server_domain ()
in
- let%lwt res4 = search `Waq ~token:waq_token (mstdn "/users/mstdn1") in
+ let res4 = search env `Waq ~token:waq_token (mstdn "/users/mstdn1") in
assert (res1 = res2);
assert (res1 = res3);
assert (
@@ -24,20 +24,20 @@ let f =
| _ -> false);
(* No token should cause an error *)
- expect_exc_lwt (fun () ->
- lookup_via_v1_accounts_search `Waq ~username:"mstdn1"
- ~domain:mstdn_server_domain ());%lwt
+ expect_exc (fun () ->
+ lookup_via_v1_accounts_search env `Waq ~username:"mstdn1"
+ ~domain:mstdn_server_domain ());
(* Lookup me *)
- let%lwt res1 = lookup `Waq ~token:waq_token ~username:"user1" () in
- let%lwt res2 =
- lookup_via_v1_accounts_search `Waq ~token:waq_token ~username:"user1" ()
+ let res1 = lookup env `Waq ~token:waq_token ~username:"user1" () in
+ let res2 =
+ lookup_via_v1_accounts_search env `Waq ~token:waq_token ~username:"user1" ()
in
- let%lwt res3 =
- lookup_via_v1_accounts_lookup `Waq ~token:waq_token ~username:"user1" ()
+ let res3 =
+ lookup_via_v1_accounts_lookup env `Waq ~token:waq_token ~username:"user1" ()
in
- let%lwt res4 =
- search `Waq ~token:waq_token (waq_server_name ^/ "users/user1")
+ let res4 =
+ search env `Waq ~token:waq_token (waq_server_name ^/ "users/user1")
in
assert (res1 = res2);
assert (res1 = res3);
@@ -47,9 +47,9 @@ let f =
| _ -> false);
(* Lookup post of @mstdn1@mstdn_server_domain *)
- let%lwt { uri; _ } = post `Mstdn ~token:mstdn_token () in
- let%lwt res = search `Waq ~token:waq_token uri in
+ let { uri; _ } = post env `Mstdn ~token:mstdn_token () in
+ let res = search env `Waq ~token:waq_token uri in
assert (
match res with _, [ status ], _ when status.uri = uri -> true | _ -> false);
- Lwt.return_unit
+ ()
diff --git a/e2e/src/waq_mstdn_9_delete.ml b/e2e/src/waq_mstdn_9_delete.ml
index 19a2661..721d825 100644
--- a/e2e/src/waq_mstdn_9_delete.ml
+++ b/e2e/src/waq_mstdn_9_delete.ml
@@ -1,82 +1,78 @@
open Common2
-let f (a0 : agent) (a1 : agent) =
+let f env (a0 : agent) (a1 : agent) =
(* a0: Follow a1 *)
- follow_agent a0 a1;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ follow_agent env a0 a1;
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* a1: Post *)
- let%lwt { uri; id = a1_post_id; _ } = post a1 () in
- Lwt_unix.sleep 1.0;%lwt
+ let { uri; id = a1_post_id; _ } = post env a1 () in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* a0: Get the post id *)
- let%lwt a0_post_id =
- match%lwt search a0 uri with
- | _, [ s ], _ -> Lwt.return s.id
- | _ -> assert false
+ let a0_post_id =
+ match search env a0 uri with _, [ s ], _ -> s.id | _ -> assert false
in
(* a0: Reblog the post *)
- let%lwt a0_reblog_id = reblog a0 ~id:a0_post_id >|= fun r -> r.id in
- Lwt_unix.sleep 1.0;%lwt
+ let a0_reblog_id = reblog env a0 ~id:a0_post_id |> fun r -> r.id in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* a0: Check the posts *)
- let%lwt _ = get_status a0 a0_post_id in
- let%lwt _ = get_status a0 a0_reblog_id in
+ let _ = get_status env a0 a0_post_id in
+ let _ = get_status env a0 a0_reblog_id in
(* a1: Delete the post *)
- delete_status a1 a1_post_id |> ignore_lwt;%lwt
- Lwt_unix.sleep 2.0;%lwt
+ delete_status env a1 a1_post_id |> ignore;
+ Eio.Time.sleep (Eio.Stdenv.clock env) 2.0;
(* a0: Check the posts *)
- expect_no_status a0 a0_post_id;%lwt
- expect_no_status a0 a0_reblog_id;%lwt
+ expect_no_status env a0 a0_post_id;
+ expect_no_status env a0 a0_reblog_id;
(***************************)
(* a0: Follow a1 *)
- follow_agent a1 a0;%lwt
+ follow_agent env a1 a0;
(* a1: Post *)
- let%lwt { uri; id = post_id; _ } = post a1 () in
- Lwt_unix.sleep 1.0;%lwt
+ let { uri; id = post_id; _ } = post env a1 () in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* a0: Get the post id *)
- let%lwt a0_post_id =
- match%lwt search a0 uri with
- | _, [ s ], _ -> Lwt.return s.id
- | _ -> assert false
+ let a0_post_id =
+ match search env a0 uri with _, [ s ], _ -> s.id | _ -> assert false
in
(* a0: Reblog the post *)
- let%lwt a0_reblog_id = reblog a0 ~id:a0_post_id >|= fun r -> r.id in
- Lwt_unix.sleep 1.0;%lwt
+ let a0_reblog_id = reblog env a0 ~id:a0_post_id |> fun r -> r.id in
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* a0: Check the posts *)
- let%lwt _ = get_status a0 a0_post_id in
- let%lwt _ = get_status a0 a0_reblog_id in
+ let _ = get_status env a0 a0_post_id in
+ let _ = get_status env a0 a0_reblog_id in
(* a1: Check if a0 reblogged a0_post_id *)
- let%lwt { reblogs_count; _ } = get_status a1 post_id in
+ let { reblogs_count; _ } = get_status env a1 post_id in
assert (reblogs_count = 1);
(* a0: Unreblog the post *)
- unreblog a0 ~id:a0_post_id |> ignore_lwt;%lwt
- Lwt_unix.sleep 1.0;%lwt
+ unreblog env a0 ~id:a0_post_id |> ignore;
+ Eio.Time.sleep (Eio.Stdenv.clock env) 1.0;
(* a0: Check the posts *)
- let%lwt _ = get_status a0 a0_post_id in
- expect_no_status a0 a0_reblog_id;%lwt
+ let _ = get_status env a0 a0_post_id in
+ expect_no_status env a0 a0_reblog_id;
(*
(* a1: Check if a0 unreblogged a0_post_id *)
- let%lwt { reblogs_count; _ } = get_status a1 post_id in
+ let { reblogs_count; _ } = get_status a1 post_id in
assert (reblogs_count = 0);
*)
- Lwt.return_unit
+ ()
let f_waq_mstdn =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
let a0 =
make_agent ~kind:`Waq ~token:waq_token ~username:"user1"
~domain:waq_server_domain
@@ -85,11 +81,11 @@ let f_waq_mstdn =
make_agent ~kind:`Mstdn ~token:mstdn_token ~username:"mstdn1"
~domain:mstdn_server_domain
in
- f a0 a1;%lwt
- Lwt.return_unit
+ f env a0 a1;
+ ()
let f_mstdn_waq =
- make_waq_and_mstdn_scenario @@ fun waq_token mstdn_token ->
+ make_waq_and_mstdn_scenario @@ fun env waq_token mstdn_token ->
let a0 =
make_agent ~kind:`Mstdn ~token:mstdn_token ~username:"mstdn1"
~domain:mstdn_server_domain
@@ -98,5 +94,5 @@ let f_mstdn_waq =
make_agent ~kind:`Waq ~token:waq_token ~username:"user1"
~domain:waq_server_domain
in
- f a0 a1;%lwt
- Lwt.return_unit
+ f env a0 a1;
+ ()
diff --git a/lib/activity.ml b/lib/activity.ml
index fdf9295..b890869 100644
--- a/lib/activity.ml
+++ b/lib/activity.ml
@@ -1,6 +1,16 @@
-open Lwt.Infix
open Util
-module Uri = Httpq.Uri
+
+module Uri = struct
+ include Uri
+
+ let http_host (u : t) =
+ let host = Uri.host u |> Option.get in
+ match Uri.port u with
+ | None -> host
+ | Some port -> host ^ ":" ^ string_of_int port
+
+ let domain (u : t) = http_host u
+end
let is_my_domain (u : string) =
u |> Uri.of_string |> Uri.domain |> Config.is_my_domain
@@ -608,7 +618,7 @@ let rec to_yojson ?(context = Some "https://www.w3.org/ns/activitystreams") v =
let sign_spec_of_account (src : Db.Account.t) =
let priv_key =
- src#private_key |> Option.get |> Httpq.Signature.decode_private_key
+ src#private_key |> Option.get |> Yume.Signature.decode_private_key
in
let key_id = src#uri ^ "#main-key" in
let signed_headers =
@@ -616,12 +626,10 @@ let sign_spec_of_account (src : Db.Account.t) =
in
Some (priv_key, key_id, signed_headers)
-let post_activity_json ~body ~sign ~url =
+let post_activity_json env ~body ~sign ~url =
let meth = `POST in
let headers = [ (`Content_type, "application/activity+json") ] in
- let%lwt res = Throttle_fetch.f ~meth ~headers ~body ~sign url in
- Lwt.return
- &
+ let res = Throttle_fetch.f env ~meth ~headers ~body ~sign url in
match res with
| Ok (status, _, _body)
when Cohttp.Code.(status |> code_of_status |> is_success) ->
@@ -629,27 +637,27 @@ let post_activity_json ~body ~sign ~url =
| _ -> failwith "Failed to post activity json"
(* Get activity+json from the Internet *)
-let fetch_activity ~uri =
+let fetch_activity env ~uri =
match uri with
| "https://www.w3.org/ns/activitystreams" -> failwith "Not valid activity URI"
| _ ->
- Throttle_fetch.f_exn
+ Throttle_fetch.f_exn env
~headers:
[
(`Accept, "application/activity+json");
(`Content_type, "text/html" (* dummy *));
]
uri
- >|= Yojson.Safe.from_string
+ |> Yojson.Safe.from_string
(* Send GET /.well-known/webfinger *)
-let get_webfinger ~scheme ~domain ~username =
+let get_webfinger env ~scheme ~domain ~username =
(* FIXME: Check /.well-known/host-meta if necessary *)
- let%lwt body =
- Throttle_fetch.f_exn @@ scheme ^ ":/" ^/ domain
+ let body =
+ Throttle_fetch.f_exn env @@ scheme ^ ":/" ^/ domain
^/ ".well-known/webfinger?resource=acct:" ^ username ^ "@" ^ domain
in
- body |> Yojson.Safe.from_string |> webfinger_of_yojson |> Lwt.return
+ body |> Yojson.Safe.from_string |> webfinger_of_yojson
let model_account_of_person ?original (r : ap_person) : Model.Account.t =
let domain = Uri.(r.id |> of_string |> domain) |> Option.some in
@@ -682,28 +690,27 @@ let model_account_of_person ?original (r : ap_person) : Model.Account.t =
a#set_actor_type (Some (if r.is_service then `Service else `Person));
a
-let fetch_person by =
+let fetch_person env by =
let get_uri = function
| `DomainUser (domain, username) | `UserDomain (username, domain) ->
- get_webfinger ~scheme:"https" ~domain ~username >|= fun webfinger ->
+ let webfinger = get_webfinger env ~scheme:"https" ~domain ~username in
webfinger.links
|> List.find_map @@ fun l ->
let l = webfinger_link_of_yojson l in
if l.rel = "self" then Some l.href else None
| `Uri uri ->
- Uri.(with_fragment (of_string uri) None |> to_string)
- |> Option.some |> Lwt.return
+ Uri.(with_fragment (of_string uri) None |> to_string) |> Option.some
in
- match%lwt get_uri by with
+ match get_uri by with
| None -> failwith "Couldn't find person's uri"
| Some uri -> (
- fetch_activity ~uri >|= of_yojson >|= get_person >|= function
+ fetch_activity env ~uri |> of_yojson |> get_person |> function
| None -> failwith "Couldn't parse the activity Person"
| Some person -> person)
-let search_account ?(resolve = true) by : Model.Account.t Lwt.t =
+let search_account env ?(resolve = true) by : Model.Account.t =
let make_new_account by =
- let%lwt a = fetch_person by >|= model_account_of_person in
+ let a = fetch_person env by |> model_account_of_person in
Db.(e @@ Account.save_one a)
in
match by with
@@ -713,37 +720,33 @@ let search_account ?(resolve = true) by : Model.Account.t Lwt.t =
| Some s when s <> Config.server_name () -> Some s
| _ -> None
in
- match%lwt Db.(e @@ Account.get_one ~domain ~username) with
- | acc -> Lwt.return acc
- | exception Sqlx.Error.NoRowFound
- when domain = None (* Local *) || not resolve ->
+ try Db.(e @@ Account.get_one ~domain ~username) with
+ | Sqlx.Error.NoRowFound when domain = None (* Local *) || not resolve ->
failwith "Couldn't find the account"
- | exception Sqlx.Error.NoRowFound ->
+ | Sqlx.Error.NoRowFound ->
make_new_account (`DomainUser (Option.get domain, username)))
| `Uri uri -> (
let uri = Uri.(with_fragment (of_string uri) None |> to_string) in
- match%lwt Db.(e @@ Account.get_one ~uri) with
- | acct -> Lwt.return acct
- | exception Sqlx.Error.NoRowFound when not resolve ->
+ try Db.(e @@ Account.get_one ~uri) with
+ | Sqlx.Error.NoRowFound when not resolve ->
failwith "Couldn't find the account"
- | exception Sqlx.Error.NoRowFound -> make_new_account (`Uri uri))
+ | Sqlx.Error.NoRowFound -> make_new_account (`Uri uri))
-let search_account_opt ?resolve by =
- try%lwt search_account ?resolve by >>= Lwt.return_some
- with _ -> Lwt.return_none
+let search_account_opt env ?resolve by =
+ try Some (search_account env ?resolve by) with _ -> None
-let verify_activity_json req =
- let%lwt body = Httpq.Server.body req in
- let signature = Httpq.Server.header `Signature req in
- let headers = Httpq.Server.headers req in
- let path = Httpq.Server.path req in
- let meth = Httpq.Server.meth req in
+let verify_activity_json env req =
+ let body = Yume.Server.body req in
+ let signature = Yume.Server.header `Signature req in
+ let headers = Yume.Server.headers req in
+ let path = Yume.Server.path req in
+ let meth = Yume.Server.meth req in
- let open Httpq.Signature in
+ let open Yume.Signature in
let { key_id; algorithm; headers = signed_headers; signature } =
parse_signature_header signature
in
- search_account_opt (`Uri key_id) >|= function
+ match search_account_opt env (`Uri key_id) with
| None -> (body, Error `AccountNotFound)
| Some acct when Model.Account.is_local acct -> (body, Error `AccountIsLocal)
| Some acct -> (
@@ -755,7 +758,7 @@ let verify_activity_json req =
| Error e ->
Logq.err (fun m ->
m "verify_activity_json failed: [%s]"
- (headers |> Httpq.Headers.to_list
+ (headers |> Yume.Headers.to_list
|> List.map (fun (k, v) -> k ^ "=" ^ v)
|> String.concat ", "));
(body, Error (`VerifFailure e))
@@ -810,9 +813,9 @@ let serialize_status (s : Model.Status.t) (self : Model.Account.t) : ap_note =
url = s#url;
}
-let note_of_status (s : Db.Status.t) : ap_note Lwt.t =
- let%lwt self = Db.(e Account.(get_one ~id:s#account_id)) in
- let%lwt s =
+let note_of_status (s : Db.Status.t) : ap_note =
+ let self = Db.(e Account.(get_one ~id:s#account_id)) in
+ let s =
Db.(
e
Status.(
@@ -825,23 +828,26 @@ let note_of_status (s : Db.Status.t) : ap_note Lwt.t =
`account [];
]))
in
- serialize_status s self |> Lwt.return
+ serialize_status s self
-let rec status_of_note' (note : ap_note) : Db.Status.t Lwt.t =
+let rec status_of_note' env (note : ap_note) : Db.Status.t =
let published, _, _ = Ptime.of_rfc3339 note.published |> Result.get_ok in
- let%lwt in_reply_to_id =
- let uri_to_status_id uri = fetch_status ~uri >|= fun s -> Some s#id in
+ let in_reply_to_id =
+ let uri_to_status_id uri =
+ let s = fetch_status env ~uri in
+ Some s#id
+ in
match note.in_reply_to with
| `String uri -> uri_to_status_id uri
| `Assoc l -> (
match l |> List.assoc_opt "id" with
| Some (`String uri) -> uri_to_status_id uri
- | _ -> Lwt.return_none)
- | _ -> Lwt.return_none
+ | _ -> None)
+ | _ -> None
in
- let%lwt attributedTo = search_account (`Uri note.attributed_to) in
+ let attributedTo = search_account env (`Uri note.attributed_to) in
- let%lwt status =
+ let status =
Db.(
e
Status.(
@@ -854,14 +860,15 @@ let rec status_of_note' (note : ap_note) : Db.Status.t Lwt.t =
(* Handle attachments *)
note.attachment
|> List.filter_map get_document
- |> Lwt_list.iter_s (fun (d : ap_document) ->
- let%lwt blurhash =
+ |> List.iter (fun (d : ap_document) ->
+ let blurhash =
match (d.blurhash, d.url) with
- | Some h, _ -> Lwt.return h
- | None, "" -> Lwt.return Image.dummy_blurhash
+ | Some h, _ -> h
+ | None, "" -> Image.dummy_blurhash
| None, url ->
- Throttle_fetch.http_get url >>= Image.inspect
- >|= fun (_, _, h) -> h
+ let body = Throttle_fetch.http_get env url in
+ let _, _, h = Lwt_eio.run_lwt (fun () -> Image.inspect body) in
+ h
in
Db.(
e
@@ -869,28 +876,28 @@ let rec status_of_note' (note : ap_note) : Db.Status.t Lwt.t =
make ~type_:0 ~remote_url:d.url ~account_id:status#account_id
~status_id:status#id ~blurhash ()
|> save_one))
- |> ignore_lwt);%lwt
+ |> ignore);
(* Handle mentions *)
- (note.cc @ note.to_
- |> Lwt_list.filter_map_p (fun uri -> search_account_opt (`Uri uri))
- >>= Lwt_list.iter_p @@ fun acct ->
- let m =
- Model.Mention.(make ~account_id:acct#id ~status_id:status#id ())
- in
- Db.(e @@ Mention.(save_one m)) |> ignore_lwt);%lwt
+ (* FIXME: can be processed in parallel *)
+ note.cc @ note.to_
+ |> List.filter_map (fun uri -> search_account_opt env (`Uri uri))
+ |> List.iter (fun acct ->
+ let m =
+ Model.Mention.(make ~account_id:acct#id ~status_id:status#id ())
+ in
+ Db.(e @@ Mention.(save_one m)) |> ignore);
- Lwt.return status
+ status
-and status_of_note (note : ap_note) : Db.Status.t Lwt.t =
- match%lwt Db.(e Status.(get_one ~uri:note.id)) with
- | s -> Lwt.return s
- | exception Sqlx.Error.NoRowFound -> status_of_note' note
+and status_of_note env (note : ap_note) : Db.Status.t =
+ try Db.(e Status.(get_one ~uri:note.id))
+ with Sqlx.Error.NoRowFound -> status_of_note' env note
-and status_of_announce' (ann : ap_announce) : Db.Status.t Lwt.t =
+and status_of_announce' env (ann : ap_announce) : Db.Status.t =
let published, _, _ = Ptime.of_rfc3339 ann.published |> Result.get_ok in
- let%lwt reblogee = fetch_status ~uri:ann.obj in
- let%lwt account = search_account (`Uri ann.actor) in
+ let reblogee = fetch_status env ~uri:ann.obj in
+ let account = search_account env (`Uri ann.actor) in
Db.(
e
Status.(
@@ -898,23 +905,21 @@ and status_of_announce' (ann : ap_announce) : Db.Status.t Lwt.t =
~account_id:account#id ~reblog_of_id:reblogee#id ~spoiler_text:"" ()
|> save_one))
-and status_of_announce (ann : ap_announce) : Db.Status.t Lwt.t =
- match%lwt Db.(e Status.(get_one ~uri:ann.id)) with
- | s -> Lwt.return s
- | exception Sqlx.Error.NoRowFound -> status_of_announce' ann
-
-and fetch_status ~uri =
- match%lwt Db.(e Status.(get_one ~uri)) with
- | s -> Lwt.return s
- | exception Sqlx.Error.NoRowFound -> (
- match%lwt fetch_activity ~uri >|= of_yojson with
- | Note note -> status_of_note note
- | Announce ann -> status_of_announce ann
- | _ -> failwith "fetch_status failed: fetched activity is invalid")
-
-let create_note_of_status (s : Db.Status.t) : ap_create Lwt.t =
- let%lwt self = Db.(e Account.(get_one ~id:s#account_id)) in
- note_of_status s >|= fun note ->
+and status_of_announce env (ann : ap_announce) : Db.Status.t =
+ try Db.(e Status.(get_one ~uri:ann.id))
+ with Sqlx.Error.NoRowFound -> status_of_announce' env ann
+
+and fetch_status env ~uri =
+ try Db.(e Status.(get_one ~uri))
+ with Sqlx.Error.NoRowFound -> (
+ match fetch_activity env ~uri |> of_yojson with
+ | Note note -> status_of_note env note
+ | Announce ann -> status_of_announce env ann
+ | _ -> failwith "fetch_status failed: fetched activity is invalid")
+
+let create_note_of_status (s : Db.Status.t) : ap_create =
+ let self = Db.(e Account.(get_one ~id:s#account_id)) in
+ let note = note_of_status s in
{
id = note.id ^/ "activity";
actor = `String self#uri;
@@ -924,14 +929,13 @@ let create_note_of_status (s : Db.Status.t) : ap_create Lwt.t =
obj = Note note;
}
-let announce_of_status ?(deleted = false) (s : Db.Status.t) : ap_announce Lwt.t
- =
- let%lwt reblog =
+let announce_of_status ?(deleted = false) (s : Db.Status.t) : ap_announce =
+ let reblog =
let id = Option.get s#reblog_of_id in
Db.(if deleted then e Status.(get_one' ~id) else e Status.(get_one ~id))
in
- let%lwt reblog_acct = Db.(e Account.(get_one ~id:reblog#account_id)) in
- let%lwt self = Db.(e Account.(get_one ~id:s#account_id)) in
+ let reblog_acct = Db.(e Account.(get_one ~id:reblog#account_id)) in
+ let self = Db.(e Account.(get_one ~id:s#account_id)) in
let id = s#uri ^/ "activity" in
let actor = self#uri in
@@ -940,11 +944,11 @@ let announce_of_status ?(deleted = false) (s : Db.Status.t) : ap_announce Lwt.t
let cc = [ reblog_acct#uri; self#followers_url ] in
let obj = reblog#uri in
- make_announce ~id ~actor ~published ~to_ ~cc ~obj |> Lwt.return
+ make_announce ~id ~actor ~published ~to_ ~cc ~obj
-let like_of_favourite (f : Db.Favourite.t) : ap_like Lwt.t =
- let%lwt acct = Db.(e Account.(get_one ~id:f#account_id)) in
- let%lwt status = Db.(e Status.(get_one ~id:f#status_id)) in
+let like_of_favourite (f : Db.Favourite.t) : ap_like =
+ let acct = Db.(e Account.(get_one ~id:f#account_id)) in
+ let status = Db.(e Status.(get_one ~id:f#status_id)) in
let id =
acct#uri ^ "#likes/" ^ (f#id |> Model.Favourite.ID.to_int |> string_of_int)
@@ -952,27 +956,24 @@ let like_of_favourite (f : Db.Favourite.t) : ap_like Lwt.t =
let actor = acct#uri in
let obj = status#uri in
- make_like ~id ~actor ~obj |> Lwt.return
+ make_like ~id ~actor ~obj
let favourite_of_like ?(must_already_exist = false) (l : ap_like) :
- Db.Favourite.t Lwt.t =
- let%lwt acct = Db.(e Account.(get_one ~uri:l.actor)) in
- let%lwt status = Db.(e Status.(get_one ~uri:l.obj)) in
+ Db.Favourite.t =
+ let acct = Db.(e Account.(get_one ~uri:l.actor)) in
+ let status = Db.(e Status.(get_one ~uri:l.obj)) in
let now = Ptime.now () in
- match%lwt
- Db.(e Favourite.(get_one ~account_id:acct#id ~status_id:status#id))
- with
- | fav -> Lwt.return fav
- | exception Sqlx.Error.NoRowFound ->
- if must_already_exist then
- failwith "favourite_of_like: must_already_exist failed"
- else
- Db.(
- e
- Favourite.(
- make ~created_at:now ~updated_at:now ~account_id:acct#id
- ~status_id:status#id ()
- |> save_one))
+ try Db.(e Favourite.(get_one ~account_id:acct#id ~status_id:status#id))
+ with Sqlx.Error.NoRowFound ->
+ if must_already_exist then
+ failwith "favourite_of_like: must_already_exist failed"
+ else
+ Db.(
+ e
+ Favourite.(
+ make ~created_at:now ~updated_at:now ~account_id:acct#id
+ ~status_id:status#id ()
+ |> save_one))
let to_undo ~actor =
let actor = `String actor in
diff --git a/lib/controller/api_v1/accounts/follow.ml b/lib/controller/api_v1/accounts/follow.ml
index 5ce787c..c0f7848 100644
--- a/lib/controller/api_v1/accounts/follow.ml
+++ b/lib/controller/api_v1/accounts/follow.ml
@@ -2,7 +2,7 @@ open Entity
open Helper
open Util
-let request_follow ~uri (self : Db.Account.t) (acc : Db.Account.t) =
+let request_follow env ~uri (self : Db.Account.t) (acc : Db.Account.t) =
(* FIXME: Assume acc is a remote account *)
assert (acc#domain <> None);
@@ -11,21 +11,19 @@ let request_follow ~uri (self : Db.Account.t) (acc : Db.Account.t) =
e
@@ FollowRequest.(
make ~account_id:self#id ~target_account_id:acc#id ~uri () |> save_one))
- |> ignore_lwt;%lwt
+ |> ignore;
(* Post activity *)
let open Activity in
let activity = make_follow ~id:uri ~actor:self#uri ~obj:acc#uri |> follow in
- Worker.Delivery.kick ~activity ~src:self ~url:acc#inbox_url;%lwt
+ Worker.Delivery.kick env ~activity ~src:self ~url:acc#inbox_url
- Lwt.return_unit
-
-let direct_follow ~uri (self : Db.Account.t) (acc : Db.Account.t) =
+let direct_follow env ~uri (self : Db.Account.t) (acc : Db.Account.t) =
(* Assume acc is a local account *)
assert (acc#domain = None);
(* Insert follow *)
- let%lwt f =
+ let f =
Db.(
e
@@ Follow.(
@@ -34,54 +32,49 @@ let direct_follow ~uri (self : Db.Account.t) (acc : Db.Account.t) =
in
(* Notify *)
- Worker.Local_notify.kick
+ Worker.Local_notify.kick env
~activity_id:(Model.Follow.ID.to_int f#id)
- ~activity_type:`Follow ~dst:acc ~src:self ~typ:`follow;%lwt
-
- Lwt.return_unit
+ ~activity_type:`Follow ~dst:acc ~src:self ~typ:`follow
-let follow_not_possible ~(src : Db.Account.t) ~(dst : Db.Account.t) : bool Lwt.t
- =
- Lwt.return (src#id = dst#id)
+let follow_not_possible ~(src : Db.Account.t) ~(dst : Db.Account.t) : bool =
+ src#id = dst#id
-let already_followed ~(src : Db.Account.t) ~(dst : Db.Account.t) : bool Lwt.t =
- match%lwt
+let already_followed ~(src : Db.Account.t) ~(dst : Db.Account.t) : bool =
+ match
Db.(e @@ Follow.get_one ~account_id:src#id ~target_account_id:dst#id)
with
- | _ -> Lwt.return_true
- | exception Sqlx.Error.NoRowFound -> Lwt.return_false
+ | _ -> true
+ | exception Sqlx.Error.NoRowFound -> false
-let already_follow_requested ~(src : Db.Account.t) ~(dst : Db.Account.t) :
- bool Lwt.t =
- match%lwt
+let already_follow_requested ~(src : Db.Account.t) ~(dst : Db.Account.t) : bool
+ =
+ match
Db.(e @@ FollowRequest.get_one ~account_id:src#id ~target_account_id:dst#id)
with
- | _ -> Lwt.return_true
- | exception Sqlx.Error.NoRowFound -> Lwt.return_false
+ | _ -> true
+ | exception Sqlx.Error.NoRowFound -> false
-let service ~(src : Db.Account.t) ~(dst : Db.Account.t) : unit Lwt.t =
- if%lwt follow_not_possible ~src ~dst then
- Httpq.Server.raise_error_response `Forbidden
+let service env ~(src : Db.Account.t) ~(dst : Db.Account.t) : unit =
+ if follow_not_possible ~src ~dst then
+ Yume.Server.raise_error_response `Forbidden
+ else if already_followed ~src ~dst then ()
+ else if already_follow_requested ~src ~dst then ()
else
- if%lwt already_followed ~src ~dst then Lwt.return_unit
- else
- if%lwt already_follow_requested ~src ~dst then Lwt.return_unit
- else
- let uri = src#uri ^/ Uuidm.(v `V4 |> to_string) in
- match dst#domain with
- | None (* local *) -> direct_follow ~uri src dst
- | Some _ (* remote *) -> request_follow ~uri src dst
+ let uri = src#uri ^/ Uuidm.(v `V4 |> to_string) in
+ match dst#domain with
+ | None (* local *) -> direct_follow env ~uri src dst
+ | Some _ (* remote *) -> request_follow env ~uri src dst
(* Recv POST /api/v1/accounts/:id/follow *)
-let post req =
- let%lwt self = authenticate_account req in
- let acct_id = req |> Httpq.Server.param ":id" |> string_to_account_id in
+let post env req =
+ let self = authenticate_account req in
+ let acct_id = req |> Yume.Server.param ":id" |> string_to_account_id in
- let%lwt acct = Db.e (Model.Account.get_one ~id:acct_id) in
- service ~src:self ~dst:acct;%lwt
+ let acct = Db.e (Model.Account.get_one ~id:acct_id) in
+ service env ~src:self ~dst:acct;
(* Return the result to the client *)
- let%lwt rel = make_relationship_from_model self acct in
+ let rel = make_relationship_from_model self acct in
(* Pretend the follow succeeded *)
let rel = { rel with following = true } in
rel |> yojson_of_relationship |> respond_yojson
diff --git a/lib/controller/api_v1/accounts/following.ml b/lib/controller/api_v1/accounts/following.ml
index d8af1aa..013b317 100644
--- a/lib/controller/api_v1/accounts/following.ml
+++ b/lib/controller/api_v1/accounts/following.ml
@@ -1,4 +1,3 @@
-open Lwt.Infix
open Helper
type params = {
@@ -12,37 +11,35 @@ type params = {
let string_to_follow_id s = s |> int_of_string |> Model.Follow.ID.of_int
let parse_req req =
- let open Httpq.Server in
- let%lwt self_id =
- may_authenticate_account req >|= fun a -> a |> Option.map (fun a -> a#id)
+ let open Yume.Server in
+ let self_id =
+ may_authenticate_account req |> fun a -> a |> Option.map (fun a -> a#id)
in
let id = req |> param ":id" |> int_of_string |> Model.Account.ID.of_int in
- let%lwt limit = req |> query ~default:"40" "limit" >|= int_of_string in
+ let limit = req |> query ~default:"40" "limit" |> int_of_string in
let limit = min limit 80 in
- let%lwt max_id =
- req |> query_opt "max_id" >|= Option.map string_to_follow_id
+ let max_id = req |> query_opt "max_id" |> Option.map string_to_follow_id in
+ let since_id =
+ req |> query_opt "since_id" |> Option.map string_to_follow_id
in
- let%lwt since_id =
- req |> query_opt "since_id" >|= Option.map string_to_follow_id
- in
- Lwt.return { id; self_id; max_id; since_id; limit }
+ { id; self_id; max_id; since_id; limit }
let respond_account_list accts =
accts
|> List.map (fun (a : Db.Account.t) -> a#id)
|> Entity.load_accounts_from_db
- >|= List.map Entity.yojson_of_account
- >|= (fun l -> `List l)
- >>= respond_yojson
+ |> List.map Entity.yojson_of_account
+ |> (fun l -> `List l)
+ |> respond_yojson
-let get_following req =
+let get_following _ req =
(* FIXME: Return Link header for pagination *)
- let%lwt { id; self_id; max_id; since_id; limit } = parse_req req in
+ let { id; self_id; max_id; since_id; limit } = parse_req req in
Db.(e @@ get_following ~id ~self_id ~max_id ~since_id ~limit)
- >>= respond_account_list
+ |> respond_account_list
-let get_followers req =
+let get_followers _ req =
(* FIXME: Return Link header for pagination *)
- let%lwt { id; self_id; max_id; since_id; limit } = parse_req req in
+ let { id; self_id; max_id; since_id; limit } = parse_req req in
Db.(e @@ get_followers ~id ~self_id ~max_id ~since_id ~limit)
- >>= respond_account_list
+ |> respond_account_list
diff --git a/lib/controller/api_v1/accounts/lookup.ml b/lib/controller/api_v1/accounts/lookup.ml
index ffad2d2..3e9f416 100644
--- a/lib/controller/api_v1/accounts/lookup.ml
+++ b/lib/controller/api_v1/accounts/lookup.ml
@@ -1,15 +1,12 @@
open Entity
open Helper
-open Lwt.Infix
-let parse_req req = req |> Httpq.Server.query "acct" >|= parse_webfinger_address
+let parse_req req = req |> Yume.Server.query "acct" |> parse_webfinger_address
-let get req =
- let%lwt username, domain = parse_req req in
- let%lwt a =
- match%lwt Db.e (Model.Account.get_one ~domain ~username) with
- | a -> Lwt.return a
- | exception Sqlx.Error.NoRowFound ->
- Httpq.Server.raise_error_response `Not_found
+let get _ req =
+ let username, domain = parse_req req in
+ let a =
+ try Db.e (Model.Account.get_one ~domain ~username)
+ with Sqlx.Error.NoRowFound -> Yume.Server.raise_error_response `Not_found
in
- make_account_from_model a >|= yojson_of_account >>= respond_yojson
+ make_account_from_model a |> yojson_of_account |> respond_yojson
diff --git a/lib/controller/api_v1/accounts/relationships.ml b/lib/controller/api_v1/accounts/relationships.ml
index ab0d0ae..ff20199 100644
--- a/lib/controller/api_v1/accounts/relationships.ml
+++ b/lib/controller/api_v1/accounts/relationships.ml
@@ -1,18 +1,17 @@
open Entity
-open Lwt.Infix
open Helper
-let get req =
- let%lwt self = authenticate_account req in
- let%lwt account_ids =
+let get _ req =
+ let self = authenticate_account req in
+ let account_ids =
req
- |> Httpq.Server.query_many "id"
- >|= List.map (fun s -> s |> int_of_string |> Model.Account.ID.of_int)
+ |> Yume.Server.query_many "id"
+ |> List.map (fun s -> s |> int_of_string |> Model.Account.ID.of_int)
in
account_ids
- |> Lwt_list.map_p (fun account_id ->
+ |> List.map (fun account_id ->
Db.e (Model.Account.get_one ~id:account_id)
- >>= make_relationship_from_model self)
- >|= List.map yojson_of_relationship
- >|= (fun l -> `List l)
- >>= respond_yojson
+ |> make_relationship_from_model self)
+ |> List.map yojson_of_relationship
+ |> (fun l -> `List l)
+ |> respond_yojson
diff --git a/lib/controller/api_v1/accounts/root.ml b/lib/controller/api_v1/accounts/root.ml
index 8932ac8..0bb99ea 100644
--- a/lib/controller/api_v1/accounts/root.ml
+++ b/lib/controller/api_v1/accounts/root.ml
@@ -1,12 +1,11 @@
open Entity
open Helper
-open Lwt.Infix
-let get req =
+let get _ req =
let id =
- req |> Httpq.Server.param ":id" |> int_of_string |> Model.Account.ID.of_int
+ req |> Yume.Server.param ":id" |> int_of_string |> Model.Account.ID.of_int
in
- match%lwt Db.e (Model.Account.get_one ~id) with
+ match Db.e (Model.Account.get_one ~id) with
| exception Sqlx.Error.NoRowFound ->
- Httpq.Server.raise_error_response `Not_found
- | a -> make_account_from_model a >|= yojson_of_account >>= respond_yojson
+ Yume.Server.raise_error_response `Not_found
+ | a -> make_account_from_model a |> yojson_of_account |> respond_yojson
diff --git a/lib/controller/api_v1/accounts/search.ml b/lib/controller/api_v1/accounts/search.ml
index 9ee8f38..5de1b83 100644
--- a/lib/controller/api_v1/accounts/search.ml
+++ b/lib/controller/api_v1/accounts/search.ml
@@ -1,4 +1,3 @@
-open Lwt.Infix
open Activity
open Helper
@@ -14,18 +13,16 @@ type entry = {
type t = entry list [@@deriving yojson]
let parse_req req =
- let open Httpq.Server in
- let%lwt resolve =
- req |> query ~default:"false" "resolve" >|= bool_of_string
- in
- req |> query "q" >|= parse_webfinger_address >|= fun (username, domain) ->
+ let open Yume.Server in
+ let resolve = req |> query ~default:"false" "resolve" |> bool_of_string in
+ let username, domain = req |> query "q" |> parse_webfinger_address in
(resolve, username, domain)
-let get req =
- let%lwt _ = authenticate_bearer req in
- let%lwt _resolve, username, domain = parse_req req in
- try%lwt
- let%lwt acc = search_account (`Webfinger (domain, username)) in
+let get env req =
+ let _ = authenticate_bearer req in
+ let _resolve, username, domain = parse_req req in
+ try
+ let acc = search_account env (`Webfinger (domain, username)) in
let acct =
match acc#domain with
| None -> username
@@ -37,5 +34,5 @@ let get req =
~username ~acct ~display_name:acc#display_name
in
[ ent ] |> yojson_of_t |> Yojson.Safe.to_string
- |> Httpq.Server.respond ~headers:[ Helper.content_type_app_json ]
- with _ -> Httpq.Server.raise_error_response `Not_found
+ |> Yume.Server.respond ~headers:[ Helper.content_type_app_json ]
+ with _ -> Yume.Server.raise_error_response `Not_found
diff --git a/lib/controller/api_v1/accounts/statuses.ml b/lib/controller/api_v1/accounts/statuses.ml
index 5cb6782..f4a2d08 100644
--- a/lib/controller/api_v1/accounts/statuses.ml
+++ b/lib/controller/api_v1/accounts/statuses.ml
@@ -1,4 +1,3 @@
-open Lwt.Infix
open Helper
type params = {
@@ -11,37 +10,37 @@ type params = {
}
let parse_req req =
- let open Httpq.Server in
- let%lwt self_id =
- may_authenticate_account req >|= fun a -> a |> Option.map (fun a -> a#id)
+ let open Yume.Server in
+ let self_id =
+ may_authenticate_account req |> fun a -> a |> Option.map (fun a -> a#id)
in
let id = req |> param ":id" |> int_of_string |> Model.Account.ID.of_int in
- let%lwt limit = req |> query ~default:"20" "limit" >|= int_of_string in
+ let limit = req |> query ~default:"20" "limit" |> int_of_string in
let limit = min limit 40 in
- let%lwt max_id =
+ let max_id =
req |> query_opt "max_id"
- >|= Option.map (fun s -> s |> int_of_string |> Model.Status.ID.of_int)
+ |> Option.map (fun s -> s |> int_of_string |> Model.Status.ID.of_int)
in
- let%lwt since_id =
+ let since_id =
req |> query_opt "since_id"
- >|= Option.map (fun s -> s |> int_of_string |> Model.Status.ID.of_int)
+ |> Option.map (fun s -> s |> int_of_string |> Model.Status.ID.of_int)
in
- let%lwt exclude_replies =
+ let exclude_replies =
req
|> query_opt "exclude_replies"
- >|= Option.map bool_of_string
- >|= Option.value ~default:false
+ |> Option.map bool_of_string
+ |> Option.value ~default:false
in
- Lwt.return { id; self_id; max_id; since_id; limit; exclude_replies }
+ { id; self_id; max_id; since_id; limit; exclude_replies }
-let get req =
- let%lwt { self_id; id; limit; max_id; since_id; exclude_replies } =
+let get _ req =
+ let { self_id; id; limit; max_id; since_id; exclude_replies } =
parse_req req
in
- let%lwt result =
+ let result =
Db.(e @@ account_statuses ~id ~limit ~max_id ~since_id ~exclude_replies)
- >|= List.map (fun (s : Db.Status.t) -> s#id)
- >>= Entity.load_statuses_from_db ?self_id
+ |> List.map (fun (s : Db.Status.t) -> s#id)
+ |> Entity.load_statuses_from_db ?self_id
in
let headers =
match result with
diff --git a/lib/controller/api_v1/accounts/unfollow.ml b/lib/controller/api_v1/accounts/unfollow.ml
index 3598d0e..878059a 100644
--- a/lib/controller/api_v1/accounts/unfollow.ml
+++ b/lib/controller/api_v1/accounts/unfollow.ml
@@ -1,12 +1,11 @@
open Entity
-open Lwt.Infix
open Helper
open Util
-let service (self : Db.Account.t) (acc : Db.Account.t) (f : Db.Follow.t) =
- Db.(e @@ Follow.delete [ f ]);%lwt
+let service env (self : Db.Account.t) (acc : Db.Account.t) (f : Db.Follow.t) =
+ Db.(e @@ Follow.delete [ f ]);
match acc#domain with
- | None -> Lwt.return_unit
+ | None -> ()
| Some _ ->
(* Remote account *)
let open Activity in
@@ -20,25 +19,24 @@ let service (self : Db.Account.t) (acc : Db.Account.t) (f : Db.Follow.t) =
~actor:(`String self#uri) ~obj ()
|> undo
in
- Worker.Delivery.kick ~activity ~src:self ~url:acc#inbox_url
+ Worker.Delivery.kick env ~activity ~src:self ~url:acc#inbox_url
(* Recv POST /api/v1/accounts/:id/unfollow *)
-let post req =
- let%lwt self = authenticate_account req in
- let id = req |> Httpq.Server.param ":id" |> string_to_account_id in
+let post env req =
+ let self = authenticate_account req in
+ let id = req |> Yume.Server.param ":id" |> string_to_account_id in
(* Check if accounts are valid *)
- let%lwt acc = Db.e (Model.Account.get_one ~id) in
+ let acc = Db.e (Model.Account.get_one ~id) in
(* Check if followed *)
- let%lwt f =
- Db.(
- e @@ Follow.get_one ~account_id:self#id ~target_account_id:id
- |> maybe_no_row)
+ let f =
+ try Some Db.(e @@ Follow.get_one ~account_id:self#id ~target_account_id:id)
+ with Sqlx.Error.NoRowFound -> None
in
(* If valid, send Undo of Follow to the server *)
- if%lwt Lwt.return (f <> None) then service self acc (Option.get f);%lwt
+ if f <> None then service env self acc (Option.get f);
(* Return the result to the client *)
make_relationship_from_model self acc
- >|= yojson_of_relationship >>= respond_yojson
+ |> yojson_of_relationship |> respond_yojson
diff --git a/lib/controller/api_v1/accounts/update_credentials.ml b/lib/controller/api_v1/accounts/update_credentials.ml
index 18cc931..7a5a1be 100644
--- a/lib/controller/api_v1/accounts/update_credentials.ml
+++ b/lib/controller/api_v1/accounts/update_credentials.ml
@@ -1,50 +1,51 @@
open Entity
open Helper
-open Lwt.Infix
open Util
-let patch req =
- let%lwt self = authenticate_account req in
+let patch env req =
+ let self = authenticate_account req in
(* FIXME: support more *)
req
- |> Httpq.Server.query_opt "display_name"
- >|= Option.value ~default:self#display_name
- >|= self#set_display_name;%lwt
+ |> Yume.Server.query_opt "display_name"
+ |> Option.value ~default:self#display_name
+ |> self#set_display_name;
req
- |> Httpq.Server.query_opt "note"
- >|= Option.value ~default:self#note
- >|= self#set_note;%lwt
+ |> Yume.Server.query_opt "note"
+ |> Option.value ~default:self#note
+ |> self#set_note;
(req
- |> Httpq.Server.query_opt "bot"
- >|= Option.value ~default:(Model.Account.is_bot self |> string_of_bool)
- >|= function
+ |> Yume.Server.query_opt "bot"
+ |> Option.value ~default:(Model.Account.is_bot self |> string_of_bool)
+ |> function
| "true" -> self#set_actor_type (Some `Service)
| "false" -> self#set_actor_type (Some `Person)
- | _ -> raise_error_response `Bad_request);%lwt
+ | _ -> raise_error_response `Bad_request);
(* Avatar *)
- Lwt_unix.mkpath (Config.account_avatar_dir ()) 0o755;%lwt
- Httpq.Server.formdata "avatar" req
- |> Lwt_result.iter (fun formdata ->
- let%lwt _, file_name, _ =
+ Eio.Path.mkdirs ~exists_ok:true ~perm:0o755
+ Eio.Path.(env#fs / Config.account_avatar_dir ());
+ Yume.Server.formdata "avatar" req
+ |> Result.iter (fun formdata ->
+ let _, file_name, _ =
+ Lwt_eio.run_lwt @@ fun () ->
Image.save_formdata ~outdir:(Config.account_avatar_dir ()) formdata
in
let file_url = Config.account_avatar_url file_name in
- self#set_avatar_remote_url (Some file_url);
- Lwt.return_unit);%lwt
+ self#set_avatar_remote_url (Some file_url));
(* Header *)
- Lwt_unix.mkpath (Config.account_header_dir ()) 0o755;%lwt
- Httpq.Server.formdata "header" req
- |> Lwt_result.iter (fun formdata ->
- let%lwt _, file_name, _ =
+ Eio.Path.mkdirs ~exists_ok:true ~perm:0o755
+ Eio.Path.(env#fs / Config.account_header_dir ());
+ Yume.Server.formdata "header" req
+ |> Result.iter (fun formdata ->
+ let _, file_name, _ =
+ Lwt_eio.run_lwt @@ fun () ->
Image.save_formdata ~outdir:(Config.account_header_dir ()) formdata
in
let file_url = Config.account_header_url file_name in
- self#set_header_remote_url file_url;
- Lwt.return_unit);%lwt
+ self#set_header_remote_url file_url);
- let%lwt a = Db.(e @@ Account.update [ self ]) >|= List.hd in
- Worker.Account_update.kick ~account_id:a#id ~updated_at:a#updated_at;%lwt
- make_credential_account_from_model a >|= yojson_of_account >>= respond_yojson
+ let a = Db.(e @@ Account.update [ self ]) |> List.hd in
+ Worker.Account_update.kick env ~account_id:a#id ~updated_at:a#updated_at;
+ make_credential_account_from_model a |> yojson_of_account |> respond_yojson
diff --git a/lib/controller/api_v1/accounts/verify_credentials.ml b/lib/controller/api_v1/accounts/verify_credentials.ml
index 467a94f..d834771 100644
--- a/lib/controller/api_v1/accounts/verify_credentials.ml
+++ b/lib/controller/api_v1/accounts/verify_credentials.ml
@@ -1,8 +1,6 @@
open Entity
-open Lwt.Infix
open Helper
-let get req =
- let%lwt self = authenticate_account req in
- make_credential_account_from_model self
- >|= yojson_of_account >>= respond_yojson
+let get _ req =
+ let self = authenticate_account req in
+ make_credential_account_from_model self |> yojson_of_account |> respond_yojson
diff --git a/lib/controller/api_v1/apps/root.ml b/lib/controller/api_v1/apps/root.ml
index 0c56663..fb4fca0 100644
--- a/lib/controller/api_v1/apps/root.ml
+++ b/lib/controller/api_v1/apps/root.ml
@@ -9,12 +9,12 @@ type res = {
}
[@@deriving make, yojson]
-let post req =
- let%lwt client_name = req |> Httpq.Server.query "client_name" in
- let%lwt redirect_uris = req |> Httpq.Server.query "redirect_uris" in
- let%lwt scopes = req |> Httpq.Server.query ~default:"read" "scopes" in
+let post _ req =
+ let client_name = req |> Yume.Server.query "client_name" in
+ let redirect_uris = req |> Yume.Server.query "redirect_uris" in
+ let scopes = req |> Yume.Server.query ~default:"read" "scopes" in
- let%lwt app =
+ let app =
Oauth_helper.generate_application ~name:client_name
~redirect_uri:redirect_uris ~scopes
in
@@ -25,4 +25,4 @@ let post req =
~vapid_key:(Config.vapid_public_key ())
()
|> yojson_of_res |> Yojson.Safe.to_string
- |> Httpq.Server.respond ~headers:[ Helper.content_type_app_json ]
+ |> Yume.Server.respond ~headers:[ Helper.content_type_app_json ]
diff --git a/lib/controller/api_v1/apps/verify_credentials.ml b/lib/controller/api_v1/apps/verify_credentials.ml
index 36335fd..926f9c5 100644
--- a/lib/controller/api_v1/apps/verify_credentials.ml
+++ b/lib/controller/api_v1/apps/verify_credentials.ml
@@ -1,9 +1,9 @@
type res = { name : string } [@@deriving make, yojson]
-let get req =
- let%lwt token = Helper.authenticate_bearer req in
- let%lwt app =
+let get _ req =
+ let token = Helper.authenticate_bearer req in
+ let app =
Db.(e OAuthApplication.(get_one ~id:(Option.get token#application_id)))
in
make_res ~name:app#name |> yojson_of_res |> Yojson.Safe.to_string
- |> Httpq.Server.respond
+ |> Yume.Server.respond
diff --git a/lib/controller/api_v1/instance.ml b/lib/controller/api_v1/instance.ml
index e523e1d..efc3234 100644
--- a/lib/controller/api_v1/instance.ml
+++ b/lib/controller/api_v1/instance.ml
@@ -23,7 +23,7 @@ type v1_instance = {
}
[@@deriving make, yojson]
-let get _req =
+let get _ _req =
let uri = Config.server_name () in
let streaming_api = "wss://" ^ uri in
make_v1_instance ~uri ~title:"Waq"
@@ -32,4 +32,4 @@ let get _req =
~version:"0.0.1"
~urls:(make_v1_instance_urls ~streaming_api)
|> yojson_of_v1_instance |> Yojson.Safe.to_string
- |> Httpq.Server.respond ~headers:[ Helper.content_type_app_json ]
+ |> Yume.Server.respond ~headers:[ Helper.content_type_app_json ]
diff --git a/lib/controller/api_v1/markers.ml b/lib/controller/api_v1/markers.ml
index 4c08b26..276b057 100644
--- a/lib/controller/api_v1/markers.ml
+++ b/lib/controller/api_v1/markers.ml
@@ -9,39 +9,41 @@ let serialize_markers xs =
|> fun j -> (timeline, j))
|> fun j -> `Assoc j
-let get req =
- let%lwt user = authenticate_user req in
- Httpq.Server.query_many "timeline" req
- >|= List.filter (function "home" | "notifications" -> true | _ -> false)
- >|= List.sort_uniq compare
- >>= Lwt_list.map_p (fun timeline ->
- Db.(
- e Marker.(get_one ~timeline ~user_id:(Some user#id)) |> maybe_no_row)
- >|= fun x ->
- let default =
- Model.Marker.make ~updated_at:(Ptime.now ()) ~last_read_id:0
- ~user_id:user#id ~timeline ()
- in
- (timeline, x |> Option.value ~default))
- >|= serialize_markers >>= respond_yojson
+let get _ req =
+ let user = authenticate_user req in
+ Yume.Server.query_many "timeline" req
+ |> List.filter (function "home" | "notifications" -> true | _ -> false)
+ |> List.sort_uniq compare
+ |> List.map (fun timeline ->
+ let x =
+ try Some Db.(e Marker.(get_one ~timeline ~user_id:(Some user#id)))
+ with Sqlx.Error.NoRowFound -> None
+ in
+ let default =
+ Model.Marker.make ~updated_at:(Ptime.now ()) ~last_read_id:0
+ ~user_id:user#id ~timeline ()
+ in
+ (timeline, x |> Option.value ~default))
+ |> serialize_markers |> respond_yojson
-let post req =
- let%lwt user = authenticate_user req in
- let%lwt home_last_read_id, noti_last_read_id =
- Httpq.Server.body req >|= Yojson.Safe.from_string >|= expect_assoc
- >|= List.fold_left
- (fun (home, noti) -> function
- | "home", `Assoc [ ("last_read_id", `String id) ] ->
- (Some (int_of_string id), noti)
- | "notifications", `Assoc [ ("last_read_id", `String id) ] ->
- (home, Some (int_of_string id))
- | _ -> raise_error_response `Bad_request)
- (None, None)
+let post _ req =
+ let user = authenticate_user req in
+ let home_last_read_id, noti_last_read_id =
+ Yume.Server.body req |> Yojson.Safe.from_string |> expect_assoc
+ |> List.fold_left
+ (fun (home, noti) -> function
+ | "home", `Assoc [ ("last_read_id", `String id) ] ->
+ (Some (int_of_string id), noti)
+ | "notifications", `Assoc [ ("last_read_id", `String id) ] ->
+ (home, Some (int_of_string id))
+ | _ -> raise_error_response `Bad_request)
+ (None, None)
in
let home_marker = ref None in
let noti_marker = ref None in
- let%lwt result =
+ let result =
+ Lwt_eio.run_lwt @@ fun () ->
Db.(
transaction @@ fun c ->
let aux last_read_id_opt timeline out_ref =
diff --git a/lib/controller/api_v1/notifications/root.ml b/lib/controller/api_v1/notifications/root.ml
index 3eb0363..cbb16fd 100644
--- a/lib/controller/api_v1/notifications/root.ml
+++ b/lib/controller/api_v1/notifications/root.ml
@@ -1,5 +1,4 @@
open Helper
-open Lwt.Infix
type params = {
self_id : Model.Account.ID.t;
@@ -12,24 +11,24 @@ let string_to_notification_id s =
s |> int_of_string |> Model.Notification.ID.of_int
let parse_req req =
- let open Httpq.Server in
- let%lwt self_id = authenticate_account req >|= fun a -> a#id in
- let%lwt limit = req |> query ~default:"15" "limit" >|= int_of_string in
+ let open Yume.Server in
+ let self_id = authenticate_account req |> fun a -> a#id in
+ let limit = req |> query ~default:"15" "limit" |> int_of_string in
let limit = min limit 30 in
- let%lwt max_id =
- req |> query_opt "max_id" >|= Option.map string_to_notification_id
+ let max_id =
+ req |> query_opt "max_id" |> Option.map string_to_notification_id
in
- let%lwt since_id =
- req |> query_opt "since_id" >|= Option.map string_to_notification_id
+ let since_id =
+ req |> query_opt "since_id" |> Option.map string_to_notification_id
in
- Lwt.return { self_id; max_id; since_id; limit }
+ { self_id; max_id; since_id; limit }
-let get req =
- let%lwt { self_id; max_id; since_id; limit } = parse_req req in
+let get _ req =
+ let { self_id; max_id; since_id; limit } = parse_req req in
Db.(e @@ get_notifications ~account_id:self_id ~max_id ~since_id ~limit)
- >|= List.map (fun (n : Db.Notification.t) -> n#id)
- >>= Entity.load_notifications_from_db ~self_id
- >|= List.map Entity.yojson_of_notification
- >|= (fun l -> `List l)
- >>= respond_yojson
+ |> List.map (fun (n : Db.Notification.t) -> n#id)
+ |> Entity.load_notifications_from_db ~self_id
+ |> List.map Entity.yojson_of_notification
+ |> (fun l -> `List l)
+ |> respond_yojson
diff --git a/lib/controller/api_v1/push/subscription.ml b/lib/controller/api_v1/push/subscription.ml
index c6b682d..f5b33e2 100644
--- a/lib/controller/api_v1/push/subscription.ml
+++ b/lib/controller/api_v1/push/subscription.ml
@@ -1,28 +1,26 @@
open Helper
-open Lwt.Infix
open Util
let expect_assoc = function `Assoc l -> l | _ -> failwith "expect assoc"
let expect_string = function `String s -> s | _ -> failwith "expect string"
-let get req =
- let%lwt oauth_access_token = authenticate_bearer req in
- match%lwt
- Db.(
- e
- WebPushSubscription.(
- get_one ~access_token_id:(Some oauth_access_token#id))
- |> maybe_no_row)
- with
- | None -> raise_error_response `Not_found
- | Some s ->
- s |> Entity.serialize_web_push_subscription
- |> Entity.yojson_of_web_push_subscription |> respond_yojson
+let get _ req =
+ let oauth_access_token = authenticate_bearer req in
+ let s =
+ try
+ Db.(
+ e
+ WebPushSubscription.(
+ get_one ~access_token_id:(Some oauth_access_token#id)))
+ with Sqlx.Error.NoRowFound -> raise_error_response `Not_found
+ in
+ s |> Entity.serialize_web_push_subscription
+ |> Entity.yojson_of_web_push_subscription |> respond_yojson
-let post req =
- let%lwt oauth_access_token = authenticate_bearer req in
+let post _ req =
+ let oauth_access_token = authenticate_bearer req in
- let%lwt body = Httpq.Server.body req in
+ let body = Yume.Server.body req in
let endpoint, key_p256dh, key_auth =
try
let subscription =
@@ -43,17 +41,14 @@ let post req =
~access_token_id:oauth_access_token#id
?user_id:oauth_access_token#resource_owner_id ()
|> save_one))
- >|= Entity.(
- serialize_web_push_subscription *> yojson_of_web_push_subscription)
- >>= respond_yojson
+ |> Entity.(serialize_web_push_subscription *> yojson_of_web_push_subscription)
+ |> respond_yojson
-let delete req =
+let delete _ req =
let open Model.WebPushSubscription in
- let%lwt oauth_access_token = authenticate_bearer req in
- (try%lwt
- let%lwt s =
- Db.(e @@ get_one ~access_token_id:(Some oauth_access_token#id))
- in
+ let oauth_access_token = authenticate_bearer req in
+ (try
+ let s = Db.(e @@ get_one ~access_token_id:(Some oauth_access_token#id)) in
Db.(e @@ delete [ s ])
- with Sqlx.Error.NoRowFound -> Lwt.return_unit);%lwt
+ with Sqlx.Error.NoRowFound -> ());
respond_yojson (`Assoc [])
diff --git a/lib/controller/api_v1/statuses/context.ml b/lib/controller/api_v1/statuses/context.ml
index 31653d6..7e00e90 100644
--- a/lib/controller/api_v1/statuses/context.ml
+++ b/lib/controller/api_v1/statuses/context.ml
@@ -1,33 +1,32 @@
open Helper
-open Lwt.Infix
type t = { ancestors : Entity.status list; descendants : Entity.status list }
[@@deriving make, yojson_of]
-let get req =
- let%lwt self_id =
- may_authenticate_account req >|= fun a -> a |> Option.map (fun x -> x#id)
+let get _ req =
+ let self_id =
+ may_authenticate_account req |> fun a -> a |> Option.map (fun x -> x#id)
in
let status_id =
- req |> Httpq.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
+ req |> Yume.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
in
- let%lwt ancestors = Db.(e (Status.get_ancestors status_id) |> maybe_no_row) in
- let%lwt descendants =
- Db.(e (Status.get_descendants status_id) |> maybe_no_row)
- in
- match (ancestors, descendants) with
- | None, _ | _, None -> Httpq.Server.raise_error_response `Not_found
- | Some ancestors, Some descendants ->
- let%lwt ancestors =
+ match
+ ( Db.(e (Status.get_ancestors status_id)),
+ Db.(e (Status.get_descendants status_id)) )
+ with
+ | exception Sqlx.Error.NoRowFound ->
+ Yume.Server.raise_error_response `Not_found
+ | ancestors, descendants ->
+ let ancestors =
ancestors
|> List.map (fun (s : Db.Status.t) -> s#id)
|> Entity.load_statuses_from_db ?self_id
in
- let%lwt descendants =
+ let descendants =
descendants
|> List.map (fun (s : Db.Status.t) -> s#id)
|> Entity.load_statuses_from_db ?self_id
in
make ~ancestors ~descendants ()
|> yojson_of_t |> Yojson.Safe.to_string
- |> Httpq.Server.respond ~headers:[ content_type_app_json ]
+ |> Yume.Server.respond ~headers:[ content_type_app_json ]
diff --git a/lib/controller/api_v1/statuses/favourite.ml b/lib/controller/api_v1/statuses/favourite.ml
index dc50d81..4a55dca 100644
--- a/lib/controller/api_v1/statuses/favourite.ml
+++ b/lib/controller/api_v1/statuses/favourite.ml
@@ -1,46 +1,40 @@
open Util
open Helper
open Entity
-open Lwt.Infix
-let post req =
- let%lwt self = authenticate_account req in
+let post env req =
+ let self = authenticate_account req in
let status_id =
- req |> Httpq.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
+ req |> Yume.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
in
- let%lwt status =
- match%lwt
- Db.e (Model.Status.get_one ~id:status_id ~preload:[ `account [] ])
- with
- | exception Sqlx.Error.NoRowFound ->
- Httpq.Server.raise_error_response `Not_found
- | s -> Lwt.return s
+ let status =
+ try Db.e (Model.Status.get_one ~id:status_id ~preload:[ `account [] ])
+ with Sqlx.Error.NoRowFound -> Yume.Server.raise_error_response `Not_found
in
- (match%lwt Db.(e @@ Favourite.get_one ~status_id ~account_id:self#id) with
- | _ -> (* Already favourited *) Lwt.return_unit
- | exception Sqlx.Error.NoRowFound ->
- let now = Ptime.now () in
- let%lwt fav =
- Db.(
- e
- @@ Favourite.(
- make ~created_at:now ~updated_at:now ~account_id:self#id
- ~status_id ()
- |> save_one))
- in
- if%lwt Lwt.return (self#id = status#account_id) then Lwt.return_unit
- else
- let src = self in
- let%lwt dst = Db.e (Model.Account.get_one ~id:status#account_id) in
- if Db.Account.is_remote status#account then
- let%lwt activity = Activity.(like_of_favourite fav >|= like) in
- Worker.Delivery.kick ~activity ~src ~url:dst#inbox_url
- else
- Worker.Local_notify.kick
- ~activity_id:(Model.Favourite.ID.to_int fav#id)
- ~activity_type:`Favourite ~typ:`favourite ~src ~dst);%lwt
+ (try Db.(e @@ Favourite.get_one ~status_id ~account_id:self#id) |> ignore
+ with Sqlx.Error.NoRowFound ->
+ let now = Ptime.now () in
+ let fav =
+ Db.(
+ e
+ @@ Favourite.(
+ make ~created_at:now ~updated_at:now ~account_id:self#id
+ ~status_id ()
+ |> save_one))
+ in
+ if self#id = status#account_id then ()
+ else
+ let src = self in
+ let dst = Db.e (Model.Account.get_one ~id:status#account_id) in
+ if Db.Account.is_remote status#account then
+ let activity = Activity.(like_of_favourite fav |> like) in
+ Worker.Delivery.kick env ~activity ~src ~url:dst#inbox_url
+ else
+ Worker.Local_notify.kick env
+ ~activity_id:(Model.Favourite.ID.to_int fav#id)
+ ~activity_type:`Favourite ~typ:`favourite ~src ~dst);
make_status_from_model ~self_id:self#id status
- >|= yojson_of_status >>= respond_yojson
+ |> yojson_of_status |> respond_yojson
diff --git a/lib/controller/api_v1/statuses/favourited_by.ml b/lib/controller/api_v1/statuses/favourited_by.ml
index f628440..6e6a529 100644
--- a/lib/controller/api_v1/statuses/favourited_by.ml
+++ b/lib/controller/api_v1/statuses/favourited_by.ml
@@ -1,16 +1,15 @@
open Util
open Helper
-open Lwt.Infix
-let get req =
+let get _ req =
let status_id =
- req |> Httpq.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
+ req |> Yume.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
in
- let%lwt accts = Db.(e @@ get_favourited_by ~status_id) in
- let%lwt accts =
+ let accts = Db.(e @@ get_favourited_by ~status_id) in
+ let accts =
accts
|> List.map (fun (a : Db.Account.t) -> a#id)
|> Entity.load_accounts_from_db
- >|= List.map Entity.yojson_of_account
+ |> List.map Entity.yojson_of_account
in
`List accts |> respond_yojson
diff --git a/lib/controller/api_v1/statuses/reblog.ml b/lib/controller/api_v1/statuses/reblog.ml
index e521c0d..c032851 100644
--- a/lib/controller/api_v1/statuses/reblog.ml
+++ b/lib/controller/api_v1/statuses/reblog.ml
@@ -1,54 +1,45 @@
open Util
open Helper
open Entity
-open Lwt.Infix
-let post req =
- let%lwt self = authenticate_account req in
+let post env req =
+ let self = authenticate_account req in
let status_id =
- req |> Httpq.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
+ req |> Yume.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
in
- let%lwt status =
- Db.(
- e @@ Status.get_one ~id:status_id ~preload:[ `account [] ] |> maybe_no_row)
- >|= function
- | Some s -> s
- | None -> Httpq.Server.raise_error_response `Not_found
+ let status =
+ try Db.(e @@ Status.get_one ~id:status_id ~preload:[ `account [] ])
+ with Sqlx.Error.NoRowFound -> Yume.Server.raise_error_response `Not_found
in
- let%lwt status =
+ let status =
match status#reblog_of_id with
- | None -> Lwt.return status
+ | None -> status
| Some id -> Db.e (Model.Status.get_one ~id)
in
- let%lwt s =
- match%lwt
+ let s =
+ try
Db.e
(Model.Status.get_one ~account_id:self#id ~reblog_of_id:(Some status#id))
- with
- | s ->
- (* Already reblogged *)
- Lwt.return s
- | exception Sqlx.Error.NoRowFound ->
- let now = Ptime.now () in
- let%lwt s =
- Db.(
- e
- @@ Status.(
- make ~text:"" ~created_at:now ~updated_at:now ~uri:""
- ~account_id:self#id ~reblog_of_id:status#id ~spoiler_text:""
- ()
- |> save_one_with_uri_and_url))
- in
- Worker.Distribute.kick s;%lwt
- (if s#account_id = status#account_id then Lwt.return_unit
- else if Model.Account.is_remote status#account then Lwt.return_unit
- else
- let%lwt src = Db.e (Model.Account.get_one ~id:s#account_id) in
- let%lwt dst = Db.e (Model.Account.get_one ~id:status#account_id) in
- Worker.Local_notify.kick
- ~activity_id:(Model.Status.ID.to_int s#id)
- ~activity_type:`Status ~typ:`reblog ~src ~dst);%lwt
- Lwt.return s
+ with Sqlx.Error.NoRowFound ->
+ let now = Ptime.now () in
+ let s =
+ Db.(
+ e
+ @@ Status.(
+ make ~text:"" ~created_at:now ~updated_at:now ~uri:""
+ ~account_id:self#id ~reblog_of_id:status#id ~spoiler_text:"" ()
+ |> save_one_with_uri_and_url))
+ in
+ Worker.Distribute.kick env s;
+ (if s#account_id = status#account_id then ()
+ else if Model.Account.is_remote status#account then ()
+ else
+ let src = Db.e (Model.Account.get_one ~id:s#account_id) in
+ let dst = Db.e (Model.Account.get_one ~id:status#account_id) in
+ Worker.Local_notify.kick env
+ ~activity_id:(Model.Status.ID.to_int s#id)
+ ~activity_type:`Status ~typ:`reblog ~src ~dst);
+ s
in
make_status_from_model ~self_id:self#id s
- >|= yojson_of_status >>= Helper.respond_yojson
+ |> yojson_of_status |> Helper.respond_yojson
diff --git a/lib/controller/api_v1/statuses/root.ml b/lib/controller/api_v1/statuses/root.ml
index 711da7f..292f0f1 100644
--- a/lib/controller/api_v1/statuses/root.ml
+++ b/lib/controller/api_v1/statuses/root.ml
@@ -1,38 +1,34 @@
open Entity
open Util
-open Lwt.Infix [@@warning "-33"]
open Helper
(* GET /api/v1/statuses/:id *)
-let get req =
+let get _ req =
let status_id =
- req |> Httpq.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
+ req |> Yume.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
in
- let%lwt self_id =
- may_authenticate_account req >|= fun a -> a |> Option.map (fun x -> x#id)
+ let self_id = may_authenticate_account req |> Option.map (fun x -> x#id) in
+ let s =
+ try Db.(e @@ Status.get_one ~id:status_id)
+ with Sqlx.Error.NoRowFound -> Yume.Server.raise_error_response `Not_found
in
- match%lwt Db.(e @@ Status.get_one ~id:status_id |> maybe_no_row) with
- | None -> Httpq.Server.raise_error_response `Not_found
- | Some s ->
- let%lwt s = make_status_from_model ?self_id s in
- s |> yojson_of_status |> Yojson.Safe.to_string
- |> Httpq.Server.respond ~headers:[ content_type_app_json ]
+ let s = make_status_from_model ?self_id s in
+ s |> yojson_of_status |> Yojson.Safe.to_string
+ |> Yume.Server.respond ~headers:[ content_type_app_json ]
(* Recv POST /api/v1/statuses *)
-let post req =
- let%lwt self = authenticate_account req in
- let%lwt status =
- req |> Httpq.Server.query ~default:"" "status" >|= String.trim
- in
- let%lwt spoiler_text =
- req |> Httpq.Server.query ~default:"" "spoiler_text" >|= String.trim
+let post env req =
+ let self = authenticate_account req in
+ let status = req |> Yume.Server.query ~default:"" "status" |> String.trim in
+ let spoiler_text =
+ req |> Yume.Server.query ~default:"" "spoiler_text" |> String.trim
in
- let%lwt in_reply_to_id =
+ let in_reply_to_id =
req
- |> Httpq.Server.query_opt "in_reply_to_id"
- >|= Option.map (fun s -> s |> int_of_string |> Model.Status.ID.of_int)
+ |> Yume.Server.query_opt "in_reply_to_id"
+ |> Option.map (fun s -> s |> int_of_string |> Model.Status.ID.of_int)
in
- let%lwt media_ids = req |> Httpq.Server.query_many "media_ids" in
+ let media_ids = req |> Yume.Server.query_many "media_ids" in
(* Sanity check *)
(match (status = "", media_ids) with
@@ -40,7 +36,7 @@ let post req =
| _ -> raise_error_response `Unprocessable_entity);
(* Handle media attachments *)
- let%lwt attachments =
+ let attachments =
let ids =
media_ids |> List.map (int_of_string *> Model.MediaAttachment.ID.of_int)
in
@@ -50,22 +46,21 @@ let post req =
raise_error_response `Bad_request;
(* Handle mentions *)
- let%lwt mentioned_accts =
+ let mentioned_accts =
Text_helper.match_mention status
- |> Lwt_list.filter_map_p (fun (_off, _len, username, domain) ->
- try%lwt
- Activity.search_account (`Webfinger (domain, username))
- >|= Option.some
+ |> List.filter_map (fun (_off, _len, username, domain) ->
+ try
+ Some (Activity.search_account env (`Webfinger (domain, username)))
with _ ->
Logq.debug (fun m ->
m "Couldn't find the mentioned account: %s"
(username
^ match domain with None -> "" | Some s -> "@" ^ s));
- Lwt.return_none)
+ None)
in
(* Insert status and mentions *)
- let%lwt s =
+ let s =
Db.(
e
Status.(
@@ -74,39 +69,37 @@ let post req =
~spoiler_text ())))
in
(mentioned_accts
- |> Lwt_list.iter_p @@ fun acct ->
+ |> List.iter @@ fun acct ->
Db.(e Mention.(make ~account_id:acct#id ~status_id:s#id () |> save_one))
- |> ignore_lwt);%lwt
+ |> ignore);
(* Update attachments *)
- ( attachments |> List.map (fun m -> m#with_status_id (Some s#id)) |> fun xs ->
- Db.(e MediaAttachment.(update xs)) |> ignore_lwt );%lwt
+ (let xs = attachments |> List.map (fun m -> m#with_status_id (Some s#id)) in
+ Db.(e MediaAttachment.(update xs)) |> ignore);
(* Deliver the status to others *)
- Worker.Distribute.kick s;%lwt
+ Worker.Distribute.kick env s;
(* Attach preview cards if any *)
- Worker.Link_crawl.kick s#id;%lwt
+ Worker.Link_crawl.kick env s#id;
(* Return the result to the client *)
- let%lwt s = make_status_from_model ~self_id:self#id s in
+ let s = make_status_from_model ~self_id:self#id s in
s |> yojson_of_status |> Yojson.Safe.to_string
- |> Httpq.Server.respond ~headers:[ content_type_app_json ]
+ |> Yume.Server.respond ~headers:[ content_type_app_json ]
-let delete req =
- let%lwt self = authenticate_account req in
+let delete env req =
+ let self = authenticate_account req in
let status_id =
- req |> Httpq.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
+ req |> Yume.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
in
- let%lwt status =
+ let status =
try Db.e (Model.Status.get_one ~id:status_id)
- with Sqlx.Error.NoRowFound -> Httpq.Server.raise_error_response `Not_found
+ with Sqlx.Error.NoRowFound -> Yume.Server.raise_error_response `Not_found
in
if status#account_id <> self#id then raise_error_response `Not_found;
(* We should construct the result BEFORE the removal *)
- let%lwt status_to_be_returned =
- make_status_from_model ~self_id:self#id status
- in
- Worker.Removal.kick ~account_id:self#id ~status_id;%lwt
+ let status_to_be_returned = make_status_from_model ~self_id:self#id status in
+ Worker.Removal.kick env ~account_id:self#id ~status_id;
yojson_of_status status_to_be_returned |> respond_yojson
diff --git a/lib/controller/api_v1/statuses/unfavourite.ml b/lib/controller/api_v1/statuses/unfavourite.ml
index 82efa32..bd8d0d1 100644
--- a/lib/controller/api_v1/statuses/unfavourite.ml
+++ b/lib/controller/api_v1/statuses/unfavourite.ml
@@ -1,35 +1,29 @@
open Helper
open Entity
-open Lwt.Infix
-let post req =
- let%lwt self = authenticate_account req in
+let post env req =
+ let self = authenticate_account req in
let status_id =
- req |> Httpq.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
+ req |> Yume.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
in
- let%lwt status =
- match%lwt
- Db.e (Model.Status.get_one ~id:status_id ~preload:[ `account [] ])
- with
- | exception Sqlx.Error.NoRowFound ->
- Httpq.Server.raise_error_response `Not_found
- | s -> Lwt.return s
+ let status =
+ try Db.e (Model.Status.get_one ~id:status_id ~preload:[ `account [] ])
+ with Sqlx.Error.NoRowFound -> Yume.Server.raise_error_response `Not_found
in
- (match%lwt Db.(e @@ Favourite.get_one ~status_id ~account_id:self#id) with
- | exception Sqlx.Error.NoRowFound ->
- (* Already unfavourited *) Lwt.return_unit
+ (match Db.(e @@ Favourite.get_one ~status_id ~account_id:self#id) with
+ | exception Sqlx.Error.NoRowFound -> (* Already unfavourited *) ()
| fav ->
- Db.(e @@ Favourite.delete [ fav ]);%lwt
- if%lwt Model.Account.is_remote status#account |> Lwt.return then
+ Db.(e @@ Favourite.delete [ fav ]);
+ if Model.Account.is_remote status#account then
let src = self in
- let%lwt dst = Db.e (Model.Account.get_one ~id:status#account_id) in
- let%lwt activity =
+ let dst = Db.e (Model.Account.get_one ~id:status#account_id) in
+ let activity =
Activity.(
- like_of_favourite fav >|= like >|= to_undo ~actor:src#uri >|= undo)
+ like_of_favourite fav |> like |> to_undo ~actor:src#uri |> undo)
in
- Worker.Delivery.kick ~activity ~src ~url:dst#inbox_url);%lwt
+ Worker.Delivery.kick env ~activity ~src ~url:dst#inbox_url);
make_status_from_model ~self_id:self#id status
- >|= yojson_of_status >>= respond_yojson
+ |> yojson_of_status |> respond_yojson
diff --git a/lib/controller/api_v1/statuses/unreblog.ml b/lib/controller/api_v1/statuses/unreblog.ml
index 9732455..bf80f5a 100644
--- a/lib/controller/api_v1/statuses/unreblog.ml
+++ b/lib/controller/api_v1/statuses/unreblog.ml
@@ -1,26 +1,21 @@
open Helper
open Entity
-open Lwt.Infix
-let post req =
- let%lwt self = authenticate_account req in
+let post env req =
+ let self = authenticate_account req in
let status_id =
- req |> Httpq.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
+ req |> Yume.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
in
- try%lwt
- let%lwt status = Db.e (Model.Status.get_one ~id:status_id) in
- let%lwt reblog =
+ try
+ let status = Db.e (Model.Status.get_one ~id:status_id) in
+ let reblog =
Db.(
e
Model.Status.(
- get_one ~reblog_of_id:(Some status_id) ~account_id:self#id)
- |> maybe_no_row)
- >|= function
- | None -> raise_error_response `Not_found
- | Some s -> s
+ get_one ~reblog_of_id:(Some status_id) ~account_id:self#id))
in
- let%lwt entity = make_status_from_model ~self_id:self#id status in
- Worker.Removal.kick ~account_id:self#id ~status_id:reblog#id;%lwt
+ let entity = make_status_from_model ~self_id:self#id status in
+ Worker.Removal.kick env ~account_id:self#id ~status_id:reblog#id;
let entity =
{
entity with
@@ -29,4 +24,4 @@ let post req =
}
in
yojson_of_status entity |> respond_yojson
- with Sqlx.Error.NoRowFound -> Httpq.Server.raise_error_response `Not_found
+ with Sqlx.Error.NoRowFound -> Yume.Server.raise_error_response `Not_found
diff --git a/lib/controller/api_v1/streaming.ml b/lib/controller/api_v1/streaming.ml
index c635204..dbe408a 100644
--- a/lib/controller/api_v1/streaming.ml
+++ b/lib/controller/api_v1/streaming.ml
@@ -1,5 +1,3 @@
-open Lwt.Infix
-
let may_subscribe ~user_id ~stream ~ws_conn subscription_ref =
match !subscription_ref with
| Some _ -> ()
@@ -13,23 +11,23 @@ let may_unsubscribe subscription_ref =
|> Option.iter (fun (key, conn_id) -> Streaming.remove key conn_id);
subscription_ref := None
-let get req =
- let%lwt access_token =
- let open Httpq.Server in
- req |> query_opt "access_token" >|= function
+let get _env req =
+ let access_token =
+ let open Yume.Server in
+ req |> query_opt "access_token" |> function
| Some v -> v
| None -> req |> header `Sec_websocket_protocol
in
- let%lwt stream = req |> Httpq.Server.query_opt "stream" in
+ let stream = req |> Yume.Server.query_opt "stream" in
- let%lwt user_id =
- try%lwt
- Oauth_helper.authenticate_access_token access_token >|= fun token ->
+ let user_id =
+ try
+ Oauth_helper.authenticate_access_token access_token |> fun token ->
Option.get token#resource_owner_id
- with _ -> Httpq.Server.raise_error_response `Unauthorized
+ with _ -> Yume.Server.raise_error_response `Unauthorized
in
- Httpq.Server.websocket req @@ fun ws_conn ->
+ Yume.Server.websocket req @@ fun ws_conn ->
let user_subscription_ref = ref None in
let may_subscribe_user () =
may_subscribe ~user_id ~stream:`User ~ws_conn user_subscription_ref
@@ -39,11 +37,11 @@ let get req =
(match stream with
| None -> ()
| Some "user" -> may_subscribe_user ()
- | _ -> Httpq.Server.raise_error_response `Bad_request);
+ | _ -> Yume.Server.raise_error_response `Bad_request);
let rec loop () =
- match%lwt Httpq.Server.ws_recv ws_conn with
- | None -> Lwt.return_unit (* Closed *)
+ match Yume.Server.ws_recv ws_conn with
+ | None -> () (* Closed *)
| Some json ->
(match
let ev = Yojson.Safe.from_string json |> Yojson.Safe.Util.to_assoc in
@@ -65,4 +63,4 @@ let get req =
());
loop ()
in
- Lwt.finalize loop (fun () -> Lwt.return (may_unsubscribe_user ()))
+ Fun.protect ~finally:may_unsubscribe_user loop
diff --git a/lib/controller/api_v1/timelines/home.ml b/lib/controller/api_v1/timelines/home.ml
index 21caef9..45f2e1e 100644
--- a/lib/controller/api_v1/timelines/home.ml
+++ b/lib/controller/api_v1/timelines/home.ml
@@ -1,28 +1,25 @@
open Helper
-open Lwt.Infix
let parse_req req =
- let open Httpq.Server in
- let%lwt self = authenticate_account req in
- let%lwt limit = req |> query ~default:"20" "limit" >|= int_of_string in
+ let open Yume.Server in
+ let self = authenticate_account req in
+ let limit = req |> query ~default:"20" "limit" |> int_of_string in
let limit = min limit 40 in
- let%lwt max_id =
- req |> query_opt "max_id" >|= Option.map string_to_status_id
+ let max_id = req |> query_opt "max_id" |> Option.map string_to_status_id in
+ let since_id =
+ req |> query_opt "since_id" |> Option.map string_to_status_id
in
- let%lwt since_id =
- req |> query_opt "since_id" >|= Option.map string_to_status_id
- in
- Lwt.return (self#id, max_id, since_id, limit)
+ (self#id, max_id, since_id, limit)
-let get req =
+let get _env req =
(* Parse the request *)
- let%lwt self_id, max_id, since_id, limit = parse_req req in
+ let self_id, max_id, since_id, limit = parse_req req in
(* Retrieve the result from DB *)
- let%lwt result =
+ let result =
Db.(e @@ home_timeline ~id:self_id ~limit ~max_id ~since_id)
- >|= List.map (fun (s : Db.Status.t) -> s#id)
- >>= Entity.load_statuses_from_db ~self_id
+ |> List.map (fun (s : Db.Status.t) -> s#id)
+ |> Entity.load_statuses_from_db ~self_id
in
(* Construct HTTP link header *)
diff --git a/lib/controller/api_v2/media.ml b/lib/controller/api_v2/media.ml
index 2b6ae63..0446fcb 100644
--- a/lib/controller/api_v2/media.ml
+++ b/lib/controller/api_v2/media.ml
@@ -2,12 +2,13 @@ open Helper
open Lwt.Infix
open Util
-let post req =
- let%lwt self = authenticate_account req in
- let%lwt formdata = Httpq.Server.formdata_exn "file" req in
+let post _ req =
+ let self = authenticate_account req in
+ let formdata = Yume.Server.formdata_exn "file" req in
let result_attachment = ref None in
- let%lwt success =
+ let success =
+ Lwt_eio.run_lwt @@ fun () ->
Db.transaction @@ fun c ->
let%lwt attachment =
Model.MediaAttachment.(
diff --git a/lib/controller/api_v2/search.ml b/lib/controller/api_v2/search.ml
index dcc6f4d..f31421a 100644
--- a/lib/controller/api_v2/search.ml
+++ b/lib/controller/api_v2/search.ml
@@ -1,5 +1,4 @@
open Helper
-open Lwt.Infix
open Util
type t = {
@@ -9,71 +8,69 @@ type t = {
}
[@@deriving make, yojson_of]
-let handle_query_accounts resolve q =
+let handle_query_accounts env resolve q =
let re = Regex.e {|^@?([^@]+)(?:@([^@]+))?$|} in
- try%lwt
+ try
match Regex.match_ re q with
| [ [| _; Some { substr = username; _ }; None |] ] -> (
- match%lwt Db.(e Account.(select_by_username_prefix username)) with
+ match Db.(e Account.(select_by_username_prefix username)) with
| [] ->
- Activity.search_account ~resolve (`Webfinger (None, username))
- >|= fun a -> [ a ]
- | xs -> Lwt.return xs)
+ Activity.search_account env ~resolve (`Webfinger (None, username))
+ |> fun a -> [ a ]
+ | xs -> xs)
| [ [| _; Some username; Some domain |] ] ->
- Activity.search_account ~resolve
+ Activity.search_account env ~resolve
(`Webfinger (Some domain.substr, username.substr))
- >|= fun a -> [ a ]
- | _ -> Lwt.return []
- with _ -> Lwt.return []
+ |> fun a -> [ a ]
+ | _ -> []
+ with _ -> []
-let handle_query_uri resolve q =
+let handle_query_uri env resolve q =
let try_search_account uri =
- match%lwt Activity.search_account ~resolve (`Uri uri) with
- | exception e ->
- Logq.debug (fun m ->
- m "try_search_account failed: %s\n%s" (Printexc.to_string e)
- (Printexc.get_backtrace ()));
- Lwt.return_none
- | a -> Lwt.return_some a
+ try Some (Activity.search_account env ~resolve (`Uri uri))
+ with e ->
+ Logq.debug (fun m ->
+ m "try_search_account failed: %s\n%s" (Printexc.to_string e)
+ (Printexc.get_backtrace ()));
+ None
in
let try_fetch_status uri =
- match%lwt Activity.fetch_status ~uri with
- | exception e ->
- Logq.debug (fun m ->
- m "try_fetch_status failed: %s\n%s" (Printexc.to_string e)
- (Printexc.get_backtrace ()));
- Lwt.return_none
- | s -> Lwt.return_some s
+ try Some (Activity.fetch_status env ~uri)
+ with e ->
+ Logq.debug (fun m ->
+ m "try_fetch_status failed: %s\n%s" (Printexc.to_string e)
+ (Printexc.get_backtrace ()));
+ None
in
let list_of_option x = x |> Option.fold ~none:[] ~some:List.singleton in
if
String.(starts_with ~prefix:"http://" q || starts_with ~prefix:"https://" q)
then
- let%lwt a_opt = try_search_account q in
- let%lwt s_opt = if resolve then try_fetch_status q else Lwt.return_none in
- Lwt.return (list_of_option a_opt, list_of_option s_opt)
- else Lwt.return ([], [])
+ let a_opt = try_search_account q in
+ let s_opt = if resolve then try_fetch_status q else None in
+ (list_of_option a_opt, list_of_option s_opt)
+ else ([], [])
-let handle_query resolve q =
+let handle_query env resolve q =
(* FIXME: Support more kinds of queries *)
let q = String.trim q in
- let%lwt a1, s1 = handle_query_uri resolve q in
- let%lwt a2 = handle_query_accounts resolve q in
- let%lwt accounts =
+ let a1, s1 = handle_query_uri env resolve q in
+ let a2 = handle_query_accounts env resolve q in
+ let accounts =
a1 @ a2
|> List.map (fun (a : Db.Account.t) -> a#id)
|> Entity.load_accounts_from_db
in
- let%lwt statuses =
+ let statuses =
s1
|> List.map (fun (s : Db.Status.t) -> s#id)
|> Entity.load_statuses_from_db
in
let hashtags = [] in
- make ~accounts ~statuses ~hashtags () |> Lwt.return
+ make ~accounts ~statuses ~hashtags ()
-let get req =
- let%lwt self = may_authenticate_account req in
- let%lwt q = req |> Httpq.Server.query "q" in
+let get env req =
+ let self = may_authenticate_account req in
+ let q = req |> Yume.Server.query "q" in
Logq.debug (fun m -> m "[/api/v2/search] %b %s" (Option.is_some self) q);
- handle_query (Option.is_some self) q >|= yojson_of_t >>= respond_yojson
+ handle_query env (Option.is_some self) q |> yojson_of_t |> respond_yojson
diff --git a/lib/controller/helper.ml b/lib/controller/helper.ml
index 007fc60..0afa23d 100644
--- a/lib/controller/helper.ml
+++ b/lib/controller/helper.ml
@@ -1,5 +1,4 @@
open Util
-open Lwt.Infix
let app_activity_json = "application/activity+json"
let text_html = "text/html"
@@ -13,10 +12,10 @@ let content_type_app_jrd_json =
let content_type_app_json = (`Content_type, "application/json; charset=utf-8")
let content_type_app_activity_json = (`Content_type, "application/activity+json")
let content_type_text_html = (`Content_type, "text/html; charset=utf-8")
-let raise_error_response = Httpq.Server.raise_error_response
+let raise_error_response = Yume.Server.raise_error_response
let authenticate_bearer = function
- | Httpq.Server.Request r -> (
+ | Yume.Server.Request r -> (
try
let header = r.headers |> List.assoc `Authorization in
assert (String.starts_with ~prefix:"Bearer " header);
@@ -24,23 +23,22 @@ let authenticate_bearer = function
Oauth_helper.authenticate_access_token bearer_token
with _ -> raise_error_response `Unauthorized)
-let authenticate_user (r : Httpq.Server.request) : Model.User.t Lwt.t =
+let authenticate_user (r : Yume.Server.request) : Model.User.t =
try
- let%lwt token = authenticate_bearer r in
+ let token = authenticate_bearer r in
Db.(e User.(get_one ~id:(Option.get token#resource_owner_id)))
with _ -> raise_error_response `Unauthorized
-let authenticate_account (r : Httpq.Server.request) : Model.Account.t Lwt.t =
+let authenticate_account (r : Yume.Server.request) : Model.Account.t =
try
- let%lwt user = authenticate_user r in
+ let user = authenticate_user r in
Db.(e Account.(get_one ~id:user#account_id))
with _ -> raise_error_response `Unauthorized
-let may_authenticate_user r =
- try%lwt authenticate_user r >|= Option.some with _ -> Lwt.return_none
+let may_authenticate_user r = try Some (authenticate_user r) with _ -> None
let may_authenticate_account r =
- try%lwt authenticate_account r >|= Option.some with _ -> Lwt.return_none
+ try Some (authenticate_account r) with _ -> None
let int_of_string s =
match int_of_string_opt s with
@@ -53,19 +51,19 @@ let bool_of_string s =
| Some b -> b
let respond_html ?(headers = []) s =
- Httpq.Server.respond ~headers:(content_type_text_html :: headers) s
+ Yume.Server.respond ~headers:(content_type_text_html :: headers) s
let respond_yojson ?(headers = []) y =
Yojson.Safe.to_string y
- |> Httpq.Server.respond ~headers:(content_type_app_json :: headers)
+ |> Yume.Server.respond ~headers:(content_type_app_json :: headers)
let respond_activity_yojson y =
Yojson.Safe.to_string y
- |> Httpq.Server.respond ~headers:[ content_type_app_activity_json ]
+ |> Yume.Server.respond ~headers:[ content_type_app_activity_json ]
let render ~default routes req =
let accept =
- Httpq.Server.header_opt `Accept req
+ Yume.Server.header_opt `Accept req
|> Option.map (String.split_on_char ',' |.> List.map String.trim)
in
let default = ("default", default) in
@@ -90,7 +88,7 @@ let parse_webfinger_address q =
| _ -> raise_error_response `Bad_request
let raise_if_no_row_found ?(status = `Bad_request) f =
- try%lwt f with Sqlx.Error.NoRowFound -> raise_error_response status
+ try f with Sqlx.Error.NoRowFound -> raise_error_response status
let string_to_status_id s = s |> int_of_string |> Model.Status.ID.of_int
let string_to_account_id s = s |> int_of_string |> Model.Account.ID.of_int
diff --git a/lib/controller/inbox.ml b/lib/controller/inbox.ml
index ab525ab..7b22ec0 100644
--- a/lib/controller/inbox.ml
+++ b/lib/controller/inbox.ml
@@ -2,148 +2,144 @@ open Util
open Activity
(* Recv Follow in inbox *)
-let kick_inbox_follow (req : ap_follow) =
+let kick_inbox_follow env (req : ap_follow) =
let src, dst =
match (req.actor, req.obj) with
| s, d when is_my_domain d -> (s, d)
- | _ -> Httpq.Server.raise_error_response `Bad_request
+ | _ -> Yume.Server.raise_error_response `Bad_request
in
- let%lwt src = search_account (`Uri src) in
- match%lwt Db.e (Model.Account.get_one ~uri:dst) with
- | exception Sqlx.Error.NoRowFound ->
- Httpq.Server.raise_error_response `Bad_request
- | dst ->
- Job.kick ~name:__FUNCTION__ @@ fun () ->
- let%lwt f =
- match%lwt
- Db.(e @@ Follow.get_one ~account_id:src#id ~target_account_id:dst#id)
- with
- | f -> Lwt.return f
- | exception Sqlx.Error.NoRowFound ->
- (* Insert to table 'follows' *)
- let now = Ptime.now () in
- let%lwt f =
- Db.(
- e
- @@ Follow.(
- make ~created_at:now ~updated_at:now ~account_id:src#id
- ~target_account_id:dst#id ~uri:req.id ()
- |> save_one))
- in
- Worker.Local_notify.kick
- ~activity_id:(Model.Follow.ID.to_int f#id)
- ~activity_type:`Follow ~src ~dst ~typ:`follow;%lwt
- Lwt.return f
+ let src = search_account env (`Uri src) in
+ let dst =
+ try Db.e (Model.Account.get_one ~uri:dst)
+ with Sqlx.Error.NoRowFound ->
+ Yume.Server.raise_error_response `Bad_request
+ in
+ Job.kick env ~name:__FUNCTION__ @@ fun () ->
+ let f =
+ try Db.(e @@ Follow.get_one ~account_id:src#id ~target_account_id:dst#id)
+ with Sqlx.Error.NoRowFound ->
+ (* Insert to table 'follows' *)
+ let now = Ptime.now () in
+ let f =
+ Db.(
+ e
+ @@ Follow.(
+ make ~created_at:now ~updated_at:now ~account_id:src#id
+ ~target_account_id:dst#id ~uri:req.id ()
+ |> save_one))
in
+ Worker.Local_notify.kick env
+ ~activity_id:(Model.Follow.ID.to_int f#id)
+ ~activity_type:`Follow ~src ~dst ~typ:`follow;
+ f
+ in
- (* Send 'Accept' *)
- Worker.Accept.kick ~f ~followee:dst ~follower:src
+ (* Send 'Accept' *)
+ Worker.Accept.kick env ~f ~followee:dst ~follower:src
(* Recv Accept in inbox *)
-let kick_inbox_accept (req : ap_accept) =
+let kick_inbox_accept env (req : ap_accept) =
let uri =
match req.obj with
| Follow { id; _ } -> id
- | _ -> Httpq.Server.raise_error_response `Bad_request
+ | _ -> Yume.Server.raise_error_response `Bad_request
in
- match%lwt Db.(e @@ FollowRequest.get_one ~uri) with
- | exception Sqlx.Error.NoRowFound ->
- Httpq.Server.raise_error_response `Bad_request
- | r ->
- Job.kick ~name:__FUNCTION__ @@ fun () ->
- let now = Ptime.now () in
- Db.(e @@ FollowRequest.delete [ r ]) |> ignore_lwt;%lwt
- Db.(
- e
- @@ Follow.(
- make ~account_id:r#account_id
- ~target_account_id:r#target_account_id ~uri ~created_at:now
- ~updated_at:now ()
- |> save_one))
- |> ignore_lwt
+ let r =
+ try Db.(e @@ FollowRequest.get_one ~uri)
+ with Sqlx.Error.NoRowFound ->
+ Yume.Server.raise_error_response `Bad_request
+ in
+ Job.kick env ~name:__FUNCTION__ @@ fun () ->
+ let now = Ptime.now () in
+ Db.(e @@ FollowRequest.delete [ r ]) |> ignore;
+ Db.(
+ e
+ @@ Follow.(
+ make ~account_id:r#account_id ~target_account_id:r#target_account_id
+ ~uri ~created_at:now ~updated_at:now ()
+ |> save_one))
+ |> ignore
-let kick_inbox_undo_like (l : ap_like) =
- Job.kick ~name:__FUNCTION__ @@ fun () ->
- let%lwt fav = favourite_of_like ~must_already_exist:true l in
+let kick_inbox_undo_like env (l : ap_like) =
+ Job.kick env ~name:__FUNCTION__ @@ fun () ->
+ let fav = favourite_of_like ~must_already_exist:true l in
Db.(e @@ Favourite.delete [ fav ])
-let kick_inbox_undo_follow ({ id; _ } : ap_follow) =
- Job.kick ~name:__FUNCTION__ @@ fun () ->
- let%lwt follow = Db.(e @@ Follow.get_one ~uri:id) in
+let kick_inbox_undo_follow env ({ id; _ } : ap_follow) =
+ Job.kick env ~name:__FUNCTION__ @@ fun () ->
+ let follow = Db.(e @@ Follow.get_one ~uri:id) in
Db.(e @@ Follow.delete [ follow ])
-let kick_inbox_undo_announce (a : ap_announce) =
- Job.kick ~name:__FUNCTION__ @@ fun () ->
- let%lwt account = Db.e (Model.Account.get_one ~uri:a.actor) in
- let%lwt status = Db.(e Status.(get_one ~uri:a.id)) in
- Worker.Removal.kick ~account_id:account#id ~status_id:status#id
+let kick_inbox_undo_announce env (a : ap_announce) =
+ Job.kick env ~name:__FUNCTION__ @@ fun () ->
+ let account = Db.e (Model.Account.get_one ~uri:a.actor) in
+ let status = Db.(e Status.(get_one ~uri:a.id)) in
+ Worker.Removal.kick env ~account_id:account#id ~status_id:status#id
(* Recv Create in inbox *)
-let kick_inbox_create (req : ap_create) =
+let kick_inbox_create env (req : ap_create) =
let note =
match req with
| { obj = Note note; _ } -> note
- | _ -> Httpq.Server.raise_error_response `Bad_request
+ | _ -> Yume.Server.raise_error_response `Bad_request
in
- Job.kick ~name:__FUNCTION__ @@ fun () ->
- let%lwt s = status_of_note note in
- Worker.Link_crawl.kick s#id;%lwt
- Worker.Distribute.kick s
+ Job.kick env ~name:__FUNCTION__ @@ fun () ->
+ let s = status_of_note env note in
+ Worker.Link_crawl.kick env s#id;
+ Worker.Distribute.kick env s
(* Recv Announce in inbox *)
-let kick_inbox_announce (req : ap_announce) =
- Job.kick ~name:__FUNCTION__ @@ fun () ->
- let%lwt s = status_of_announce req in
- Worker.Distribute.kick s;%lwt
- let%lwt s' = Db.e (Model.Status.get_one ~id:(Option.get s#reblog_of_id)) in
- let%lwt dst = Db.e (Model.Account.get_one ~id:s'#account_id) in
+let kick_inbox_announce env (req : ap_announce) =
+ Job.kick env ~name:__FUNCTION__ @@ fun () ->
+ let s = status_of_announce env req in
+ Worker.Distribute.kick env s;
+ let s' = Db.e (Model.Status.get_one ~id:(Option.get s#reblog_of_id)) in
+ let dst = Db.e (Model.Account.get_one ~id:s'#account_id) in
if Model.Account.is_local dst then
- let%lwt src = Db.e (Model.Account.get_one ~id:s#account_id) in
- Worker.Local_notify.kick
+ let src = Db.e (Model.Account.get_one ~id:s#account_id) in
+ Worker.Local_notify.kick env
~activity_id:(Model.Status.ID.to_int s#id)
~activity_type:`Status ~typ:`reblog ~src ~dst
- else Lwt.return_unit
(* Recv Like in inbox *)
-let kick_inbox_like (req : ap_like) =
- Job.kick ~name:__FUNCTION__ @@ fun () ->
- let%lwt f = favourite_of_like req in
- let%lwt src = Db.e (Model.Account.get_one ~id:f#account_id) in
- let%lwt s = Db.e (Model.Status.get_one ~id:f#status_id) in
- let%lwt dst = Db.e (Model.Account.get_one ~id:s#account_id) in
- Worker.Local_notify.kick
+let kick_inbox_like env (req : ap_like) =
+ Job.kick env ~name:__FUNCTION__ @@ fun () ->
+ let f = favourite_of_like req in
+ let src = Db.e (Model.Account.get_one ~id:f#account_id) in
+ let s = Db.e (Model.Status.get_one ~id:f#status_id) in
+ let dst = Db.e (Model.Account.get_one ~id:s#account_id) in
+ Worker.Local_notify.kick env
~activity_id:(Model.Favourite.ID.to_int f#id)
- ~activity_type:`Favourite ~typ:`favourite ~src ~dst;%lwt
- Lwt.return_unit
+ ~activity_type:`Favourite ~typ:`favourite ~src ~dst
-let kick_inbox_delete (req : ap_delete) =
- match%lwt Db.e (Model.Account.get_one ~uri:req.actor) with
+let kick_inbox_delete env (req : ap_delete) =
+ match Db.e (Model.Account.get_one ~uri:req.actor) with
| exception Sqlx.Error.NoRowFound ->
(* Unknown account; just ignore *)
- Lwt.return_unit
+ ()
| account -> (
(* FIXME: Support deletion of accounts *)
match req.obj |> of_yojson |> get_tombstone with
- | (exception _) | None ->
- (* Unknown object; just ignore *) Lwt.return_unit
+ | (exception _) | None -> (* Unknown object; just ignore *) ()
| Some tomb -> (
- match%lwt Db.(e Status.(get_many ~uri:tomb.id)) with
- | [] -> Lwt.return_unit
+ match Db.(e Status.(get_many ~uri:tomb.id)) with
+ | [] -> ()
| [ status ] ->
- Worker.Removal.kick ~account_id:account#id ~status_id:status#id
+ Worker.Removal.kick env ~account_id:account#id
+ ~status_id:status#id
| _ :: _ -> failwith "Internal error: not unique status uri"))
let kick_inbox_update_person (r : ap_person) =
- let%lwt a = Db.e (Model.Account.get_one ~uri:r.id) in
+ let a = Db.e (Model.Account.get_one ~uri:r.id) in
let a = Activity.model_account_of_person ~original:a r in
- Db.(e @@ Account.save_one a) |> ignore_lwt
+ Db.(e @@ Account.save_one a) |> ignore
(* Recv POST /users/:name/inbox *)
-let post req =
- match%lwt Activity.verify_activity_json req with
+let post env req =
+ match Activity.verify_activity_json env req with
| body, Error (`AccountNotFound | `AccountIsLocal) ->
Logq.err (fun m -> m "account not found or account is local: %s" body);
- Httpq.Server.respond ~status:`Accepted ""
+ Yume.Server.respond ~status:`Accepted ""
| body, Error (`VerifFailure e) ->
Logq.err (fun m ->
m "verification failure of activity json: %s: %s"
@@ -151,23 +147,23 @@ let post req =
| `AlgorithmNotImplemented -> "algorithm not implemented"
| `Msg msg -> msg)
body);
- Httpq.Server.respond ~status:`Unauthorized ""
+ Yume.Server.respond ~status:`Unauthorized ""
| body, Ok () -> (
- try%lwt
+ try
(*Logq.debug (fun m -> m ">>>>>>>>\n%s" body);*)
(match Yojson.Safe.from_string body |> of_yojson with
- | Accept r -> kick_inbox_accept r
- | Announce r -> kick_inbox_announce r
- | Create r -> kick_inbox_create r
- | Delete r -> kick_inbox_delete r
- | Follow r -> kick_inbox_follow r
- | Like r -> kick_inbox_like r
- | Undo { obj = Follow v; _ } -> kick_inbox_undo_follow v
- | Undo { obj = Like v; _ } -> kick_inbox_undo_like v
- | Undo { obj = Announce v; _ } -> kick_inbox_undo_announce v
+ | Accept r -> kick_inbox_accept env r
+ | Announce r -> kick_inbox_announce env r
+ | Create r -> kick_inbox_create env r
+ | Delete r -> kick_inbox_delete env r
+ | Follow r -> kick_inbox_follow env r
+ | Like r -> kick_inbox_like env r
+ | Undo { obj = Follow v; _ } -> kick_inbox_undo_follow env v
+ | Undo { obj = Like v; _ } -> kick_inbox_undo_like env v
+ | Undo { obj = Announce v; _ } -> kick_inbox_undo_announce env v
| Update { obj = Person r; _ } -> kick_inbox_update_person r
- | _ -> failwith "activity not implemented");%lwt
- Httpq.Server.respond ~status:`Accepted ""
+ | _ -> failwith "activity not implemented");
+ Yume.Server.respond ~status:`Accepted ""
with e ->
Logq.err (fun m ->
m
@@ -177,4 +173,4 @@ let post req =
%s"
(Printexc.to_string e)
(Printexc.get_backtrace ()));
- Httpq.Server.respond ~status:`Accepted ~tags:[ "log" ] "")
+ Yume.Server.respond ~status:`Accepted ~tags:[ "log" ] "")
diff --git a/lib/controller/nodeinfo.ml b/lib/controller/nodeinfo.ml
index 9831eb4..99852c4 100644
--- a/lib/controller/nodeinfo.ml
+++ b/lib/controller/nodeinfo.ml
@@ -1,6 +1,6 @@
open Helper
-let get_2_0 _req =
+let get_2_0 _ _req =
(* FIXME: Fill in correct values *)
`Assoc
[
diff --git a/lib/controller/oauth/authorize.ml b/lib/controller/oauth/authorize.ml
index d716ebc..a4c10eb 100644
--- a/lib/controller/oauth/authorize.ml
+++ b/lib/controller/oauth/authorize.ml
@@ -1,36 +1,38 @@
open Helper
-let post req =
- let%lwt response_type = req |> Httpq.Server.query "response_type" in
- let%lwt client_id = req |> Httpq.Server.query "client_id" in
- let%lwt redirect_uri = req |> Httpq.Server.query "redirect_uri" in
- let%lwt scope = req |> Httpq.Server.query ~default:"read" "scope" in
- let%lwt state = req |> Httpq.Server.query_opt "state" in
- let%lwt username = req |> Httpq.Server.query "username" in
- let%lwt password = req |> Httpq.Server.query "password" in
+let post _env req =
+ let response_type = req |> Yume.Server.query "response_type" in
+ let client_id = req |> Yume.Server.query "client_id" in
+ let redirect_uri = req |> Yume.Server.query "redirect_uri" in
+ let scope = req |> Yume.Server.query ~default:"read" "scope" in
+ let state = req |> Yume.Server.query_opt "state" in
+ let username = req |> Yume.Server.query "username" in
+ let password = req |> Yume.Server.query "password" in
if response_type <> "code" then raise_error_response `Bad_request;
- let%lwt app = Oauth_helper.authenticate_application client_id in
+ let app = Oauth_helper.authenticate_application client_id in
(* FIXME: Check if scope is correct *)
if redirect_uri <> app#redirect_uri then raise_error_response `Bad_request;
- let%lwt account =
- Db.(e Account.(get_one ~domain:None ~username)) |> raise_if_no_row_found
+ let account =
+ try Db.(e Account.(get_one ~domain:None ~username))
+ with Sqlx.Error.NoRowFound -> raise_error_response `Bad_request
in
- let%lwt user =
- Db.(e User.(get_one ~account_id:account#id)) |> raise_if_no_row_found
+ let user =
+ try Db.(e User.(get_one ~account_id:account#id))
+ with Sqlx.Error.NoRowFound -> raise_error_response `Bad_request
in
if not Bcrypt.(verify password (hash_of_string user#encrypted_password)) then
raise_error_response `Unauthorized;
let resource_owner_id = user#id in
- let%lwt grant =
+ let grant =
Oauth_helper.generate_access_grant ~expires_in:600 ~redirect_uri
~scopes:scope ~app ~resource_owner_id
in
if grant#redirect_uri = "urn:ietf:wg:oauth:2.0:oob" then
- Httpq.Server.respond grant#token
+ Yume.Server.respond grant#token
else
let u = Uri.of_string grant#redirect_uri in
let u = Uri.add_query_param u ("code", [ grant#token ]) in
@@ -39,16 +41,16 @@ let post req =
|> Option.fold ~none:u ~some:(fun s ->
Uri.add_query_param u ("state", [ s ]))
in
- Httpq.Server.respond ~status:`Found
+ Yume.Server.respond ~status:`Found
~headers:[ (`Location, Uri.to_string u) ]
""
-let get req =
- let%lwt response_type = req |> Httpq.Server.query "response_type" in
- let%lwt client_id = req |> Httpq.Server.query "client_id" in
- let%lwt redirect_uri = req |> Httpq.Server.query "redirect_uri" in
- let%lwt scope = req |> Httpq.Server.query ~default:"read" "scope" in
- let%lwt state = req |> Httpq.Server.query_opt "state" in
+let get _ req =
+ let response_type = req |> Yume.Server.query "response_type" in
+ let client_id = req |> Yume.Server.query "client_id" in
+ let redirect_uri = req |> Yume.Server.query "redirect_uri" in
+ let scope = req |> Yume.Server.query ~default:"read" "scope" in
+ let state = req |> Yume.Server.query_opt "state" in
let models =
let open Jingoo.Jg_types in
diff --git a/lib/controller/oauth/token.ml b/lib/controller/oauth/token.ml
index 6ca6665..961de0e 100644
--- a/lib/controller/oauth/token.ml
+++ b/lib/controller/oauth/token.ml
@@ -9,38 +9,38 @@ type res = {
}
[@@deriving make, yojson]
-let post req =
- let%lwt grant_type = req |> Httpq.Server.query "grant_type" in
- let%lwt code = req |> Httpq.Server.query_opt "code" in
- let%lwt client_id = req |> Httpq.Server.query "client_id" in
- let%lwt client_secret = req |> Httpq.Server.query "client_secret" in
- let%lwt redirect_uri = req |> Httpq.Server.query "redirect_uri" in
- let%lwt scope = req |> Httpq.Server.query ~default:"read" "scope" in
+let post _ req =
+ let grant_type = req |> Yume.Server.query "grant_type" in
+ let code = req |> Yume.Server.query_opt "code" in
+ let client_id = req |> Yume.Server.query "client_id" in
+ let client_secret = req |> Yume.Server.query "client_secret" in
+ let redirect_uri = req |> Yume.Server.query "redirect_uri" in
+ let scope = req |> Yume.Server.query ~default:"read" "scope" in
- let%lwt token =
+ let token =
match (grant_type, code) with
| "authorization_code", Some code ->
- let%lwt grant = Oauth_helper.authenticate_access_grant code in
+ let grant = Oauth_helper.authenticate_access_grant code in
(* FIXME: Check if scope is correct *)
- let%lwt app =
+ let app =
Db.(
e OAuthApplication.(get_one ~id:(Option.get grant#application_id)))
in
if app#redirect_uri <> redirect_uri then
- Httpq.Server.raise_error_response `Bad_request;
+ Yume.Server.raise_error_response `Bad_request;
if app#uid <> client_id || app#secret <> client_secret then
- Httpq.Server.raise_error_response `Unauthorized;
+ Yume.Server.raise_error_response `Unauthorized;
if
let open Ptime in
grant#expires_in
< (diff (now ()) grant#created_at |> Span.to_int_s |> Option.get)
- then Httpq.Server.raise_error_response `Bad_request;
+ then Yume.Server.raise_error_response `Bad_request;
Oauth_helper.generate_access_token ~scopes:scope
~resource_owner_id:(Option.get grant#resource_owner_id)
~app ()
| "client_credentials", None ->
- let%lwt app = Db.(e OAuthApplication.(get_one ~uid:client_id)) in
+ let app = Db.(e OAuthApplication.(get_one ~uid:client_id)) in
if app#secret <> client_secret then raise_error_response `Unauthorized;
Oauth_helper.generate_access_token ~scopes:scope ~app ()
| _ -> raise_error_response `Bad_request
@@ -50,4 +50,4 @@ let post req =
~created_at:
(token#created_at |> Ptime.to_span |> Ptime.Span.to_int_s |> Option.get)
|> yojson_of_res |> Yojson.Safe.to_string
- |> Httpq.Server.respond ~headers:[ Helper.content_type_app_json ]
+ |> Yume.Server.respond ~headers:[ Helper.content_type_app_json ]
diff --git a/lib/controller/root.ml b/lib/controller/root.ml
index d2b294d..17fcddd 100644
--- a/lib/controller/root.ml
+++ b/lib/controller/root.ml
@@ -1,6 +1,6 @@
open Helper
-let get _req =
+let get _ _req =
let open Jingoo.Jg_types in
let models = [ ("server_name", Tstr (Config.server_name ())) ] in
{|
diff --git a/lib/controller/static.ml b/lib/controller/static.ml
index 992d676..6dc1a5d 100644
--- a/lib/controller/static.ml
+++ b/lib/controller/static.ml
@@ -15,16 +15,16 @@ let get_body path =
s
with _ -> raise_error_response `Not_found
-let get req =
+let get _ req =
let root = Config.static_root () |> Unix.realpath in
let path =
- try Filename.concat root (Httpq.Server.path req) |> Unix.realpath
+ try Filename.concat root (Yume.Server.path req) |> Unix.realpath
with Unix.Unix_error (Unix.ENOENT, "realpath", _) ->
raise_error_response `Not_found
in
if not (String.starts_with ~prefix:root path) then
raise_error_response `Not_found
else
- Httpq.Server.respond
+ Yume.Server.respond
~headers:[ (`Content_type, Filename.extension path |> get_content_type) ]
(get_body path)
diff --git a/lib/controller/users/following.ml b/lib/controller/users/following.ml
index 17313a7..7439e66 100644
--- a/lib/controller/users/following.ml
+++ b/lib/controller/users/following.ml
@@ -1,24 +1,24 @@
open Util
open Helper
-let get_followers req =
+let get_followers _env req =
(* FIXME: Support ?page and ?min_id *)
- let username = Httpq.Server.param ":name" req in
- let%lwt acct = Db.e (Model.Account.get_one ~username ~domain:None) in
+ let username = Yume.Server.param ":name" req in
+ let acct = Db.e (Model.Account.get_one ~username ~domain:None) in
let id = acct#followers_url in
- let%lwt totalItems = Db.(e @@ count_followers ~account_id:acct#id) in
+ let totalItems = Db.(e @@ count_followers ~account_id:acct#id) in
let first = acct#followers_url ^ "?page=1" in
Activity.(
make_ordered_collection ~id ~totalItems ~first ()
|> ordered_collection |> to_yojson)
|> respond_yojson
-let get_following req =
+let get_following _env req =
(* FIXME: Support ?page and ?min_id *)
- let username = Httpq.Server.param ":name" req in
- let%lwt acct = Db.e (Model.Account.get_one ~username ~domain:None) in
+ let username = Yume.Server.param ":name" req in
+ let acct = Db.e (Model.Account.get_one ~username ~domain:None) in
let id = acct#uri ^/ "following" in
- let%lwt totalItems = Db.(e @@ count_following ~account_id:acct#id) in
+ let totalItems = Db.(e @@ count_following ~account_id:acct#id) in
let first = id ^ "?page=1" in
Activity.(
make_ordered_collection ~id ~totalItems ~first ()
diff --git a/lib/controller/users/outbox.ml b/lib/controller/users/outbox.ml
index 3be40e5..668a06a 100644
--- a/lib/controller/users/outbox.ml
+++ b/lib/controller/users/outbox.ml
@@ -1,11 +1,11 @@
open Helper
-let get req =
+let get _ req =
(* FIXME: Support ?page and ?min_id *)
- let username = Httpq.Server.param ":name" req in
- let%lwt acct = Db.e (Model.Account.get_one ~username ~domain:None) in
+ let username = Yume.Server.param ":name" req in
+ let acct = Db.e (Model.Account.get_one ~username ~domain:None) in
let id = acct#outbox_url in
- let%lwt totalItems = Db.(e @@ Status.count ~account_id:(`Eq acct#id)) in
+ let totalItems = Db.(e @@ Status.count ~account_id:(`Eq acct#id)) in
let first = acct#outbox_url ^ "?page=true" in
let last = acct#outbox_url ^ "?min_id=0&page=true" in
Activity.(
diff --git a/lib/controller/users/root.ml b/lib/controller/users/root.ml
index 30fcd19..6888aa4 100644
--- a/lib/controller/users/root.ml
+++ b/lib/controller/users/root.ml
@@ -1,5 +1,4 @@
open Helper
-open Lwt.Infix
open Util
let respond_activity a () =
@@ -8,13 +7,13 @@ let respond_activity a () =
let respond_html (a : Db.Account.t) () =
let open Jingoo.Jg_types in
- let%lwt statuses =
+ let statuses =
Db.(
e
@@ account_statuses ~id:a#id ~limit:30 ~max_id:None ~since_id:None
~exclude_replies:false)
- >|= List.map (fun (s : Db.Status.t) -> s#id)
- >>= Entity.load_statuses_from_db
+ |> List.map (fun (s : Db.Status.t) -> s#id)
+ |> Entity.load_statuses_from_db
in
let status_to_Tobj (s : Entity.status) =
let rec aux (s : Entity.status) =
@@ -78,13 +77,13 @@ let respond_html (a : Db.Account.t) () =
|> String.trim |> respond_html
(* Recv GET /users/:name *)
-let get req =
- let username = req |> Httpq.Server.param ":name" in
- match%lwt Db.e (Model.Account.get_one ~domain:None ~username) with
- | exception Sqlx.Error.NoRowFound ->
- Httpq.Server.raise_error_response `Not_found
- | a ->
- let%lwt _ = Db.(e @@ User.get_one ~account_id:a#id) in
- req
- |> render ~default:(respond_html a)
- [ (app_activity_json, respond_activity a) ]
+let get _env req =
+ let username = req |> Yume.Server.param ":name" in
+ let a =
+ try Db.e (Model.Account.get_one ~domain:None ~username)
+ with Sqlx.Error.NoRowFound -> Yume.Server.raise_error_response `Not_found
+ in
+ let _ = Db.(e @@ User.get_one ~account_id:a#id) in
+ req
+ |> render ~default:(respond_html a)
+ [ (app_activity_json, respond_activity a) ]
diff --git a/lib/controller/users/statuses.ml b/lib/controller/users/statuses.ml
index d5475b8..27c688e 100644
--- a/lib/controller/users/statuses.ml
+++ b/lib/controller/users/statuses.ml
@@ -1,13 +1,12 @@
open Activity
-open Lwt.Infix
open Helper
-let get req =
- let _username = req |> Httpq.Server.param ":name" in
+let get _ req =
+ let _username = req |> Yume.Server.param ":name" in
let status_id =
- req |> Httpq.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
+ req |> Yume.Server.param ":id" |> int_of_string |> Model.Status.ID.of_int
in
- match%lwt Db.e (Model.Status.get_one ~id:status_id) with
+ match Db.e (Model.Status.get_one ~id:status_id) with
| exception Sqlx.Error.NoRowFound ->
- Httpq.Server.raise_error_response `Not_found
- | s -> note_of_status s >|= of_note >|= to_yojson >>= respond_activity_yojson
+ Yume.Server.raise_error_response `Not_found
+ | s -> note_of_status s |> of_note |> to_yojson |> respond_activity_yojson
diff --git a/lib/controller/well_known/host_meta.ml b/lib/controller/well_known/host_meta.ml
index ad63308..7d0ebb4 100644
--- a/lib/controller/well_known/host_meta.ml
+++ b/lib/controller/well_known/host_meta.ml
@@ -1,5 +1,5 @@
(* Recv GET /.well-known/host-meta *)
-let get _req =
+let get _env _req =
let url = Config.url [ ".well-known"; "webfinger" ] in
Jingoo.Jg_template.from_string
~models:[ ("url", Tstr url) ]
@@ -7,4 +7,4 @@ let get _req =
|}
- |> Httpq.Server.respond ~headers:[ Helper.content_type_app_xrd_xml ]
+ |> Yume.Server.respond ~headers:[ Helper.content_type_app_xrd_xml ]
diff --git a/lib/controller/well_known/nodeinfo.ml b/lib/controller/well_known/nodeinfo.ml
index bcb94fd..eadf1da 100644
--- a/lib/controller/well_known/nodeinfo.ml
+++ b/lib/controller/well_known/nodeinfo.ml
@@ -1,6 +1,6 @@
open Helper
-let get _req =
+let get _ _req =
`Assoc
[
( "links",
diff --git a/lib/controller/well_known/webfinger.ml b/lib/controller/well_known/webfinger.ml
index 737b73e..535e150 100644
--- a/lib/controller/well_known/webfinger.ml
+++ b/lib/controller/well_known/webfinger.ml
@@ -4,7 +4,7 @@ open Util
let respond_jrd w () =
w |> yojson_of_webfinger |> Yojson.Safe.to_string
- |> Httpq.Server.respond ~headers:[ Helper.content_type_app_jrd_json ]
+ |> Yume.Server.respond ~headers:[ Helper.content_type_app_jrd_json ]
let respond_xrd w () =
({||}
@@ -27,12 +27,12 @@ let respond_xrd w () =
],
[] ))) )
|> to_string))
- |> Httpq.Server.respond ~headers:[ Helper.content_type_app_xrd_xml ]
+ |> Yume.Server.respond ~headers:[ Helper.content_type_app_xrd_xml ]
(* Recv GET /.well-known/webfinger *)
-let get req =
- try%lwt
- let%lwt s = req |> Httpq.Server.query "resource" in
+let get _ req =
+ try
+ let s = req |> Yume.Server.query "resource" in
let s =
(* Remove 'acct:' prefix if exists *)
if String.starts_with ~prefix:"acct:" s then
@@ -45,8 +45,8 @@ let get req =
failwith "Invalid request";
(* Return the body *)
let name, dom = (List.hd s, List.nth s 1) in
- let%lwt a = Db.(e & Account.get_one ~domain:None ~username:name) in
- let%lwt _ = Db.(e & User.get_one ~account_id:a#id) in
+ let a = Db.(e & Account.get_one ~domain:None ~username:name) in
+ let _ = Db.(e & User.get_one ~account_id:a#id) in
let res =
make_webfinger
~subject:("acct:" ^ name ^ "@" ^ dom)
@@ -67,4 +67,4 @@ let get req =
m "[well_known_webfinger] Can't find user: %s\n%s"
(Printexc.to_string e)
(Printexc.get_backtrace ()));
- Httpq.Server.raise_error_response `Not_found
+ Yume.Server.raise_error_response `Not_found
diff --git a/lib/crypto.ml b/lib/crypto.ml
index 7cb6b76..496b8d7 100644
--- a/lib/crypto.ml
+++ b/lib/crypto.ml
@@ -1,4 +1,5 @@
-let initialize () = Mirage_crypto_rng_lwt.initialize ()
+let initialize env f =
+ Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env f
module SecureRandom = struct
let generate len = Mirage_crypto_rng.generate len |> Cstruct.to_string
diff --git a/lib/db.ml b/lib/db.ml
index 8cdeb3c..788ee66 100644
--- a/lib/db.ml
+++ b/lib/db.ml
@@ -27,9 +27,9 @@ open Util
let register_user ~username ~display_name ~email ~password =
let now = Ptime.now () in
let created_at, updated_at = (now, now) in
- let private_key, public_key = Httpq.Signature.generate_keypair () in
- let public_key = Httpq.Signature.encode_public_key public_key in
- let private_key = Httpq.Signature.encode_private_key private_key in
+ let private_key, public_key = Yume.Signature.generate_keypair () in
+ let public_key = Yume.Signature.encode_public_key public_key in
+ let private_key = Yume.Signature.encode_private_key private_key in
let uri = Config.url [ "users"; username ] in
let inbox_url = uri ^/ "inbox" in
let outbox_url = uri ^/ "outbox" in
@@ -58,3 +58,4 @@ let register_user ~username ~display_name ~email ~password =
let initialize () = initialize (Config.db_url ())
let transaction f = e (fun c -> c#transaction f)
+let e x = Lwt_eio.run_lwt @@ fun () -> e x
diff --git a/lib/dune b/lib/dune
index a6e4303..fc9fa12 100644
--- a/lib/dune
+++ b/lib/dune
@@ -32,7 +32,6 @@
eio
eio_main
fpath
- httpq
jingoo
lambdasoup
logq
@@ -40,7 +39,7 @@
lwt_eio
lwt.unix
mirage-crypto-rng
- mirage-crypto-rng.lwt
+ mirage-crypto-rng-eio
pcre
postgresql
ptime
@@ -53,7 +52,8 @@
xml-light
yaml
yaml.unix
- yojson)
+ yojson
+ yume)
(flags :standard -warn-error -33))
(include_subdirs qualified)
diff --git a/lib/entity.ml b/lib/entity.ml
index 4d199d9..af8b2ed 100644
--- a/lib/entity.ml
+++ b/lib/entity.ml
@@ -1,5 +1,4 @@
open Util
-open Lwt.Infix
(* Entity account *)
type emoji = {
@@ -99,18 +98,19 @@ let serialize_account ?(credential = false) (a : Model.Account.t) : account =
~following_count:stat#following_count ?source ()
let load_accounts_from_db ?(credential = false)
- (account_ids : Model.Account.ID.t list) : account list Lwt.t =
- Db.(e Account.(select ~id:(`In account_ids) ~preload:[ `stat [] ]))
- >|= index_by (fun x -> x#id)
- >|= fun accts ->
+ (account_ids : Model.Account.ID.t list) : account list =
+ let accts =
+ Db.(e Account.(select ~id:(`In account_ids) ~preload:[ `stat [] ]))
+ |> index_by (fun x -> x#id)
+ in
account_ids
|> List.map (fun id -> Hashtbl.find accts id |> serialize_account ~credential)
-let make_account_from_model (a : Db.Account.t) : account Lwt.t =
- load_accounts_from_db [ a#id ] >|= List.hd
+let make_account_from_model (a : Db.Account.t) : account =
+ load_accounts_from_db [ a#id ] |> List.hd
-let make_credential_account_from_model (a : Db.Account.t) : account Lwt.t =
- load_accounts_from_db ~credential:true [ a#id ] >|= List.hd
+let make_credential_account_from_model (a : Db.Account.t) : account =
+ load_accounts_from_db ~credential:true [ a#id ] |> List.hd
(* Entity MediaAttachment *)
type media_attachment_meta = MAImage
@@ -348,8 +348,8 @@ let status_preload_spec self_id : Model.Status.preload_spec =
]
let load_statuses_from_db ?visibility ?(self_id : Model.Account.ID.t option)
- (status_ids : Model.Status.ID.t list) : status list Lwt.t =
- let%lwt statuses =
+ (status_ids : Model.Status.ID.t list) : status list =
+ let statuses =
Db.(
e
Status.(
@@ -359,11 +359,10 @@ let load_statuses_from_db ?visibility ?(self_id : Model.Account.ID.t option)
status_ids
|> List.map (fun id ->
Hashtbl.find statuses id |> serialize_status ?visibility)
- |> Lwt.return
let make_status_from_model ?(visibility = "public") ?self_id (s : Db.Status.t) :
- status Lwt.t =
- load_statuses_from_db ~visibility ?self_id [ s#id ] >|= List.hd
+ status =
+ load_statuses_from_db ~visibility ?self_id [ s#id ] |> List.hd
(* Entity relationship *)
type relationship = {
@@ -385,17 +384,16 @@ type relationship = {
let make_relationship_from_model (self : Db.Account.t) (acct : Db.Account.t) =
let id = acct#id |> Model.Account.ID.to_int |> string_of_int in
- let%lwt following =
+ let following =
Db.(e Follow.(does_follow ~account_id:self#id ~target_account_id:acct#id))
in
- let%lwt followed_by =
+ let followed_by =
Db.(e Follow.(does_follow ~target_account_id:self#id ~account_id:acct#id))
in
make_relationship ~id ~following ~followed_by ~showing_reblogs:true
~notifying:false ~blocking:false ~blocked_by:false ~muting:false
~muting_notifications:false ~requested:false ~domain_blocking:false
~endorsed:false ~note:""
- |> Lwt.return
(* Entity push_notification *)
type push_notification = {
@@ -477,18 +475,19 @@ let serialize_notification (n : Model.Notification.t) : notification =
()
let load_notifications_from_db ?self_id
- (noti_ids : Model.Notification.ID.t list) : notification list Lwt.t =
- Db.(
- e
- Notification.(
- select ~id:(`In noti_ids)
- ~preload:
- [
- `from_account [ `stat [] ];
- `target_status (status_preload_spec self_id);
- ]))
- >|= index_by (fun x -> x#id)
- >|= fun notis ->
+ (noti_ids : Model.Notification.ID.t list) : notification list =
+ let notis =
+ Db.(
+ e
+ Notification.(
+ select ~id:(`In noti_ids)
+ ~preload:
+ [
+ `from_account [ `stat [] ];
+ `target_status (status_preload_spec self_id);
+ ]))
+ |> index_by (fun x -> x#id)
+ in
noti_ids
|> List.filter_map (fun id ->
let n = Hashtbl.find notis id in
diff --git a/lib/image.ml b/lib/image.ml
index 3d92872..b43a82a 100644
--- a/lib/image.ml
+++ b/lib/image.ml
@@ -46,7 +46,7 @@ let generate_unique_filename img_type =
Uuidm.(v `V4 |> to_string)
^ match img_type with `PNG -> ".png" | `JPEG -> ".jpeg"
-let save_formdata ~outdir (formdata : Httpq.Server.formdata_t) =
+let save_formdata ~outdir (formdata : Yume.Server.formdata_t) =
let fdata = formdata in
let input_type =
match
@@ -54,7 +54,7 @@ let save_formdata ~outdir (formdata : Httpq.Server.formdata_t) =
|> parse_content_type
with
| Ok t -> t
- | Error _ -> Httpq.Server.raise_error_response `Bad_request
+ | Error _ -> Yume.Server.raise_error_response `Bad_request
in
let file_name = generate_unique_filename input_type in
let file_path = Filename.concat outdir file_name in
diff --git a/lib/job.ml b/lib/job.ml
index b958469..87c634e 100644
--- a/lib/job.ml
+++ b/lib/job.ml
@@ -1,23 +1,32 @@
-open Lwt.Infix
+module Runner = struct
+ type t = { chan : (unit -> unit) Eio.Stream.t }
-let kick ~name (f : unit -> unit Lwt.t) : unit Lwt.t =
+ let global_runner = { chan = Eio.Stream.create 0 }
+
+ let start_global_runner ~sw =
+ Eio.Fiber.fork ~sw (fun () ->
+ let rec loop () =
+ let task = Eio.Stream.take global_runner.chan in
+ Eio.Fiber.fork ~sw task;
+ loop ()
+ in
+ loop ())
+
+ let queue task = Eio.Stream.add global_runner.chan task
+end
+
+let kick env ~name (f : unit -> unit) : unit =
let timeout_seconds = 25.0 in
- let timeout_f () =
- let timeout = Lwt_unix.sleep timeout_seconds in
- let task_done = ref false in
- Lwt.pick [ timeout; (f () >|= fun () -> task_done := true) ] >|= fun () ->
- if not !task_done then failwith "Timeout"
- in
if Config.debug_job_kick_block () then (
Logq.debug (fun m -> m "[DEBUG ONLY] Blocked kick: %s" name);
- try%lwt timeout_f ()
+ try Eio.Time.with_timeout_exn env#clock timeout_seconds f
with e ->
Logq.warn (fun m ->
m "[DEBUG ONLY] Fail immediately due to job failure:\n%s: %s: %s" name
(match e with _ -> Printexc.to_string e)
(Printexc.get_backtrace ()));
- Lwt.fail e)
+ raise e)
else
let task () =
let num_repeats = 3 in
@@ -26,21 +35,20 @@ let kick ~name (f : unit -> unit Lwt.t) : unit Lwt.t =
(i * i * i * i) + 15 + (Random.int 10 * (i + 1)) |> float_of_int
in
let rec loop i =
- try%lwt timeout_f ()
+ try Eio.Time.with_timeout_exn env#clock timeout_seconds f
with e ->
Logq.warn (fun m ->
m "Job failed: %s: %s: %s" name (Printexc.to_string e)
(Printexc.get_backtrace ()));
- if i + 1 = num_repeats then (
- Logq.err (fun m -> m "Job killed: %s: Limit reached" name);
- Lwt.return_unit)
+ if i + 1 = num_repeats then
+ Logq.err (fun m -> m "Job killed: %s: Limit reached" name)
else
let dur = sleep_duration i in
Logq.debug (fun m -> m "Job: %s will sleep %.1f seconds" name dur);
- Lwt_unix.sleep dur;%lwt
+ Eio.Time.sleep env#clock dur;
loop (i + 1)
in
loop 0
in
- Lwt.async task;
- Lwt.return_unit
+ Runner.queue task;
+ ()
diff --git a/lib/oauth_helper.ml b/lib/oauth_helper.ml
index 6c0e42d..32f9655 100644
--- a/lib/oauth_helper.ml
+++ b/lib/oauth_helper.ml
@@ -30,13 +30,9 @@ let generate_access_token ~scopes ?resource_owner_id
let authenticate_access_token token = Db.(e (OAuthAccessToken.get_one ~token))
let authenticate_application uid =
- match%lwt Db.(e (OAuthApplication.get_one ~uid) |> maybe_no_row) with
- | Some app -> Lwt.return app
- | None -> Httpq.Server.raise_error_response `Bad_request
+ try Db.(e (OAuthApplication.get_one ~uid))
+ with Sqlx.Error.NoRowFound -> Yume.Server.raise_error_response `Bad_request
let authenticate_access_grant auth_code =
- match%lwt
- Db.(e (OAuthAccessGrant.get_one ~token:auth_code) |> maybe_no_row)
- with
- | Some grant -> Lwt.return grant
- | None -> Httpq.Server.raise_error_response `Bad_request
+ try Db.(e (OAuthAccessGrant.get_one ~token:auth_code))
+ with Sqlx.Error.NoRowFound -> Yume.Server.raise_error_response `Bad_request
diff --git a/lib/ogp.ml b/lib/ogp.ml
index 1b4bdd5..e8a14a2 100644
--- a/lib/ogp.ml
+++ b/lib/ogp.ml
@@ -1,4 +1,3 @@
-open Lwt.Infix
open Util
type oembed = {
@@ -77,13 +76,13 @@ let parse_json_oembed ~url src =
make ~image ()
| _ -> failwith "Invalid type"
-let fetch_oembed url =
- Throttle_fetch.http_get url
- >|= find_json_oembed_href >>= Throttle_fetch.http_get
- >|= parse_json_oembed ~url
+let fetch_oembed env url =
+ Throttle_fetch.http_get env url
+ |> find_json_oembed_href
+ |> Throttle_fetch.http_get env
+ |> parse_json_oembed ~url
-let fetch_oembed_opt url =
- try%lwt fetch_oembed url >|= Option.some with _ -> Lwt.return_none
+let fetch_oembed_opt env url = try Some (fetch_oembed env url) with _ -> None
let parse_opengraph ~url src =
let open Soup in
@@ -121,23 +120,25 @@ let parse_opengraph ~url src =
make_oembed ~url ~typ:"link" ~title ~description ?image ?provider_name ()
-let fetch_image_info url = Throttle_fetch.http_get url >>= Image.inspect
+let fetch_image_info env url =
+ let body = Throttle_fetch.http_get env url in
+ Lwt_eio.run_lwt @@ fun () -> Image.inspect body
-let fetch_opengraph url =
- let%lwt src = Throttle_fetch.http_get url >|= parse_opengraph ~url in
+let fetch_opengraph env url =
+ let src = Throttle_fetch.http_get env url |> parse_opengraph ~url in
match src.image with
- | None -> Lwt.return src
+ | None -> src
| Some image_url -> (
- try%lwt
- let%lwt width, height, blurhash = fetch_image_info image_url in
+ try
+ let width, height, blurhash = fetch_image_info env image_url in
let blurhash = Some blurhash in
- Lwt.return { src with width; height; blurhash }
- with _ -> Lwt.return { src with image = None })
+ { src with width; height; blurhash }
+ with _ -> { src with image = None })
-let fetch_opengraph_opt url =
- try%lwt fetch_opengraph url >|= Option.some
+let fetch_opengraph_opt env url =
+ try Some (fetch_opengraph env url)
with e ->
Logq.err (fun m ->
m "Couldn't fetch opengraph: %s\n%s" (Printexc.to_string e)
(Printexc.get_backtrace ()));
- Lwt.return_none
+ None
diff --git a/lib/router.ml b/lib/router.ml
index c79184c..2a78135 100644
--- a/lib/router.ml
+++ b/lib/router.ml
@@ -1,5 +1,5 @@
open Util [@@warning "-33"]
-open Httpq.Server
+open Yume.Server
let cors =
Cors.
diff --git a/lib/streaming.ml b/lib/streaming.ml
index 104fdc0..4fea2ed 100644
--- a/lib/streaming.ml
+++ b/lib/streaming.ml
@@ -1,6 +1,6 @@
type stream = [ `User ]
type key = int * stream
-type connection = [ `WebSocket of Httpq.Server.ws_conn ]
+type connection = [ `WebSocket of Yume.Server.ws_conn ]
type connection_id = int
let connections : (key, (connection_id, connection) Hashtbl.t) Hashtbl.t =
@@ -52,4 +52,4 @@ let push ~(key : key) ~(event : string) ?payload () =
|> Option.fold ~none:l ~some:(fun payload ->
("payload", `String payload) :: l)
in
- `Assoc l |> Yojson.Safe.to_string |> Httpq.Server.ws_send conn)
+ `Assoc l |> Yojson.Safe.to_string |> Yume.Server.ws_send conn)
diff --git a/lib/throttle_fetch.ml b/lib/throttle_fetch.ml
index 66fd22e..d23b125 100644
--- a/lib/throttle_fetch.ml
+++ b/lib/throttle_fetch.ml
@@ -1,32 +1,208 @@
open Util
+(*
+module Throttle = struct
+ type t = {
+ rate : int;
+ mtx : Eio.Mutex.t;
+ count : (string, int) Hashtbl.t;
+ mutable cleaning : bool;
+ }
+
+ let create ~rate ~n =
+ {
+ rate;
+ mtx = Eio.Mutex.create ();
+ count = Hashtbl.create n;
+ cleaning = false;
+ }
+
+ let clean clock t =
+ Eio.Time.sleep clock 1.0;
+ Eio.Mutex.use_rw ~protect:true t.mtx (fun () ->
+ Hashtbl.clear t.count;
+ t.cleaning <- false)
+
+ let wait ~sw clock t k =
+ Eio.Mutex.use_rw ~protect:true t.mtx (fun () ->
+ if not t.cleaning then (
+ t.cleaning <- true;
+ Eio.Fiber.fork ~sw (fun () -> clean clock t));
+
+ match Hashtbl.find_opt t.count k with
+ | None ->
+ Hashtbl.add t.count k 1;
+ true
+ | Some c when c > t.rate -> false
+ | Some c ->
+ Hashtbl.replace t.count k (c + 1);
+ true)
+end
+
module StringHash = struct
type t = string
let equal = ( = )
let hash = Hashtbl.hash
end
+*)
+
+module Uri = struct
+ include Uri
-module StringLwtThrottle = Lwt_throttle.Make (StringHash)
+ let getaddrinfo_port (u : t) =
+ let scheme = Uri.scheme u |> Option.get in
+ u |> Uri.port |> Option.fold ~none:scheme ~some:string_of_int
-let limitter = StringLwtThrottle.create ~rate:1 ~max:100 ~n:1
+ let http_host (u : t) =
+ let host = Uri.host u |> Option.get in
+ match Uri.port u with
+ | None -> host
+ | Some port -> host ^ ":" ^ string_of_int port
+
+ let path_query_fragment (u : t) =
+ let res = Uri.path u in
+ let res =
+ match Uri.verbatim_query u with None -> res | Some q -> res ^ "?" ^ q
+ in
+ let res =
+ match Uri.fragment u with None -> res | Some f -> res ^ "#" ^ f
+ in
+ res
+
+ let domain (u : t) = http_host u
+end
+
+module Ptime = struct
+ include Ptime
+
+ let now () = Unix.gettimeofday () |> of_float_s |> Option.get
+
+ let to_http_date (v : t) : string =
+ let string_of_week = function
+ | `Sun -> "Sun"
+ | `Mon -> "Mon"
+ | `Tue -> "Tue"
+ | `Wed -> "Wed"
+ | `Thu -> "Thu"
+ | `Fri -> "Fri"
+ | `Sat -> "Sat"
+ in
+ let string_of_month = function
+ | 1 -> "Jan"
+ | 2 -> "Feb"
+ | 3 -> "Mar"
+ | 4 -> "Apr"
+ | 5 -> "May"
+ | 6 -> "Jun"
+ | 7 -> "Jul"
+ | 8 -> "Aug"
+ | 9 -> "Sep"
+ | 10 -> "Oct"
+ | 11 -> "Nov"
+ | 12 -> "Dec"
+ | _ -> assert false
+ in
+ let (year, month, day_of_month), ((hour, minute, second), _) =
+ to_date_time v
+ in
+ let month = string_of_month month in
+ let day_name = weekday v |> string_of_week in
+ Printf.sprintf "%s, %02d %s %d %02d:%02d:%02d GMT" day_name day_of_month
+ month year hour minute second
+end
+
+let fetch env ?(headers = []) ?(meth = `GET) ?(body = "") ?(sign = None) url =
+ let open Yume in
+ let uri = Uri.of_string url in
+
+ (* NOTE: Ad-hoc scheme rewriting (https -> http) for localhost
+ for better dev experience *)
+ let uri =
+ match Uri.scheme uri with
+ | Some "https"
+ when [ Some "localhost"; Some "127.0.0.1" ] |> List.mem (Uri.host uri) ->
+ Uri.with_scheme uri (Some "http")
+ | _ -> uri
+ in
+
+ let meth_s = Method.to_string meth in
+ let headers =
+ let headers =
+ let add (k, v) headers =
+ if List.mem_assoc k headers then headers else (k, v) :: headers
+ in
+ headers
+ |> add (`Content_length, body |> String.length |> string_of_int)
+ |> add (`Connection, "close")
+ |> add (`Host, Uri.http_host uri)
+ |> add (`Date, Ptime.(now () |> to_http_date))
+ in
+ let headers =
+ match sign with
+ | None -> headers
+ | Some (priv_key, key_id, signed_headers) ->
+ Signature.sign ~priv_key ~key_id ~signed_headers ~headers ~meth
+ ~path:(Uri.path_query_fragment uri)
+ ~body:(Some body)
+ in
+ Headers.to_list headers
+ in
+ try
+ Eio.Switch.run @@ fun sw ->
+ let resp =
+ match meth with
+ | `GET | `DELETE ->
+ Client.request env ~sw ~headers ~meth (Uri.to_string uri)
+ | `POST | `PATCH ->
+ Client.request env ~sw ~headers ~body:(`Fixed body) ~meth
+ (Uri.to_string uri)
+ | _ -> failwith "Not implemented method"
+ in
+ let status = Client.Response.status resp in
+ Logq.debug (fun m ->
+ m "[fetch] %s %s --> %s" meth_s url
+ (Cohttp.Code.string_of_status status));
+ let headers = Client.Response.headers resp in
+ let body = Client.Response.drain resp in
+ Ok (status, headers, body)
+ with e ->
+ let backtrace = Printexc.get_backtrace () in
+ Logq.err (fun m ->
+ m "[fetch] %s %s: %s\n%s" meth_s url (Printexc.to_string e) backtrace);
+ Error ()
+
+exception FetchFailure of (Yume.Status.t * Yume.Headers.t * string) option
+
+let fetch_exn ?(headers = []) ?(meth = `GET) ?(body = "") ?(sign = None) env
+ (url : string) : string =
+ match fetch env ~headers ~meth ~body ~sign url with
+ | Ok (`OK, _, body) -> body
+ | Ok r -> raise (FetchFailure (Some r))
+ | _ -> raise (FetchFailure None)
+
+module Throttle = struct
+ type t = { semaphore : Eio.Semaphore.t }
+
+ let create ~rate = { semaphore = Eio.Semaphore.make rate }
+
+ let wait { semaphore } _k f =
+ Eio.Semaphore.acquire semaphore;
+ Fun.protect ~finally:(fun () -> Eio.Semaphore.release semaphore) f
+end
+
+let limitter = Throttle.create ~rate:10
let call f url =
if Config.debug_no_throttle_fetch () then f url
else
let host = Uri.(of_string url |> host) |> Option.value ~default:"" in
- let rec aux () =
- if%lwt StringLwtThrottle.wait limitter host then f url
- else (
- Lwt_unix.sleep 1.0;%lwt
- aux ())
- in
- aux ()
+ Throttle.wait limitter host (fun () -> f url)
-let f ?(headers = []) ?(meth = `GET) ?(body = "") ?(sign = None) =
- call (Httpq.Client.fetch ~headers ~meth ~body ~sign)
+let f env ?(headers = []) ?(meth = `GET) ?(body = "") ?(sign = None) =
+ call (fetch env ~headers ~meth ~body ~sign)
-let f_exn ?(headers = []) ?(meth = `GET) ?(body = "") ?(sign = None) =
- call (Httpq.Client.fetch_exn ~headers ~meth ~body ~sign)
+let f_exn env ?(headers = []) ?(meth = `GET) ?(body = "") ?(sign = None) =
+ call (fetch_exn env ~headers ~meth ~body ~sign)
let http_get url = f_exn url
diff --git a/lib/webpush_helper.ml b/lib/webpush_helper.ml
index ae29e4a..0d45852 100644
--- a/lib/webpush_helper.ml
+++ b/lib/webpush_helper.ml
@@ -1,27 +1,25 @@
-open Lwt.Infix
-
-let deliver ?user_id message =
+let deliver env ?user_id message =
Db.(e @@ WebPushSubscription.(get_many ~user_id))
- >>= Lwt_list.iter_p @@ fun s ->
- match
- Webpush.construct_request ~message ~auth_key:s#key_auth
- ~p256dh_key:s#key_p256dh
- ~subscriber:(Config.webpush_subscriber ())
- ~endpoint:s#endpoint
- ~vapid_priv_key:(Config.vapid_private_key ())
- with
- | Error _ ->
- Logq.err (fun m ->
- m "Couldn't construct request of webpush: %s" s#endpoint);
- Lwt.return_unit
- | Ok (headers, body) -> (
- let body = Cstruct.to_string body in
- match%lwt Throttle_fetch.f ~headers ~meth:`POST ~body s#endpoint with
- | Ok (status, _, _) when Httpq.Status.is_success status ->
- Lwt.return_unit
- | Ok (`Gone, _, _) ->
- Logq.debug (fun m -> m "Subscription gone: %s" s#endpoint);
- Db.(e WebPushSubscription.(delete [ s ]))
- | _ ->
- Logq.err (fun m -> m "Couldn't post webpush: %s" s#endpoint);
- Lwt.return_unit)
+ |> List.map (fun s () ->
+ match
+ Webpush.construct_request ~message ~auth_key:s#key_auth
+ ~p256dh_key:s#key_p256dh
+ ~subscriber:(Config.webpush_subscriber ())
+ ~endpoint:s#endpoint
+ ~vapid_priv_key:(Config.vapid_private_key ())
+ with
+ | Error _ ->
+ Logq.err (fun m ->
+ m "Couldn't construct request of webpush: %s" s#endpoint)
+ | Ok (headers, body) -> (
+ let body = Cstruct.to_string body in
+ match
+ Throttle_fetch.f env ~headers ~meth:`POST ~body s#endpoint
+ with
+ | Ok (status, _, _) when Yume.Status.is_success status -> ()
+ | Ok (`Gone, _, _) ->
+ Logq.debug (fun m -> m "Subscription gone: %s" s#endpoint);
+ Db.(e WebPushSubscription.(delete [ s ]))
+ | _ -> Logq.err (fun m -> m "Couldn't post webpush: %s" s#endpoint)
+ ))
+ |> Eio.Fiber.all
diff --git a/lib/worker/accept.ml b/lib/worker/accept.ml
index 7cc3403..79725a3 100644
--- a/lib/worker/accept.ml
+++ b/lib/worker/accept.ml
@@ -1,7 +1,7 @@
open Activity
(* Send Accept to POST inbox *)
-let kick ~(f : Db.Follow.t) ~(followee : Db.Account.t)
+let kick env ~(f : Db.Follow.t) ~(followee : Db.Account.t)
~(follower : Db.Account.t) =
let id =
followee#uri ^ "#accepts/follows/"
@@ -11,4 +11,4 @@ let kick ~(f : Db.Follow.t) ~(followee : Db.Account.t)
make_follow ~id:f#uri ~actor:follower#uri ~obj:followee#uri |> follow
in
let activity = make_accept ~id ~actor:(`String followee#uri) ~obj |> accept in
- Delivery.kick ~activity ~src:followee ~url:follower#inbox_url
+ Delivery.kick env ~activity ~src:followee ~url:follower#inbox_url
diff --git a/lib/worker/account_update.ml b/lib/worker/account_update.ml
index 6007810..7495b07 100644
--- a/lib/worker/account_update.ml
+++ b/lib/worker/account_update.ml
@@ -1,14 +1,13 @@
open Util
-open Lwt.Infix
-let kick ~account_id ~updated_at =
- Job.kick ~name:__FUNCTION__ @@ fun () ->
- let%lwt src = Db.e (Model.Account.get_one ~id:account_id) in
+let kick env ~account_id ~updated_at =
+ Job.kick env ~name:__FUNCTION__ @@ fun () ->
+ let src = Db.e (Model.Account.get_one ~id:account_id) in
let id = src#uri ^ "#updates" ^/ (Ptime.to_int updated_at |> string_of_int) in
let actor = src#uri in
let to_ = [ "https://www.w3.org/ns/activitystreams#Public" ] in
let obj = Activity.(person_of_account src |> person) in
let activity = Activity.(make_update ~id ~actor ~to_ ~obj |> update) in
Db.(e @@ get_remote_followers ~account_id)
- >|= Db.Account.preferred_inbox_urls
- >>= Lwt_list.iter_p (fun url -> Delivery.kick ~src ~url ~activity)
+ |> Db.Account.preferred_inbox_urls
+ |> List.iter (fun url -> Delivery.kick env ~src ~url ~activity)
diff --git a/lib/worker/announce.ml b/lib/worker/announce.ml
index 57b8cd0..bdc9559 100644
--- a/lib/worker/announce.ml
+++ b/lib/worker/announce.ml
@@ -1,8 +1,7 @@
open Activity
-open Lwt.Infix
(* Send Announce to POST /users/:name/inbox *)
-let kick ~(url : string) ~(status : Db.Status.t) =
- let%lwt activity = announce_of_status status >|= announce in
- let%lwt src = Db.e (Model.Account.get_one ~id:status#account_id) in
- Delivery.kick ~activity ~src ~url
+let kick env ~(url : string) ~(status : Db.Status.t) =
+ let activity = announce_of_status status |> announce in
+ let src = Db.e (Model.Account.get_one ~id:status#account_id) in
+ Delivery.kick env ~activity ~src ~url
diff --git a/lib/worker/create_note.ml b/lib/worker/create_note.ml
index 3030754..9c94cde 100644
--- a/lib/worker/create_note.ml
+++ b/lib/worker/create_note.ml
@@ -1,8 +1,7 @@
open Activity
-open Lwt.Infix
(* Send Create/Note to POST /users/:name/inbox *)
-let kick ~(url : string) ~(status : Db.Status.t) =
- let%lwt activity = create_note_of_status status >|= create in
- let%lwt src = Db.e (Model.Account.get_one ~id:status#account_id) in
- Delivery.kick ~activity ~src ~url
+let kick env ~(url : string) ~(status : Db.Status.t) =
+ let activity = create_note_of_status status |> create in
+ let src = Db.e (Model.Account.get_one ~id:status#account_id) in
+ Delivery.kick env ~activity ~src ~url
diff --git a/lib/worker/delivery.ml b/lib/worker/delivery.ml
index 4958cbb..b3ed1e8 100644
--- a/lib/worker/delivery.ml
+++ b/lib/worker/delivery.ml
@@ -1,6 +1,6 @@
open Activity
-let kick ~(activity : t) ~(url : string) ~(src : Db.Account.t) =
- Job.kick ~name:__FUNCTION__ @@ fun () ->
+let kick env ~(activity : t) ~(url : string) ~(src : Db.Account.t) =
+ Job.kick env ~name:__FUNCTION__ @@ fun () ->
let body = activity |> to_yojson |> Yojson.Safe.to_string in
- post_activity_json ~body ~sign:(sign_spec_of_account src) ~url
+ post_activity_json env ~body ~sign:(sign_spec_of_account src) ~url
diff --git a/lib/worker/distribute.ml b/lib/worker/distribute.ml
index 81531a4..64b03f0 100644
--- a/lib/worker/distribute.ml
+++ b/lib/worker/distribute.ml
@@ -1,80 +1,78 @@
open Util
-open Lwt.Infix
-let deliver_to_local ~(targets : Db.User.t list) ~(status : Db.Status.t) :
- unit Lwt.t =
+let deliver_to_local env ~(targets : Db.User.t list) ~(status : Db.Status.t) :
+ unit =
targets
- |> Lwt_list.iter_p (fun (u : Db.User.t) ->
- Insert_to_feed.kick ~account_id:u#account_id ~status_id:status#id
+ |> List.iter (fun (u : Db.User.t) ->
+ Insert_to_feed.kick env ~account_id:u#account_id ~status_id:status#id
~user_id:u#id ~stream:`User)
-let deliver_to_remote ~(targets : Db.Account.t list) ~(status : Db.Status.t) :
- unit Lwt.t =
+let deliver_to_remote env ~(targets : Db.Account.t list) ~(status : Db.Status.t)
+ : unit =
targets |> Db.Account.preferred_inbox_urls
- |> Lwt_list.iter_p (fun url ->
+ |> List.iter (fun url ->
match status#reblog_of_id with
- | None -> Create_note.kick ~status ~url
- | Some _ -> Announce.kick ~status ~url)
+ | None -> Create_note.kick env ~status ~url
+ | Some _ -> Announce.kick env ~status ~url)
-let kick (s : Db.Status.t) =
- Job.kick ~name:__FUNCTION__ @@ fun () ->
- let%lwt a = Db.e (Model.Account.get_one ~id:s#account_id) in
+let kick env (s : Db.Status.t) =
+ Job.kick env ~name:__FUNCTION__ @@ fun () ->
+ let a = Db.e (Model.Account.get_one ~id:s#account_id) in
let is_status_from_remote = a#domain <> None in
- let%lwt local_followers = Db.(e @@ get_local_followers ~account_id:a#id) in
- let%lwt remote_followers = Db.(e @@ get_remote_followers ~account_id:a#id) in
+ let local_followers = Db.(e @@ get_local_followers ~account_id:a#id) in
+ let remote_followers = Db.(e @@ get_remote_followers ~account_id:a#id) in
- let%lwt local_mentions, remote_mentions =
+ let local_mentions, remote_mentions =
Db.(
e
@@ Mention.select ~status_id:(`Eq s#id) ~account_id:`NeqNone
~preload:[ `account [ `user [] ]; `status [ `account [] ] ])
- >|= List.partition_map (fun x ->
- let acct = Option.get x#account in
- match acct#user with None -> Right x | Some _ -> Left x)
+ |> List.partition_map (fun x ->
+ let acct = Option.get x#account in
+ match acct#user with None -> Right x | Some _ -> Left x)
in
(* Deliver to self *)
- (if is_status_from_remote then Lwt.return_unit (* Just ignore *)
+ (if is_status_from_remote then () (* Just ignore *)
else
- let%lwt u = Db.(e @@ User.get_one ~account_id:a#id) in
+ let u = Db.(e @@ User.get_one ~account_id:a#id) in
(* Local: Send the status to self *)
- Insert_to_feed.kick ~account_id:a#id ~status_id:s#id ~user_id:u#id
- ~stream:`User);%lwt
+ Insert_to_feed.kick env ~account_id:a#id ~status_id:s#id ~user_id:u#id
+ ~stream:`User);
(* Deliver to remote followers *)
- if not is_status_from_remote then
- let targets = remote_followers in
- let targets =
- targets @ (remote_mentions |> List.map (fun x -> Option.get x#account))
- in
- let%lwt targets =
- match s#reblog_of_id with
- | None -> Lwt.return targets
- | Some id ->
- (* Deliver Announce activity to the original author *)
- Db.(e Status.(get_one ~id ~preload:[ `account [] ])) >|= fun s ->
- if Model.Account.is_remote s#account then s#account :: targets
- else targets
- in
- deliver_to_remote ~targets ~status:s
- else Lwt.return_unit;%lwt
+ (if not is_status_from_remote then
+ let targets = remote_followers in
+ let targets =
+ targets @ (remote_mentions |> List.map (fun x -> Option.get x#account))
+ in
+ let targets =
+ match s#reblog_of_id with
+ | None -> targets
+ | Some id ->
+ (* Deliver Announce activity to the original author *)
+ let s = Db.(e Status.(get_one ~id ~preload:[ `account [] ])) in
+ if Model.Account.is_remote s#account then s#account :: targets
+ else targets
+ in
+ deliver_to_remote env ~targets ~status:s);
(* Deliver to local followers *)
- deliver_to_local
+ deliver_to_local env
~targets:
(local_followers
@ (local_mentions
|> List.map (fun x -> Option.get (Option.get x#account)#user)))
- ~status:s;%lwt
+ ~status:s;
(* Send notification to mentioned local users *)
(local_mentions
- |> Lwt_list.iter_p @@ fun m ->
+ |> List.iter @@ fun m ->
let src = (Option.get m#status)#account in
let dst = Option.get m#account in
- Local_notify.kick
+ Local_notify.kick env
~activity_id:(Model.Mention.ID.to_int m#id)
- ~activity_type:`Mention ~typ:`mention ~src ~dst);%lwt
+ ~activity_type:`Mention ~typ:`mention ~src ~dst);
- Lwt.return_unit
+ ()
diff --git a/lib/worker/insert_to_feed.ml b/lib/worker/insert_to_feed.ml
index d556068..8f023cd 100644
--- a/lib/worker/insert_to_feed.ml
+++ b/lib/worker/insert_to_feed.ml
@@ -1,14 +1,13 @@
open Entity
-let kick ~status_id ~account_id ~user_id ~stream =
- let open Lwt.Infix in
- Job.kick ~name:__FUNCTION__ @@ fun () ->
+let kick env ~status_id ~account_id ~user_id ~stream =
+ Job.kick env ~name:__FUNCTION__ @@ fun () ->
assert (stream = `User);
let key = Streaming.make_key ~user_id ~stream in
- let%lwt payload =
+ let payload =
Db.e (Model.Status.get_one ~id:status_id)
- >>= make_status_from_model ~self_id:account_id
- >|= yojson_of_status >|= Yojson.Safe.to_string
+ |> make_status_from_model ~self_id:account_id
+ |> yojson_of_status |> Yojson.Safe.to_string
in
Streaming.push ~key ~event:"update" ~payload ();
- Lwt.return_unit
+ ()
diff --git a/lib/worker/link_crawl.ml b/lib/worker/link_crawl.ml
index a92a5b5..bf75427 100644
--- a/lib/worker/link_crawl.ml
+++ b/lib/worker/link_crawl.ml
@@ -1,5 +1,4 @@
open Util
-open Lwt.Infix
let extract_urls (status : Model.Status.t) =
let urls =
@@ -38,9 +37,9 @@ let extract_urls (status : Model.Status.t) =
in
urls |> List.sort_uniq compare
-let kick (status_id : Model.Status.ID.t) =
- Job.kick ~name:__FUNCTION__ @@ fun () ->
- let%lwt status =
+let kick env (status_id : Model.Status.ID.t) =
+ Job.kick env ~name:__FUNCTION__ @@ fun () ->
+ let status =
Db.(
e
Status.(
@@ -50,40 +49,38 @@ let kick (status_id : Model.Status.ID.t) =
in
(* Find (or insert if necessary) PreviewCard *)
- let%lwt cards_already_inserted, cards_not_inserted =
+ let cards_already_inserted, cards_not_inserted =
extract_urls status
- |> Lwt_list.filter_map_p (fun url ->
- match%lwt Db.(e PreviewCard.(get_one ~url) |> maybe_no_row) with
- | Some x -> Lwt.return_some x
- | None -> (
- let%lwt oembed_opt =
- match%lwt Ogp.fetch_oembed_opt url with
- | Some y -> Lwt.return_some y
- | None -> Ogp.fetch_opengraph_opt url
- in
- match oembed_opt with
- | None -> Lwt.return_none
- | Some x ->
- (* Convert x into PreviewCard *)
- let type_ =
- match x.typ with
- | "link" -> 0
- | "photo" -> 1
- | "video" -> 2
- | "rich" -> 3
- | _ -> failwith "Invalid oembed type"
- in
- Model.PreviewCard.make ~url:x.url ~title:x.title
- ~description:x.description ?image_url:x.image ~type_
- ~html:x.html ~author_name:x.author_name
- ~author_url:x.author_url ~provider_name:x.provider_name
- ~provider_url:x.provider_url ~width:x.width
- ~height:x.height ~embed_url:x.embed_url
- ?blurhash:x.blurhash ()
- |> Lwt.return_some))
- >|= List.partition (fun c -> Option.is_some c#id_opt)
+ |> List.filter_map (fun url ->
+ try Some Db.(e PreviewCard.(get_one ~url))
+ with Sqlx.Error.NoRowFound -> (
+ let oembed_opt =
+ match Ogp.fetch_oembed_opt env url with
+ | Some y -> Some y
+ | None -> Ogp.fetch_opengraph_opt env url
+ in
+ match oembed_opt with
+ | None -> None
+ | Some x ->
+ (* Convert x into PreviewCard *)
+ let type_ =
+ match x.typ with
+ | "link" -> 0
+ | "photo" -> 1
+ | "video" -> 2
+ | "rich" -> 3
+ | _ -> failwith "Invalid oembed type"
+ in
+ Model.PreviewCard.make ~url:x.url ~title:x.title
+ ~description:x.description ?image_url:x.image ~type_
+ ~html:x.html ~author_name:x.author_name
+ ~author_url:x.author_url ~provider_name:x.provider_name
+ ~provider_url:x.provider_url ~width:x.width ~height:x.height
+ ~embed_url:x.embed_url ?blurhash:x.blurhash ()
+ |> Option.some))
+ |> List.partition (fun c -> Option.is_some c#id_opt)
in
- let%lwt cards_not_inserted = Db.(e PreviewCard.(insert cards_not_inserted)) in
+ let cards_not_inserted = Db.(e PreviewCard.(insert cards_not_inserted)) in
let cards = cards_already_inserted @ cards_not_inserted in
(* Insert PreviewCardStatus (associative entity) *)
@@ -93,12 +90,13 @@ let kick (status_id : Model.Status.ID.t) =
Model.PreviewCardStatus.make ~preview_card_id:card#id
~status_id:status#id ())
in
- if%lwt
+ if
+ Lwt_eio.run_lwt @@ fun () ->
Db.(
transaction (fun c ->
let open PreviewCardStatus in
let%lwt cards = get_many ~status_id c in
if cards <> [] then delete cards c else Lwt.return_unit;%lwt
PreviewCardStatus.insert rels c |> ignore_lwt))
- then Lwt.return_unit
+ then ()
else failwith "Transaction failed"
diff --git a/lib/worker/local_notify.ml b/lib/worker/local_notify.ml
index 7d76008..fbea6d3 100644
--- a/lib/worker/local_notify.ml
+++ b/lib/worker/local_notify.ml
@@ -1,20 +1,19 @@
open Util
-open Lwt.Infix
-let service activity_id activity_type dst src typ () =
+let service env activity_id activity_type dst src typ () =
let account_id = dst#id in
let from_account_id = src#id in
let typ = Some typ in
let now = Ptime.now () in
- match%lwt
+ match
Db.e
@@ Model.Notification.get_many ~activity_id ~activity_type ~account_id
~from_account_id ~typ
with
- | _ :: _ -> Lwt.return_unit
+ | _ :: _ -> ()
| [] ->
- let%lwt u = Db.e @@ Model.User.get_one ~account_id in
- let%lwt n =
+ let u = Db.e @@ Model.User.get_one ~account_id in
+ let n =
Db.e
@@ Model.Notification.(
make ~activity_id ~activity_type ~created_at:now ~updated_at:now
@@ -24,24 +23,25 @@ let service activity_id activity_type dst src typ () =
(* Notification via WebSocket *)
( Entity.load_notifications_from_db ~self_id:account_id [ n#id ]
- >|= List.hd >|= Entity.yojson_of_notification >|= Yojson.Safe.to_string
- >|= fun payload ->
+ |> List.hd |> Entity.yojson_of_notification |> Yojson.Safe.to_string
+ |> fun payload ->
Streaming.(
push
~key:(make_key ~user_id:u#id ~stream:`User)
- ~event:"notification" ~payload ()) );%lwt
+ ~event:"notification" ~payload ()) );
(* Push notification *)
- Webpush_helper.deliver ~user_id:u#id
+ Webpush_helper.deliver env ~user_id:u#id
(Entity.serialize_push_notification n
|> Entity.yojson_of_push_notification |> Yojson.Safe.to_string)
-let kick ~(activity_id : int) ~(activity_type : Db.Notification.activity_type_t)
- ~(dst : Db.Account.t) ~(src : Db.Account.t) ~(typ : Db.Notification.typ_t) =
- if not (Model.Account.is_local dst) then (
+let kick env ~(activity_id : int)
+ ~(activity_type : Db.Notification.activity_type_t) ~(dst : Db.Account.t)
+ ~(src : Db.Account.t) ~(typ : Db.Notification.typ_t) =
+ if not (Model.Account.is_local dst) then
Logq.err (fun m ->
m "Local_notify.kick: dst is not a local account: %s"
- (Model.Notification.activity_type_t_to_string activity_type));
- Lwt.return_unit)
+ (Model.Notification.activity_type_t_to_string activity_type))
else
- Job.kick ~name:__FUNCTION__ (service activity_id activity_type dst src typ)
+ Job.kick env ~name:__FUNCTION__
+ (service env activity_id activity_type dst src typ)
diff --git a/lib/worker/removal.ml b/lib/worker/removal.ml
index fecebda..0fe3a10 100644
--- a/lib/worker/removal.ml
+++ b/lib/worker/removal.ml
@@ -1,9 +1,7 @@
-open Lwt.Infix
-
-let aux ~account_id ~status_id ~status =
- let%lwt reblogs = Db.(e @@ Status.get_many' ~reblog_of_id:(Some status_id)) in
- let%lwt src = Db.e (Model.Account.get_one ~id:account_id) in
- let is_account_local = Model.Account.is_local src |> Lwt.return in
+let aux env ~account_id ~status_id ~status =
+ let reblogs = Db.(e @@ Status.get_many' ~reblog_of_id:(Some status_id)) in
+ let src = Db.e (Model.Account.get_one ~id:account_id) in
+ let is_account_local = Model.Account.is_local src in
let deliver_to_local ~user_id =
let open Streaming in
@@ -15,42 +13,41 @@ let aux ~account_id ~status_id ~status =
in
(* Deliver to self if necessary *)
- (if%lwt is_account_local then
- Db.(e @@ User.get_one ~account_id) >|= fun u ->
- deliver_to_local ~user_id:u#id);%lwt
+ (if is_account_local then
+ let u = Db.(e @@ User.get_one ~account_id) in
+ deliver_to_local ~user_id:u#id);
(* Deliver to local followers *)
Db.(e @@ get_local_followers ~account_id)
- >|= List.iter (fun (user : Db.User.t) -> deliver_to_local ~user_id:user#id);%lwt
+ |> List.iter (fun (user : Db.User.t) -> deliver_to_local ~user_id:user#id);
(* Deliver to remote followers *)
- if%lwt is_account_local then (
- let%lwt activity =
+ if is_account_local then (
+ let activity =
let open Activity in
match status#reblog_of_id with
| Some _ ->
(* Undo Announce *)
announce_of_status ~deleted:true status
- >|= announce >|= to_undo ~actor:src#uri >|= undo
+ |> announce |> to_undo ~actor:src#uri |> undo
| None ->
(* Delete *)
let id = status#uri ^ "#delete" in
let actor = src#uri in
let to_ = [ "https://www.w3.org/ns/activitystreams#Public" ] in
let obj = make_tombstone ~id:status#uri |> tombstone |> to_yojson in
- make_delete ~id ~actor ~to_ ~obj |> delete |> Lwt.return
+ make_delete ~id ~actor ~to_ ~obj |> delete
in
Db.(e @@ get_remote_followers ~account_id)
- >|= Db.Account.preferred_inbox_urls
- >>= Lwt_list.iter_p (fun url -> Delivery.kick ~src ~url ~activity);%lwt
+ |> Db.Account.preferred_inbox_urls
+ |> List.iter (fun url -> Delivery.kick env ~src ~url ~activity);
- Lwt.return_unit)
+ ())
-let kick ~account_id ~status_id =
- Job.kick ~name:__FUNCTION__ @@ fun () ->
- let%lwt status = Db.(e @@ Status.discard_with_reblogs status_id) in
- if account_id <> status#account_id then (
+let kick env ~account_id ~status_id =
+ Job.kick env ~name:__FUNCTION__ @@ fun () ->
+ let status = Db.(e @@ Status.discard_with_reblogs status_id) in
+ if account_id <> status#account_id then
Logq.err (fun m ->
- m "Worker.Removal: ignoring invalid pair of account_id and status_id");
- Lwt.return_unit)
- else aux ~account_id ~status_id ~status
+ m "Worker.Removal: ignoring invalid pair of account_id and status_id")
+ else aux env ~account_id ~status_id ~status
diff --git a/lib_httpq/bare_server.ml b/lib_httpq/bare_server.ml
deleted file mode 100644
index e4eff98..0000000
--- a/lib_httpq/bare_server.ml
+++ /dev/null
@@ -1,121 +0,0 @@
-open Util
-open Lwt.Infix
-
-module Request = struct
- include Cohttp_lwt.Request
-
- let headers = headers |.> Cohttp.Header.to_list
-end
-
-module Response = struct
- type t = Cohttp_lwt_unix.Server.response_action
-end
-
-module Body = Cohttp_lwt.Body
-
-let respond ~(status : Status.t) ~(headers : Headers.t) ~(body : string) =
- let headers = headers |> Headers.to_list |> Cohttp.Header.of_list in
- Cohttp_lwt_unix.Server.respond_string ~status ~headers ~body () >|= fun x ->
- `Response x
-
-let start_server port k callback =
- let callback _conn (req : Request.t) (body : Body.t) =
- (* Invoke the handler *)
- let%lwt resp =
- try%lwt callback req body
- with e ->
- let uri = Request.uri req in
- let meth = Request.meth req in
- Logq.err (fun m ->
- m "Unexpected exception: %s %s: %s\n%s" (Method.to_string meth)
- (Uri.to_string uri) (Printexc.to_string e)
- (Printexc.get_backtrace ()));
- respond ~status:`Internal_server_error ~body:"" ~headers:[]
- in
- match resp with
- | `Response (resp, body) ->
- (* NOTE: Add a connection header if one doesn't exist. It is necessary to
- receive HTTP requests correctly via Tunnelmole. FYI cohttp-async already
- has the same functionality, but cohttp-lwt does not.
- cf.: https://github.com/mirage/ocaml-cohttp/blob/cf2ae3344ed9211230a5680f251613326eacb296/cohttp-async/src/server.ml#L90-L95
- *)
- let resp =
- let keep_alive =
- Request.is_keep_alive req (*&& Http.Response.is_keep_alive resp*)
- in
- let headers =
- Cohttp.Header.add_unless_exists
- (Cohttp.Response.headers resp)
- "connection"
- (if keep_alive then "keep-alive" else "close")
- in
- { resp with headers }
- in
- Lwt.return (`Response (resp, body))
- | _ -> Lwt.return resp
- in
- let server =
- Cohttp_lwt_unix.Server.make_response_action ~callback ()
- |> Cohttp_lwt_unix.Server.create ~mode:(`TCP (`Port port))
- in
- Lwt.pick [ server; (k >>= fun () -> Lwt.task () |> fst) ]
-
-type ws_conn = {
- mutable frames_out_fn : (Websocket.Frame.t option -> unit) option;
- mutable closed : bool; [@default false]
- recv_stream : string Lwt_stream.t;
-}
-[@@deriving make]
-
-let ws_send ?(opcode = Websocket.Frame.Opcode.Text) (c : ws_conn) content =
- if not c.closed then
- Websocket.Frame.create ~opcode ~content ()
- |> Option.some |> Option.get c.frames_out_fn
-
-let ws_recv (c : ws_conn) = Lwt_stream.get c.recv_stream
-
-let websocket (req : Request.t) f =
- let recv_stream, recv_stream_push = Lwt_stream.create () in
- let conn = make_ws_conn ~recv_stream () in
- let%lwt resp, frames_out_fn =
- Websocket_cohttp_lwt.upgrade_connection req (fun { opcode; content; _ } ->
- match opcode with
- | Close ->
- Logq.debug (fun m -> m "Websocket: recv Close");
- ws_send ~opcode:Close conn "";
- conn.closed <- true;
- recv_stream_push None
- | Text | Binary ->
- Logq.debug (fun m -> m "Websocket: recv: %s" content);
- recv_stream_push (Some content)
- | Ping -> ws_send ~opcode:Pong conn content
- | Pong -> () (* Just ignore *)
- | _ ->
- Websocket.Frame.close 1002
- |> Option.(some |.> get conn.frames_out_fn))
- in
- conn.frames_out_fn <- Some frames_out_fn;
- Lwt.async (fun () ->
- try
- Logq.debug (fun m -> m "Websocket: start thread");
-
- (* Send Ping continuously *)
- let timeout = ref None in
- let timeout_seconds = 10 in
- timeout :=
- Some
- ( Lwt_timeout.create timeout_seconds @@ fun () ->
- ws_send ~opcode:Ping conn "";
- Lwt_timeout.start (Option.get !timeout) );
-
- (* Start the process *)
- Lwt_timeout.start (Option.get !timeout);
- f conn;%lwt
- Lwt_timeout.stop (Option.get !timeout);
- Lwt.return_unit
- with e ->
- Logq.err (fun m ->
- m "Websocket: thread error: %s\n%s" (Printexc.to_string e)
- (Printexc.get_backtrace ()));
- Lwt.return_unit);
- Lwt.return resp
diff --git a/lib_httpq/client.ml b/lib_httpq/client.ml
deleted file mode 100644
index 45dd357..0000000
--- a/lib_httpq/client.ml
+++ /dev/null
@@ -1,71 +0,0 @@
-open Util
-
-let fetch ?(headers = []) ?(meth = `GET) ?(body = "") ?(sign = None) url =
- let open Cohttp in
- let open Cohttp_lwt_unix in
- let uri = Uri.of_string url in
-
- (* NOTE: Ad-hoc scheme rewriting (https -> http) for localhost
- for better dev experience *)
- let uri =
- match Uri.scheme uri with
- | Some "https"
- when [ Some "localhost"; Some "127.0.0.1" ] |> List.mem (Uri.host uri) ->
- Uri.with_scheme uri (Some "http")
- | _ -> uri
- in
-
- let meth_s = Method.to_string meth in
- let headers =
- let headers =
- let add (k, v) headers =
- if List.mem_assoc k headers then headers else (k, v) :: headers
- in
- headers
- |> add (`Content_length, body |> String.length |> string_of_int)
- |> add (`Connection, "close")
- |> add (`Host, Uri.http_host uri)
- |> add (`Date, Ptime.(now () |> to_http_date))
- in
- let headers =
- match sign with
- | None -> headers
- | Some (priv_key, key_id, signed_headers) ->
- Signature.sign ~priv_key ~key_id ~signed_headers ~headers ~meth
- ~path:(Uri.path_query_fragment uri)
- ~body:(Some body)
- in
- headers |> Headers.to_list |> Header.of_list
- in
- try%lwt
- let%lwt resp, body =
- match meth with
- | `GET | `DELETE -> Client.call ~headers meth uri
- | `POST | `PATCH ->
- let body = Cohttp_lwt.Body.of_string body in
- Client.call ~headers ~body meth uri
- | _ -> failwith "Not implemented method"
- in
- let status = Response.status resp in
- Logq.debug (fun m ->
- m "[fetch] %s %s --> %s" meth_s url (Code.string_of_status status));
- let headers =
- Response.headers resp |> Header.to_list
- |> List.map (fun (k, v) -> (String.lowercase_ascii k, v))
- in
- let%lwt body = Cohttp_lwt.Body.to_string body in
- Lwt.return_ok (status, headers, body)
- with e ->
- let backtrace = Printexc.get_backtrace () in
- Logq.err (fun m ->
- m "[fetch] %s %s: %s\n%s" meth_s url (Printexc.to_string e) backtrace);
- Lwt.return_error ()
-
-exception FetchFailure of (Status.t * (string * string) list * string) option
-
-let fetch_exn ?(headers = []) ?(meth = `GET) ?(body = "") ?(sign = None)
- (url : string) : string Lwt.t =
- match%lwt fetch ~headers ~meth ~body ~sign url with
- | Ok (`OK, _, body) -> Lwt.return body
- | Ok r -> raise (FetchFailure (Some r))
- | _ -> raise (FetchFailure None)
diff --git a/lib_httpq/dune b/lib_httpq/dune
deleted file mode 100644
index 9d26a93..0000000
--- a/lib_httpq/dune
+++ /dev/null
@@ -1,28 +0,0 @@
-(library
- (name httpq)
- (preprocess
- (pps
- lwt_ppx
- ppx_deriving.enum
- ppx_deriving.make
- ppx_deriving.show
- ppx_deriving_yaml
- ppx_yojson_conv))
- (libraries
- base64
- cohttp-lwt-unix
- cstruct
- logq
- lwt
- lwt.unix
- multipart_form
- multipart_form-lwt
- ptime
- result
- sha
- unix
- uri
- websocket
- websocket-lwt-unix.cohttp
- x509
- yojson))
diff --git a/lib_httpq/util.ml b/lib_httpq/util.ml
deleted file mode 100644
index 290dc66..0000000
--- a/lib_httpq/util.ml
+++ /dev/null
@@ -1,74 +0,0 @@
-let ( |.> ) f g a = f a |> g
-let ( *> ) f g a = f a |> g
-
-module Uri = struct
- include Uri
-
- let getaddrinfo_port (u : t) =
- let scheme = Uri.scheme u |> Option.get in
- u |> Uri.port |> Option.fold ~none:scheme ~some:string_of_int
-
- let http_host (u : t) =
- let host = Uri.host u |> Option.get in
- match Uri.port u with
- | None -> host
- | Some port -> host ^ ":" ^ string_of_int port
-
- let path_query_fragment (u : t) =
- let res = Uri.path u in
- let res =
- match Uri.verbatim_query u with None -> res | Some q -> res ^ "?" ^ q
- in
- let res =
- match Uri.fragment u with None -> res | Some f -> res ^ "#" ^ f
- in
- res
-
- let domain (u : t) = http_host u
-end
-
-module Ptime = struct
- include Ptime
-
- let now () = Unix.gettimeofday () |> of_float_s |> Option.get
-
- let to_http_date (v : t) : string =
- let string_of_week = function
- | `Sun -> "Sun"
- | `Mon -> "Mon"
- | `Tue -> "Tue"
- | `Wed -> "Wed"
- | `Thu -> "Thu"
- | `Fri -> "Fri"
- | `Sat -> "Sat"
- in
- let string_of_month = function
- | 1 -> "Jan"
- | 2 -> "Feb"
- | 3 -> "Mar"
- | 4 -> "Apr"
- | 5 -> "May"
- | 6 -> "Jun"
- | 7 -> "Jul"
- | 8 -> "Aug"
- | 9 -> "Sep"
- | 10 -> "Oct"
- | 11 -> "Nov"
- | 12 -> "Dec"
- | _ -> assert false
- in
- let (year, month, day_of_month), ((hour, minute, second), _) =
- to_date_time v
- in
- let month = string_of_month month in
- let day_name = weekday v |> string_of_week in
- Printf.sprintf "%s, %02d %s %d %02d:%02d:%02d GMT" day_name day_of_month
- month year hour minute second
-end
-
-module List = struct
- include List
-
- let assoc_many k1 l =
- l |> List.filter_map (fun (k, v) -> if k = k1 then Some v else None)
-end
diff --git a/lib_webpush/test/test_webpush.ml b/lib_webpush/test/test_webpush.ml
index 35026a7..bed2384 100644
--- a/lib_webpush/test/test_webpush.ml
+++ b/lib_webpush/test/test_webpush.ml
@@ -18,5 +18,5 @@ let test_main_case1 () =
let () =
let open Alcotest in
- Mirage_crypto_rng_unix.initialize ();
+ Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna);
run "webpush" [ ("main", [ test_case "case1" `Quick test_main_case1 ]) ]
diff --git a/lib_yume/bare_server.ml b/lib_yume/bare_server.ml
new file mode 100644
index 0000000..2a7c21d
--- /dev/null
+++ b/lib_yume/bare_server.ml
@@ -0,0 +1,105 @@
+module Request = struct
+ include Cohttp.Request
+
+ let headers x = x |> headers |> Cohttp.Header.to_list
+end
+
+module Response = struct
+ type t = Cohttp_eio.Server.response_action
+end
+
+module Body = struct
+ include Cohttp_eio.Body
+
+ let to_string body = Eio.Buf_read.(parse_exn take_all) body ~max_size:max_int
+end
+
+let respond ~(status : Status.t) ~(headers : Headers.t) ~(body : string) =
+ let headers = headers |> Headers.to_list |> Cohttp.Header.of_list in
+ `Response
+ (Http.Response.make ~status ~headers (), Cohttp_eio.Body.of_string body)
+
+let start_server ~listen ~sw env k callback =
+ let callback _conn (req : Request.t) (body : Body.t) =
+ (* Invoke the handler *)
+ try callback req body
+ with e ->
+ let uri = Request.uri req in
+ let meth = Request.meth req in
+ Logq.err (fun m ->
+ m "Unexpected exception: %s %s: %s\n%s" (Method.to_string meth)
+ (Uri.to_string uri) (Printexc.to_string e)
+ (Printexc.get_backtrace ()));
+ respond ~status:`Internal_server_error ~body:"" ~headers:[]
+ in
+ let server = Cohttp_eio.Server.make_response_action ~callback () in
+ let socket =
+ Eio.Net.listen (Eio.Stdenv.net env) ~sw ~backlog:128 ~reuse_addr:true listen
+ in
+ Eio.Fiber.both
+ (fun () -> k socket)
+ (fun () -> Cohttp_eio.Server.run ~on_error:raise socket server)
+
+type ws_conn = {
+ mutable frames_out_fn : (Websocket.Frame.t option -> unit) option;
+ mutable closed : bool; [@default false]
+ recv_stream : string option Eio.Stream.t;
+}
+[@@deriving make]
+
+let websocket_handler conn frames_out_fn frame =
+ match frame with
+ | None ->
+ if not conn.closed then (
+ conn.closed <- true;
+ Eio.Stream.add conn.recv_stream None)
+ | Some Websocket.Frame.{ opcode; content; _ } -> (
+ match opcode with
+ | Close ->
+ Logq.debug (fun m -> m "Websocket: recv Close");
+ frames_out_fn
+ (Some (Websocket.Frame.create ~opcode:Close ~content:"" ()));
+ conn.closed <- true;
+ Eio.Stream.add conn.recv_stream None
+ | Text | Binary ->
+ Logq.debug (fun m -> m "Websocket: recv: %s" content);
+ Eio.Stream.add conn.recv_stream (Some content)
+ | Ping ->
+ frames_out_fn (Some (Websocket.Frame.create ~opcode:Pong ~content ()))
+ | Pong -> () (* Just ignore *)
+ | _ -> frames_out_fn (Some (Websocket.Frame.close 1002)))
+
+let ws_send ?(opcode = Websocket.Frame.Opcode.Text) (c : ws_conn) content =
+ if not c.closed then
+ Websocket.Frame.create ~opcode ~content ()
+ |> Option.some |> Option.get c.frames_out_fn
+
+let ws_recv (c : ws_conn) = Eio.Stream.take c.recv_stream
+
+let websocket env ~sw (req : Request.t) f =
+ let conn = make_ws_conn ~recv_stream:(Eio.Stream.create 10) () in
+ let resp, frames_out_fn =
+ Ws.Server.upgrade_connection req (websocket_handler conn)
+ in
+ conn.frames_out_fn <- Some frames_out_fn;
+ Eio.Fiber.fork ~sw (fun () ->
+ try
+ Logq.debug (fun m -> m "Websocket: start thread");
+
+ Eio.Fiber.both
+ (fun () ->
+ (* Send Ping continuously *)
+ let rec loop () =
+ Eio.Time.sleep env#clock 10.0;
+ ws_send ~opcode:Ping conn "";
+ loop ()
+ in
+ loop ())
+ (fun () ->
+ (* Start the process *)
+ f conn)
+ with e ->
+ Logq.err (fun m ->
+ m "Websocket: thread error: %s\n%s" (Printexc.to_string e)
+ (Printexc.get_backtrace ())));
+ resp
diff --git a/lib_yume/client.ml b/lib_yume/client.ml
new file mode 100644
index 0000000..851713b
--- /dev/null
+++ b/lib_yume/client.ml
@@ -0,0 +1,43 @@
+let null_auth ?ip:_ ~host:_ _ =
+ Ok None (* Warning: use a real authenticator in your code! *)
+
+let https ~authenticator =
+ let tls_config = Tls.Config.client ~authenticator () in
+ fun uri raw ->
+ let host =
+ Uri.host uri
+ |> Option.map (fun x -> Domain_name.(host_exn (of_string_exn x)))
+ in
+ Tls_eio.client_of_flow ?host tls_config raw
+
+module Response = struct
+ type t = { resp : Http.Response.t; body : Cohttp_eio.Body.t }
+
+ let status { resp; _ } = Http.Response.status resp
+
+ let headers { resp; _ } =
+ resp |> Http.Response.headers |> Http.Header.to_list |> Headers.of_list
+
+ let drain { body; _ } =
+ Eio.Buf_read.(parse_exn take_all) body ~max_size:max_int
+end
+
+let request ?headers ?body ~meth env ~sw (url : string) =
+ let headers = headers |> Option.map Cohttp.Header.of_list in
+ let body =
+ body |> Option.map (function `Fixed src -> Cohttp_eio.Body.of_string src)
+ in
+ let client =
+ Cohttp_eio.Client.make
+ ~https:(Some (https ~authenticator:null_auth))
+ (Eio.Stdenv.net env)
+ in
+ let resp, body =
+ Cohttp_eio.Client.call ~sw ?headers ?body client meth (Uri.of_string url)
+ in
+ Response.{ resp; body }
+
+let get = request ~meth:`GET
+let post = request ~meth:`POST
+let put = request ~meth:`PUT
+let delete = request ~meth:`DELETE
diff --git a/lib_yume/dune b/lib_yume/dune
new file mode 100644
index 0000000..df9b406
--- /dev/null
+++ b/lib_yume/dune
@@ -0,0 +1,13 @@
+(library
+ (name yume)
+ (preprocess
+ (pps ppx_deriving.show ppx_deriving.make))
+ (libraries
+ cohttp-eio
+ eio.unix
+ logq
+ multipart_form
+ multipart_form-eio
+ tls-eio
+ yojson
+ websocket))
diff --git a/lib_httpq/header.ml b/lib_yume/header.ml
similarity index 100%
rename from lib_httpq/header.ml
rename to lib_yume/header.ml
diff --git a/lib_httpq/headers.ml b/lib_yume/headers.ml
similarity index 100%
rename from lib_httpq/headers.ml
rename to lib_yume/headers.ml
diff --git a/lib_httpq/method.ml b/lib_yume/method.ml
similarity index 100%
rename from lib_httpq/method.ml
rename to lib_yume/method.ml
diff --git a/lib_httpq/path_pattern.ml b/lib_yume/path_pattern.ml
similarity index 85%
rename from lib_httpq/path_pattern.ml
rename to lib_yume/path_pattern.ml
index efdc5ae..68b6b07 100644
--- a/lib_httpq/path_pattern.ml
+++ b/lib_yume/path_pattern.ml
@@ -1,10 +1,8 @@
-open Util
-
type single_pattern = L of string | P of string | S
type t = single_pattern list
-let split_on_slash =
- String.split_on_char '/' |.> List.tl |.> List.filter (( <> ) "")
+let split_on_slash s =
+ s |> String.split_on_char '/' |> List.tl |> List.filter (( <> ) "")
let of_string (src : string) : t =
src |> split_on_slash
diff --git a/lib_httpq/server.ml b/lib_yume/server.ml
similarity index 52%
rename from lib_httpq/server.ml
rename to lib_yume/server.ml
index 9ed0cd5..571f6e6 100644
--- a/lib_httpq/server.ml
+++ b/lib_yume/server.ml
@@ -1,6 +1,3 @@
-open Util
-open Lwt.Infix
-
type formdata_t = {
filename : string option;
content_type : Multipart_form.Content_type.t;
@@ -22,7 +19,7 @@ type request =
path : string;
query : (string * string) list;
param : (string * string) list;
- body : (string option * request_body option) Lwt.t Lazy.t;
+ body : (string option * request_body option) Lazy.t;
headers : Headers.t;
}
@@ -35,7 +32,7 @@ type response =
tags : string list;
}
-type handler = request -> response Lwt.t
+type handler = Eio_unix.Stdenv.base -> request -> response
type middleware = handler -> handler
exception ErrorResponse of { status : Status.t; body : string }
@@ -44,11 +41,11 @@ let raise_error_response ?(body = "") status =
raise (ErrorResponse { status; body })
let respond ?(status = `OK) ?(headers = []) ?(tags = []) (body : string) =
- Response { status; headers; body; tags } |> Lwt.return
+ Response { status; headers; body; tags }
let body = function
| Request { body; _ } -> (
- Lazy.force body >|= function
+ match Lazy.force body with
| Some raw_body, _ -> raw_body
| _ -> failwith "body: none")
@@ -60,12 +57,15 @@ let string_of_yojson_atom = function
| `String s -> s
| _ -> failwith "string_of_yojson_atom"
-let query_many name : request -> string list Lwt.t = function
+let list_assoc_many k1 l =
+ l |> List.filter_map (fun (k, v) -> if k = k1 then Some v else None)
+
+let query_many name : request -> string list = function
| Request { body; query; _ } -> (
- match query |> List.assoc_many (name ^ "[]") with
- | _ :: _ as res -> Lwt.return res
+ match query |> list_assoc_many (name ^ "[]") with
+ | _ :: _ as res -> res
| [] -> (
- Lazy.force body >|= function
+ match Lazy.force body with
| _, Some (JSON (`Assoc l)) -> (
match List.assoc_opt name l with
| Some (`List l) -> l |> List.map string_of_yojson_atom
@@ -74,42 +74,41 @@ let query_many name : request -> string list Lwt.t = function
let formdata name = function
| Request { body; _ } -> (
- match%lwt Lazy.force body with
+ match Lazy.force body with
| _, Some (MultipartFormdata { loaded; _ }) -> (
match List.assoc_opt name loaded with
- | Some s -> Lwt.return_ok s
- | None -> Lwt.return_error ("The name " ^ name ^ " was not found"))
- | _ -> Lwt.return_error "formdata: not MultipartFormdata"
- | exception _ -> Lwt.return_error "Couldn't read body")
+ | Some s -> Ok s
+ | None -> Error ("The name " ^ name ^ " was not found"))
+ | _ -> Error "formdata: not MultipartFormdata"
+ | exception _ -> Error "Couldn't read body")
let formdata_exn name r =
- match%lwt formdata name r with
- | Ok s -> Lwt.return s
+ match formdata name r with
+ | Ok s -> s
| Error _ -> raise_error_response `Bad_request
let query ?default name req =
match req with
| Request { body; query; _ } -> (
- try%lwt
- Lazy.force body >|= snd >>= function
+ try
+ match Lazy.force body |> snd with
| None -> failwith "query: body none"
| Some x -> (
match x with
- | JSON (`Assoc l) ->
- List.assoc name l |> string_of_yojson_atom |> Lwt.return
+ | JSON (`Assoc l) -> List.assoc name l |> string_of_yojson_atom
| JSON _ -> failwith "json"
| Form body -> (
match query |> List.assoc_opt name with
- | Some x -> Lwt.return x
- | None -> body |> List.assoc name |> List.hd |> Lwt.return)
+ | Some x -> x
+ | None -> body |> List.assoc name |> List.hd)
| MultipartFormdata _ ->
- formdata_exn name req >|= fun f -> f.content)
+ let f = formdata_exn name req in
+ f.content)
with
- | _ when default <> None -> Option.get default |> Lwt.return
+ | _ when default <> None -> Option.get default
| _ -> raise_error_response `Bad_request)
-let query_opt name r =
- try%lwt query name r >|= Option.some with _ -> Lwt.return_none
+let query_opt name r = try Some (query name r) with _ -> None
let header_opt name : request -> string option = function
| Request { headers; _ } -> headers |> List.assoc_opt name
@@ -121,13 +120,46 @@ let headers = function Request { headers; _ } -> headers
let path = function Request { path; _ } -> path
let meth = function Request { meth; _ } -> meth
+let load_formdata_from_stream out_stream =
+ let open Multipart_form in
+ let rec save_part loaded raw =
+ match Eio.Stream.take_nonblocking out_stream with
+ | None -> loaded
+ | Some (_, hdr, contents) ->
+ let loaded =
+ let ( let* ) v f = v |> Option.fold ~none:loaded ~some:f in
+ let* cd = Header.content_disposition hdr in
+ let* name = Content_disposition.name cd in
+ let filename = Content_disposition.filename cd in
+ let buf = Buffer.create 0 in
+ let rec loop () =
+ match Eio.Stream.take_nonblocking contents with
+ | None -> ()
+ | Some s ->
+ Buffer.add_string buf s;
+ loop ()
+ in
+ loop ();
+ ( name,
+ make_formdata_t ?filename ~content_type:(Header.content_type hdr)
+ ~content:(Buffer.contents buf) () )
+ :: loaded
+ in
+ save_part loaded raw
+ in
+ save_part [] []
+
let parse_body ~body ~headers =
let content_type = List.assoc_opt `Content_type headers in
match
content_type
- |> Option.map (String.split_on_char ';' *> List.hd *> String.trim)
+ |> Option.map (fun s ->
+ s |> String.split_on_char ';' |> List.hd |> String.trim)
with
| Some "multipart/form-data" ->
+ (* FIXME: Currenty all contents are stored on memory.
+ This is not the best choice from perspective of space efficiency.
+ We should utilize files on disk *)
let load_body () =
let open Multipart_form in
let content_type =
@@ -135,60 +167,74 @@ let parse_body ~body ~headers =
| Ok s -> s
| Error (`Msg _msg) -> raise_error_response `Bad_request
in
- let `Parse th, stream =
- Multipart_form_lwt.stream ~identify:Fun.id
- (Bare_server.Body.to_stream body)
- content_type
- in
- let rec save_part loaded raw =
- match%lwt Lwt_stream.get stream with
- | None -> Lwt.return loaded
- | Some (_, hdr, contents) ->
- (* FIXME: Currenty all contents are stored on memory.
- This is not the best choice from perspective of space efficiency.
- We should utilize files on disk *)
- let%lwt loaded =
- let ( let* ) v f =
- v |> Option.fold ~none:(Lwt.return loaded) ~some:f
- in
- let* cd = Header.content_disposition hdr in
- let* name = Content_disposition.name cd in
- let filename = Content_disposition.filename cd in
- let buf = Buffer.create 0 in
- Lwt_stream.iter (Buffer.add_string buf) contents;%lwt
- Lwt.return
- (( name,
- make_formdata_t ?filename
- ~content_type:(Header.content_type hdr)
- ~content:(Buffer.contents buf) () )
- :: loaded)
- in
- save_part loaded raw
+
+ let in_stream = Eio.Stream.create 1 in
+ Eio.Stream.add in_stream (Bare_server.Body.to_string body);
+ Eio.Switch.run @@ fun sw ->
+ let th, out_stream =
+ Multipart_form_eio.stream ~sw ~identify:Fun.id in_stream content_type
in
- match%lwt Lwt.both th (save_part [] []) with
- | Error _, _ -> raise_error_response `Bad_request
- | Ok _, data -> Lwt.return data
+ match Eio.Promise.await_exn th with
+ | _ -> load_formdata_from_stream out_stream
+ | exception _ -> raise_error_response `Bad_request
in
- load_body () >|= fun loaded -> (None, MultipartFormdata { loaded })
+ (None, MultipartFormdata { loaded = load_body () })
| Some "application/json" -> (
- Bare_server.Body.to_string body >|= fun raw_body ->
+ let raw_body = Bare_server.Body.to_string body in
( Some raw_body,
try JSON (Yojson.Safe.from_string raw_body) with _ -> Form [] ))
| Some "application/x-www-form-urlencoded" | _ ->
- Bare_server.Body.to_string body >|= fun raw_body ->
+ let raw_body = Bare_server.Body.to_string body in
(Some raw_body, Form (Uri.query_of_encoded raw_body))
-let default_handler : handler = function
+let default_handler : handler =
+ fun _env -> function
| Request req ->
let status =
match req.meth with `GET -> `Not_found | _ -> `Method_not_allowed
in
respond ~status ""
-let start_server ?(port = 8080) ?error_handler (handler : handler) k : unit Lwt.t =
- Bare_server.start_server port (k ())
+type ws_conn = Bare_server.ws_conn
+
+module Ws_conn_man = struct
+ type t = {
+ chan : (request * (ws_conn -> unit) * response Eio.Stream.t) Eio.Stream.t;
+ }
+
+ let global_runner = { chan = Eio.Stream.create 0 }
+
+ let start_global_runner env ~sw =
+ Eio.Fiber.fork ~sw (fun () ->
+ let rec loop () =
+ let req, callback, recv_stream = Eio.Stream.take global_runner.chan in
+ let resp =
+ match req with
+ | Request { bare_req; _ } ->
+ let r = Bare_server.websocket env ~sw bare_req callback in
+ BareResponse r
+ in
+ Eio.Stream.add recv_stream resp;
+ loop ()
+ in
+ loop ())
+
+ let start_ws_conn req callback =
+ let recv_chan = Eio.Stream.create 0 in
+ Eio.Stream.add global_runner.chan (req, callback, recv_chan);
+ Eio.Stream.take recv_chan
+end
+
+let websocket (r : request) f = Ws_conn_man.start_ws_conn r f
+let ws_send = Bare_server.ws_send
+let ws_recv = Bare_server.ws_recv
+
+let start_server env ~sw ?(listen = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8080))
+ ?error_handler (handler : handler) k : unit =
+ Ws_conn_man.start_global_runner env ~sw;
+ Bare_server.start_server ~listen env ~sw k
@@ fun (req : Bare_server.Request.t) (body : Bare_server.Body.t) :
- Bare_server.Response.t Lwt.t ->
+ Bare_server.Response.t ->
(* Parse req *)
let uri = Bare_server.Request.uri req in
let meth = Bare_server.Request.meth req in
@@ -199,9 +245,9 @@ let start_server ?(port = 8080) ?error_handler (handler : handler) k : unit Lwt.
in
let lazy_parsed_body =
lazy
- (match%lwt parse_body ~body ~headers with
- | exception _ -> Lwt.return (None, None)
- | raw_body, parsed_body -> Lwt.return (raw_body, Some parsed_body))
+ (match parse_body ~body ~headers with
+ | exception _ -> (None, None)
+ | raw_body, parsed_body -> (raw_body, Some parsed_body))
in
let req =
Request
@@ -219,11 +265,11 @@ let start_server ?(port = 8080) ?error_handler (handler : handler) k : unit Lwt.
in
(* Invoke the handler *)
- let%lwt res = handler req in
+ let res = handler env req in
(* Respond (after call error_handler if necessary *)
let rec aux first = function
- | BareResponse resp -> Lwt.return resp
+ | BareResponse resp -> resp
| Response { status; headers; body; _ }
when (not first)
|| Option.is_none error_handler
@@ -234,30 +280,19 @@ let start_server ?(port = 8080) ?error_handler (handler : handler) k : unit Lwt.
Bare_server.respond ~status ~headers ~body
| Response { status; headers; body; _ } ->
let error_handler = Option.get error_handler in
- error_handler ~req ~status ~headers ~body >>= aux false
+ error_handler ~req ~status ~headers ~body |> aux false
in
aux true res
-(* WebSocket *)
-type ws_conn = Bare_server.ws_conn
-
-let ws_send = Bare_server.ws_send
-let ws_recv = Bare_server.ws_recv
-
-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
- type route = Method.t * string * (request -> response Lwt.t)
+ type route = Method.t * string * handler
type spec_entry = Route of route | Scope of (string * spec)
and spec = spec_entry list
- let use (spec : spec) (inner_handler : handler) (req : request) :
- response Lwt.t =
+ let use (spec : spec) (inner_handler : handler) env (req : request) : response
+ =
let routes =
let rec aux (spec : spec) : route list =
spec
@@ -274,29 +309,31 @@ module Router = struct
match req with
| Request req -> (
- ((* Choose correct handler from routes *)
- let param, handler =
- routes
- |> List.find_map (fun (meth', pat, handler) ->
- if req.meth <> meth' then None
- else
- Path_pattern.perform ~pat req.path
- |> Option.map (fun param -> (param, handler)))
- |> Option.value ~default:([], inner_handler)
- in
- let req = Request { req with param } in
- try%lwt handler req with
- | ErrorResponse { status; body } ->
- Logq.debug (fun m ->
- m "Error response raised: %s\n%s" (Status.to_string status)
- (Printexc.get_backtrace ()));
- respond ~status ~tags:[ "log" ] body
- | e ->
- Logq.debug (fun m ->
- m "Exception raised: %s\n%s" (Printexc.to_string e)
- (Printexc.get_backtrace ()));
- respond ~status:`Internal_server_error "")
- >|= function
+ (* Choose correct handler from routes *)
+ let param, handler =
+ routes
+ |> List.find_map (fun (meth', pat, handler) ->
+ if req.meth <> meth' then None
+ else
+ Path_pattern.perform ~pat req.path
+ |> Option.map (fun param -> (param, handler)))
+ |> Option.value ~default:([], inner_handler)
+ in
+ let req = Request { req with param } in
+ let resp =
+ try handler env req with
+ | ErrorResponse { status; body } ->
+ Logq.debug (fun m ->
+ m "Error response raised: %s\n%s" (Status.to_string status)
+ (Printexc.get_backtrace ()));
+ respond ~status ~tags:[ "log" ] body
+ | e ->
+ Logq.debug (fun m ->
+ m "Exception raised: %s\n%s" (Printexc.to_string e)
+ (Printexc.get_backtrace ()));
+ respond ~status:`Internal_server_error ""
+ in
+ match resp with
| Response ({ status; tags; _ } as r) when Status.is_error status ->
Response { r with tags = "log" :: tags }
| r -> r)
@@ -323,10 +360,10 @@ module Cors = struct
let target_pat = Path_pattern.of_string target in
{ target; target_pat; methods; origin; expose }
- let use (src : t list) (inner_handler : handler) (req : request) :
- response Lwt.t =
+ let use (src : t list) (inner_handler : handler) env (req : request) :
+ response =
(* Handler for preflight OPTIONS requests *)
- let handler (r : t) (req : request) : response Lwt.t =
+ let handler (r : t) _ (req : request) : response =
let headers =
[
( `Access_control_allow_methods,
@@ -351,31 +388,32 @@ module Cors = struct
in
(* Construct router *)
- req
- |> Router.use routes @@ function
- (* Fallback handler: apply inner_handler, and
- if path matches, append CORS headers *)
- | Request { path; _ } as req -> (
- let path_match =
- src
- |> List.find_opt (fun { target_pat; _ } ->
- Path_pattern.perform ~pat:target_pat path |> Option.is_some)
- in
- inner_handler req >|= fun resp ->
- match (resp, path_match) with
- | _, None | BareResponse _, _ -> resp
- | Response res, Some { origin; expose; _ } ->
- Response
- {
- res with
- headers =
- (`Access_control_allow_origin, origin)
- :: ( `Access_control_expose_headers,
- expose
- |> List.map Header.string_of_name
- |> String.concat ", " )
- :: res.headers;
- })
+ Router.use routes
+ (fun env -> function
+ (* Fallback handler: apply inner_handler, and
+ if path matches, append CORS headers *)
+ | Request { path; _ } as req -> (
+ let path_match =
+ src
+ |> List.find_opt (fun { target_pat; _ } ->
+ Path_pattern.perform ~pat:target_pat path |> Option.is_some)
+ in
+ let resp = inner_handler env req in
+ match (resp, path_match) with
+ | _, None | BareResponse _, _ -> resp
+ | Response res, Some { origin; expose; _ } ->
+ Response
+ {
+ res with
+ headers =
+ (`Access_control_allow_origin, origin)
+ :: ( `Access_control_expose_headers,
+ expose
+ |> List.map Header.string_of_name
+ |> String.concat ", " )
+ :: res.headers;
+ }))
+ env req
end
(* Middlware Logger *)
@@ -389,25 +427,31 @@ module Logger = struct
Bare_server.Request.pp_hum fmt bare_req;
Format.pp_print_flush fmt ();
add_string buf "\n";
- ( body |> Lazy.force >|= fst >|= fun raw_body ->
- raw_body
- |> Option.iter (fun s ->
- add_string buf "\n";
- add_string buf s;
- add_string buf "\n") );%lwt
+ let raw_body =
+ if Http.Request.has_body bare_req = `Yes then
+ body |> Lazy.force |> fst
+ else None
+ in
+ raw_body
+ |> Option.iter (fun s ->
+ add_string buf "\n";
+ add_string buf s;
+ add_string buf "\n");
add_string buf "\n==============================\n";
add_string buf ("Status: " ^ Status.to_string status);
- Buffer.contents buf |> Lwt.return
+ Buffer.contents buf
| _ -> assert false
- let use ?dump_req_dir (inner_handler : handler) (req : request) :
- response Lwt.t =
+ let now () = Unix.gettimeofday () |> Ptime.of_float_s |> Option.get
+
+ let use ?dump_req_dir (inner_handler : handler) env (req : request) : response
+ =
let (Request { uri; meth; _ }) = req in
let meth = Method.to_string meth in
let uri = Uri.to_string uri in
Logq.debug (fun m -> m "%s %s" meth uri);
- let%lwt resp = inner_handler req in
+ let resp = inner_handler env req in
(match resp with
| Response { status; _ } ->
@@ -418,16 +462,10 @@ module Logger = struct
| Response { tags; _ } when List.mem "log" tags -> (
match dump_req_dir with
| None ->
- string_of_request_response req resp >|= fun s ->
+ let s = string_of_request_response req resp in
Logq.info (fun m -> m "Detail of request and response:\n%s" s)
- | Some dir ->
- (* NOTE: We use open_temp_file to make sure that each request is written to each file. So, this file should NOT be removed after we write the content to it. *)
- let prefix =
- Ptime.(now () |> to_float_s |> Printf.sprintf "%.2f") ^ "."
- in
- let%lwt _, oc = Lwt_io.open_temp_file ~temp_dir:dir ~prefix () in
- string_of_request_response req resp >>= Lwt_io.write oc)
- | _ -> Lwt.return_unit);%lwt
+ | Some _dir -> (* FIXME: implement here *) ())
+ | _ -> ());
- Lwt.return resp
+ resp
end
diff --git a/lib_httpq/signature.ml b/lib_yume/signature.ml
similarity index 96%
rename from lib_httpq/signature.ml
rename to lib_yume/signature.ml
index adb5a9a..f793965 100644
--- a/lib_httpq/signature.ml
+++ b/lib_yume/signature.ml
@@ -65,7 +65,10 @@ let may_cons_digest_header ?(prefix = "SHA-256") (headers : Headers.t)
(body : string option) : Headers.t =
body
|> Option.fold ~none:headers ~some:(fun body ->
- let digest = Sha256.(string body |> to_bin |> Base64.encode_exn) in
+ let digest =
+ body |> Cstruct.of_string |> Mirage_crypto.Hash.SHA256.digest
+ |> Cstruct.to_string |> Base64.encode_exn
+ in
let digest = prefix ^ "=" ^ digest in
match List.assoc_opt `Digest headers with
| Some v when v <> digest -> failwith "Digest not match"
diff --git a/lib_httpq/status.ml b/lib_yume/status.ml
similarity index 100%
rename from lib_httpq/status.ml
rename to lib_yume/status.ml
diff --git a/lib_yume/test/dune b/lib_yume/test/dune
new file mode 100644
index 0000000..35d9743
--- /dev/null
+++ b/lib_yume/test/dune
@@ -0,0 +1,10 @@
+(tests
+ (names test_signature test_path_pattern test_ws)
+ (libraries
+ alcotest
+ eio_main
+ yume
+ logq
+ mirage-crypto-rng
+ mirage-crypto-rng.unix
+ mirage-crypto-rng-eio))
diff --git a/lib_yume/test/test_path_pattern.ml b/lib_yume/test/test_path_pattern.ml
new file mode 100644
index 0000000..9ffb5d7
--- /dev/null
+++ b/lib_yume/test/test_path_pattern.ml
@@ -0,0 +1,19 @@
+open Yume
+
+let test_parse_path () =
+ let open Path_pattern in
+ assert (of_string "" = []);
+ assert (of_string "/foo/bar/2000" = [ L "foo"; L "bar"; L "2000" ]);
+ assert (of_string "/foo/:bar/2000" = [ L "foo"; P ":bar"; L "2000" ]);
+ assert (of_string "/foo/*" = [ L "foo"; S ]);
+ assert (of_string "/foo/:bar" = [ L "foo"; P ":bar" ]);
+ assert (perform ~pat:(of_string "/foo/:bar") "/foo/1" = Some [ (":bar", "1") ]);
+ assert (perform ~pat:(of_string "/foo/*") "/foo/1/2" |> Option.is_some);
+ assert (perform ~pat:(of_string "/foo/bar") "/foo/bar/" |> Option.is_some);
+ assert (perform ~pat:(of_string "/foo/bar") "/foo/bar//" |> Option.is_some);
+ ()
+
+let () =
+ let open Alcotest in
+ run "path_pattern"
+ [ ("parse_path", [ test_case "case1" `Quick test_parse_path ]) ]
diff --git a/test/test_http.ml b/lib_yume/test/test_signature.ml
similarity index 82%
rename from test/test_http.ml
rename to lib_yume/test/test_signature.ml
index 771fdcb..7fc82cd 100644
--- a/test/test_http.ml
+++ b/lib_yume/test/test_signature.ml
@@ -1,18 +1,4 @@
-open Waq
-open Httpq
-
-let test_parse_path () =
- let open Path_pattern in
- assert (of_string "" = []);
- assert (of_string "/foo/bar/2000" = [ L "foo"; L "bar"; L "2000" ]);
- assert (of_string "/foo/:bar/2000" = [ L "foo"; P ":bar"; L "2000" ]);
- assert (of_string "/foo/*" = [ L "foo"; S ]);
- assert (of_string "/foo/:bar" = [ L "foo"; P ":bar" ]);
- assert (perform ~pat:(of_string "/foo/:bar") "/foo/1" = Some [ (":bar", "1") ]);
- assert (perform ~pat:(of_string "/foo/*") "/foo/1/2" |> Option.is_some);
- assert (perform ~pat:(of_string "/foo/bar") "/foo/bar/" |> Option.is_some);
- assert (perform ~pat:(of_string "/foo/bar") "/foo/bar//" |> Option.is_some);
- ()
+open Yume
let test_build_signing_string () =
let signed_headers =
@@ -183,35 +169,13 @@ KgbztieZwDBihVKbPtiaiGxeNXrxGWfL37BB0Jcy/RRYomLBjwTj2Ks=
@@ Signature.verify ~pub_key ~algorithm ~signed_headers ~signature ~headers
~meth ~path ~body)
-let test_url () =
- (* Thanks to: https://ja.wikipedia.org/wiki/Uniform_Resource_Identifier *)
- let url =
- Uri.of_string
- "https://user:password@www.example.com:123/forum/questions/?tag=networking&order=newest#top"
- in
- assert (Uri.getaddrinfo_port url = "123");
- assert (Uri.http_host url = "www.example.com:123");
- assert (Uri.domain url = "www.example.com:123");
- assert (
- Uri.path_query_fragment url
- = "/forum/questions/?tag=networking&order=newest#top");
-
- let url = Uri.of_string "http://example.com" in
- assert (Uri.getaddrinfo_port url = "http");
- assert (Uri.http_host url = "example.com");
- assert (Uri.domain url = "example.com");
- assert (Uri.path_query_fragment url = "");
- ()
-
let () =
let open Alcotest in
- Crypto.initialize ();
- run "http"
+ Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna);
+ run "signature"
[
- ("parse_path", [ test_case "case1" `Quick test_parse_path ]);
( "build_signing_string",
[ test_case "case1" `Quick test_build_signing_string ] );
("sign", [ test_case "case1" `Quick test_sign ]);
("verify", [ test_case "case1" `Quick test_verify ]);
- ("url", [ test_case "case1" `Quick test_url ]);
]
diff --git a/lib_yume/test/test_ws.ml b/lib_yume/test/test_ws.ml
new file mode 100644
index 0000000..eb4e9e9
--- /dev/null
+++ b/lib_yume/test/test_ws.ml
@@ -0,0 +1,56 @@
+open Yume
+
+let test_basic () =
+ let recv_text = ref "" in
+ let expected_string = "TEST TEXT" in
+ Eio_main.run (fun env ->
+ Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env
+ @@ fun () ->
+ try
+ Eio.Time.with_timeout_exn env#clock 3.0 @@ fun () ->
+ let handler =
+ let open Server in
+ default_handler
+ |> Router.(
+ use
+ [
+ get "/ws" (fun _ req ->
+ websocket req (fun ws_conn ->
+ recv_text :=
+ ws_recv ws_conn |> Option.value ~default:!recv_text));
+ ])
+ in
+ let listen =
+ Eio.Net.getaddrinfo_stream ~service:"0" env#net "localhost" |> List.hd
+ in
+ Eio.Switch.run @@ fun sw ->
+ Server.start_server env ~listen ~sw handler (fun socket ->
+ let listening_port =
+ match Eio.Net.listening_addr socket with
+ | `Tcp (_, port) -> port
+ | _ -> assert false
+ in
+ let ws_conn =
+ let rec loop () =
+ Eio.Time.sleep env#clock 1.0;
+ try
+ Ws.Client.connect ~sw env
+ (Printf.sprintf "http://localhost:%d/ws" listening_port)
+ with e ->
+ Logq.err (fun m ->
+ m "Ws.Client.connect failed: %s" (Printexc.to_string e));
+ loop ()
+ in
+ loop ()
+ in
+ Ws.Client.write ws_conn
+ (Websocket.Frame.create ~opcode:Text ~content:expected_string ());
+ ())
+ with Eio.Time.Timeout -> ());
+ assert (!recv_text = expected_string);
+ ()
+
+let () =
+ let open Alcotest in
+ Logq.(add_reporter (make_stderr_reporter ~l:Debug));
+ run "ws" [ ("basic", [ test_case "case1" `Quick test_basic ]) ]
diff --git a/lib_yume/ws.ml b/lib_yume/ws.ml
new file mode 100644
index 0000000..0b40a53
--- /dev/null
+++ b/lib_yume/ws.ml
@@ -0,0 +1,211 @@
+open struct
+ let random_string len = Mirage_crypto_rng.generate len |> Cstruct.to_string
+
+ let b64_encoded_sha1sum s =
+ s |> Cstruct.of_string |> Mirage_crypto.Hash.SHA1.digest
+ |> Cstruct.to_string |> Base64.encode_exn
+end
+
+open Websocket.Make (Cohttp_eio.Private.IO)
+
+module Client = struct
+ type 'a conn = {
+ id : string;
+ read_frame : unit -> Websocket.Frame.t;
+ write_frame : Websocket.Frame.t option -> unit;
+ socket : 'a Eio.Net.stream_socket_ty Eio.Resource.t;
+ }
+
+ let drain_handshake req ic oc nonce =
+ Request.write (fun _ -> ()) req oc;
+ let resp =
+ match Response.read ic with
+ | `Ok r -> r
+ | `Eof -> raise End_of_file
+ | `Invalid s -> failwith s
+ in
+ let status = Cohttp.Response.status resp in
+ let headers = Cohttp.Response.headers resp in
+ if Cohttp.Code.(is_error (code_of_status status)) then
+ failwith ("error status: " ^ Cohttp.Code.(string_of_status status));
+ if Cohttp.Response.version resp <> `HTTP_1_1 then
+ failwith "invalid HTTP version";
+ if status <> `Switching_protocols then failwith "wrong status";
+ (match Cohttp.Header.get headers "upgrade" with
+ | Some a when String.lowercase_ascii a = "websocket" -> ()
+ | _ -> failwith "wrong upgrade");
+ if not (Websocket.upgrade_present headers) then
+ failwith "upgrade header not present";
+ (match Cohttp.Header.get headers "sec-websocket-accept" with
+ | Some accept
+ when accept = b64_encoded_sha1sum (nonce ^ Websocket.websocket_uuid) ->
+ ()
+ | _ -> failwith "wrong accept");
+ ()
+
+ let connect' env sw url nonce extra_headers =
+ (* Make request *)
+ let headers =
+ Cohttp.Header.add_list extra_headers
+ [
+ ("Upgrade", "websocket");
+ ("Connection", "Upgrade");
+ ("Sec-WebSocket-Key", nonce);
+ ("Sec-WebSocket-Version", "13");
+ ]
+ in
+ let req = Cohttp.Request.make ~headers url in
+
+ (* Make socket *)
+ let host = Uri.host url |> Option.get in
+ let service =
+ match Uri.port url with
+ | Some port -> string_of_int port
+ | None -> (
+ match Uri.scheme url with
+ | Some "ws" -> "http"
+ | Some "wss" -> "https"
+ | Some scheme -> scheme
+ | None -> "http")
+ in
+ let addr =
+ match Eio.Net.getaddrinfo_stream (Eio.Stdenv.net env) host ~service with
+ | [] -> failwith "getaddrinfo failed"
+ | addr :: _ -> addr
+ in
+ let socket = Eio.Net.connect ~sw (Eio.Stdenv.net env) addr in
+ let flow =
+ let tls_enabled =
+ match service with "443" | "https" -> true | _ -> false
+ in
+ if not tls_enabled then (socket :> Eio.Flow.two_way_ty Eio.Resource.t)
+ else
+ let authenticator =
+ let null_auth ?ip:_ ~host:_ _ = Ok None in
+ null_auth
+ in
+ let host =
+ Result.to_option
+ (Result.bind (Domain_name.of_string host) Domain_name.host)
+ in
+ let client =
+ Tls_eio.client_of_flow
+ Tls.Config.(
+ client ~version:(`TLS_1_0, `TLS_1_3) ~authenticator
+ ~ciphers:Ciphers.supported ())
+ ?host socket
+ in
+ (client :> Eio.Flow.two_way_ty Eio.Resource.t)
+ in
+
+ (* Drain handshake *)
+ let ic = Eio.Buf_read.of_flow ~max_size:max_int flow in
+ Eio.Buf_write.with_flow flow (fun oc -> drain_handshake req ic oc nonce);
+
+ (socket, flow, ic)
+
+ let connect ?(extra_headers = Cohttp.Header.init ()) ~sw env url =
+ let url = Uri.of_string url in
+
+ let nonce = Base64.encode_exn (random_string 16) in
+ let socket, flow, ic = connect' env sw url nonce extra_headers in
+
+ (* Start writer fiber. All writes must be done in this fiber,
+ because Eio.Flow.write is not thread-safe.
+ c.f.: https://github.com/ocaml-multicore/eio/blob/v0.11/lib_eio/flow.mli#L73-L74
+ *)
+ let write_queue = Eio.Stream.create 10 in
+ (let rec writer () =
+ try
+ let frame = Eio.Stream.take write_queue in
+ match frame with
+ | None -> ()
+ | Some frame ->
+ let buf = Buffer.create 128 in
+ write_frame_to_buf ~mode:(Client random_string) buf frame;
+ Eio.Buf_write.with_flow flow (fun oc ->
+ Eio.Buf_write.string oc (Buffer.contents buf));
+ writer ()
+ with Eio.Io _ -> ()
+ in
+ Eio.Fiber.fork ~sw writer);
+
+ let write_frame frame = Eio.Stream.add write_queue frame in
+ let read_frame () =
+ Eio.Buf_write.with_flow flow (fun oc ->
+ make_read_frame ~mode:(Client random_string) ic oc ())
+ in
+
+ { socket; id = random_string 10; read_frame; write_frame }
+
+ let id { id; _ } = id
+ let read { read_frame; _ } = read_frame ()
+ let write { write_frame; _ } frame = write_frame (Some frame)
+
+ let close_transport { socket; write_frame; _ } =
+ write_frame None;
+ Eio.Net.close socket
+end
+
+module Server = struct
+ let read_frames ic oc handler_fn =
+ let read_frame = make_read_frame ~mode:Server ic oc in
+ let rec inner () = read_frame () |> handler_fn |> inner in
+ inner ()
+
+ let send_frames stream oc =
+ let buf = Buffer.create 128 in
+ let send_frame fr =
+ Buffer.clear buf;
+ write_frame_to_buf ~mode:Server buf fr;
+ Eio.Buf_write.string oc (Buffer.contents buf)
+ in
+ let rec inner () =
+ match Eio.Stream.take stream with
+ | None -> () (* end of stream *)
+ | Some fr ->
+ send_frame fr;
+ inner ()
+ in
+ inner ()
+
+ let upgrade_connection request incoming_handler =
+ let headers = Cohttp.Request.headers request in
+ let key =
+ match Cohttp.Header.get headers "sec-websocket-key" with
+ | Some key -> key
+ | None ->
+ failwith "upgrade_connection: missing header `sec-websocket-key`"
+ in
+ let hash = b64_encoded_sha1sum (key ^ Websocket.websocket_uuid) in
+ let response_headers =
+ Cohttp.Header.of_list
+ [
+ ("Upgrade", "websocket");
+ ("Connection", "Upgrade");
+ ("Sec-WebSocket-Accept", hash);
+ ]
+ in
+ let resp =
+ Cohttp.Response.make ~status:`Switching_protocols
+ ~encoding:Cohttp.Transfer.Unknown ~headers:response_headers ~flush:true
+ ()
+ in
+ let frames_out_stream = Eio.Stream.create 10 in
+ let frames_out_fn = Eio.Stream.add frames_out_stream in
+ let handle_conn ic oc =
+ let handler = incoming_handler frames_out_fn in
+ (try
+ Eio.Fiber.both
+ (fun () -> read_frames ic oc (fun fr -> handler (Some fr)))
+ (fun () -> send_frames frames_out_stream oc)
+ with
+ | End_of_file -> ()
+ | e ->
+ Logq.err (fun m ->
+ m "ws connection broken by exc: %s: %s" (Printexc.to_string e)
+ (Printexc.get_backtrace ())));
+ handler None
+ in
+ (`Expert (resp, handle_conn), frames_out_fn)
+end
diff --git a/lib_httpq/httpq.ml b/lib_yume/yume.ml
similarity index 80%
rename from lib_httpq/httpq.ml
rename to lib_yume/yume.ml
index 53f95a0..7b1b855 100644
--- a/lib_httpq/httpq.ml
+++ b/lib_yume/yume.ml
@@ -1,9 +1,10 @@
-module Client = Client
+module Path_pattern = Path_pattern
+module Status = Status
module Header = Header
module Headers = Headers
module Method = Method
-module Path_pattern = Path_pattern
+module Ws = Ws
+module Bare_server = Bare_server
module Server = Server
+module Client = Client
module Signature = Signature
-module Status = Status
-module Uri = Util.Uri
diff --git a/test/dune b/test/dune
index 36bfaa4..95f80dd 100644
--- a/test/dune
+++ b/test/dune
@@ -1,5 +1,5 @@
(tests
- (names test_http test_util test_text_helper test_regex test_ogp)
+ (names test_util test_text_helper test_regex test_ogp)
(preprocess
(pps lwt_ppx))
- (libraries alcotest alcotest-lwt httpq logq waq))
+ (libraries alcotest alcotest-lwt logq waq))
diff --git a/waq.opam b/waq.opam
index 5977a90..eee3973 100644
--- a/waq.opam
+++ b/waq.opam
@@ -19,7 +19,7 @@ depends: [
"camlimages"
"cmdliner"
"cohttp"
- "cohttp-lwt-unix"
+ "cohttp-eio"
"cppo"
"cstruct"
"eio"
@@ -32,9 +32,10 @@ depends: [
"lwt_eio"
"lwt_ppx"
"lwt_ssl"
- "mirage-crypto-rng" {<= "0.10.7"}
+ "mirage-crypto-rng"
+ "mirage-crypto-rng-eio"
"multipart_form"
- "multipart_form-lwt"
+ "multipart_form-eio"
"ocaml" {>= "5.1.0"}
"pcre"
"postgresql"
@@ -45,10 +46,10 @@ depends: [
"result"
"safepass"
"sha"
+ "tls-eio"
"uri"
"uuidm"
"websocket"
- "websocket-lwt-unix"
"x509"
"xml-light"
"yaml"
@@ -71,5 +72,10 @@ 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://github.com/ushitora-anqou/camlimages.git#90ceb604527e5e1daddc969d920ff37d118b8a60" ]
+ [ "websocket.2.16" "git+https://github.com/ushitora-anqou/ocaml-websocket#74988ec5ec7d7c620e7d58c5509acd003107c513" ]
+ [ "multipart_form.0.5.0" "git+https://github.com/dinosaure/multipart_form#a794239b8fc9601540ffea489b2c470227216c5e" ]
+ [ "multipart_form-eio.0.5.0" "git+https://github.com/dinosaure/multipart_form#a794239b8fc9601540ffea489b2c470227216c5e" ]
]