lib/iweb.ml

@@ -231,6 +231,8 @@ let xhtmlform ?(clz = "") tit name (ips : Html.Form.input list) err (dat : Html.
                :: sep 0 :: [])
        :: sep 0 :: [])
 
+let (let*%) = Http.(let*%)
+
 (** HTTP endpoint for ping and loop (Main.Queue). *)
 module Ping = struct
   (** HTTP GET handler to receive a ping.
@@ -245,12 +247,12 @@ module Ping = struct
     | [("nudge",_)] ->
       Main.Queue.ping_and_forget ~base ~run_delay_s
     | [("loop",_)] -> (
-        match Ap.PubKeyPem.(private_of_pem pk_pem) with
-        | Ok pk ->
-          Main.Queue.(loop ~base ~run_delay_s (process_new_and_due ~pk ~base))
-        | Error e ->
-          Logr.warn (fun m -> m "%s.%s %s" "Iweb.Ping" "get" e);
-          Lwt.return Http.s500 )
+        let*% pk = Ap.PubKeyPem.(private_of_pem pk_pem)
+                   |> Result.map_error (fun e ->
+                       Logr.warn (fun m -> m "%s.%s %s" "Iweb.Ping" "get" e);
+                       Http.s500' ) in
+        Main.Queue.(loop ~base ~run_delay_s (process_new_and_due ~pk ~base))
+      )
     | _ -> Lwt.return Http.s400
 end
 
@@ -483,8 +485,6 @@ let uid_redir x : (Auth.uid * Cgi.Request.t, Cgi.Response.t) result =
       Ok (Auth.dummy, r))
     else r302 Passwd.path
 
-let (let*%) = Http.(let*%)
-
 (** HTTP endpoint for Profile documents and (un)follow/(un)block. *)
 module Actor = struct
   let path = "/activitypub/actor.xml"
@@ -669,30 +669,29 @@ module Actor = struct
       let query = r.query_string |> Uri.query_of_encoded in
       match query with
       | ["id",[u]] ->
-        (match Ap.PubKeyPem.(private_of_pem pk_pem) with
-         | Error e ->
-           Logr.warn (fun m -> m "%s.%s %s" "Iweb.Actor.Icon" "get" e);
-           Lwt.return Http.s500
-         | Ok pk ->
-           let date = Ptime_clock.now () in
-           let base = base () in
-           let key_id = Uri.make ~path:Ap.proj () |> Http.reso ~base |> Ap.Person.my_key_id in
-           let key = Some (Http.Signature.mkey key_id pk date) in
-           let%lwt act =
-             u
-             |> Uri.of_string
-             |> Ap.Actor.http_get ~key in
-           (match act with
-            | Error s ->
-              Logr.warn (fun m -> m "%s.%s %a %s" "Iweb.Avatar" "get" Uuidm.pp uuid s);
-              Http.s502 ~body:(s |> Cgi.Response.body ~ee:E.e1043)
-            | Ok p ->
-              match p.icon with
-              | [] -> Http.s400
-              | i :: _ ->  i
-                           |> Uri.to_string
-                           |> Http.s302)
-           |> Lwt.return)
+        (let*% pk =  Ap.PubKeyPem.(private_of_pem pk_pem)
+                     |> Result.map_error (fun e ->
+                         Logr.warn (fun m -> m "%s.%s %s" "Iweb.Actor.Icon" "get" e);
+                         Http.s500' )
+         in
+         let date = Ptime_clock.now () in
+         let base = base () in
+         let key_id = Uri.make ~path:Ap.proj () |> Http.reso ~base |> Ap.Person.my_key_id in
+         let key = Some (Http.Signature.mkey key_id pk date) in
+         let%lwt act =
+           u
+           |> Uri.of_string
+           |> Ap.Actor.http_get ~key in
+         let*% p = act
+                   |> Result.map_error (fun s ->
+                       Logr.warn (fun m -> m "%s.%s %a %s" "Iweb.Avatar" "get" Uuidm.pp uuid s);
+                       Http.s502' ~body:(s |> Cgi.Response.body ~ee:E.e1043) ) in
+         (match p.icon with
+          | [] ->  Http.s400
+          | i :: _ -> i
+                      |> Uri.to_string
+                      |> Http.s302
+         ) |> Lwt.return)
       | _ -> Http.s404
              |> Lwt.return
   end
@@ -797,25 +796,24 @@ module Http_ = struct
     let%lwt p = u
                 |> Uri.of_string
                 |> Http.get ~key ~headers in
-    match p with
-    | Error e ->
-      Logr.warn (fun m -> m "%s.%s %a responded %s" "Iweb.Http_" "get" Uuidm.pp uuid e);
-      Http.s422 |> Lwt.return
-    | Ok (r,b) ->
-      match r.status with
-      | #Cohttp.Code.success_status ->
-        let ct = "content-type"
-                 |> Cohttp.Header.get r.headers
-                 |> Option.value ~default:Http.Mime.text_plain
-                 |> Http.H.content_type in
-        let%lwt b = b |> Cohttp_lwt.Body.to_string in
-        Ok (`OK, [ct], Cgi.Response.body b)
-        |> Lwt.return
-      | s ->
-        let s = s |> Cohttp.Code.string_of_status in
-        Logr.warn (fun m -> m "%s.%s %a responded %a" "Iweb.Http_" "get" Uuidm.pp uuid Http.pp_status r.status);
-        Http.s502 ~body:(s |> Cgi.Response.body ~ee:E.e1044)
-        |> Lwt.return
+    let*% (r,b) = p
+                  |> Result.map_error (fun e ->
+                      Logr.warn (fun m -> m "%s.%s %a responded %s" "Iweb.Http_" "get" Uuidm.pp uuid e);
+                      Http.s422' ) in
+    match r.status with
+    | #Cohttp.Code.success_status ->
+      let ct = "content-type"
+               |> Cohttp.Header.get r.headers
+               |> Option.value ~default:Http.Mime.text_plain
+               |> Http.H.content_type in
+      let%lwt b = b |> Cohttp_lwt.Body.to_string in
+      Ok (`OK, [ct], Cgi.Response.body b)
+      |> Lwt.return
+    | s ->
+      let s = s |> Cohttp.Code.string_of_status in
+      Logr.warn (fun m -> m "%s.%s %a responded %a" "Iweb.Http_" "get" Uuidm.pp uuid Http.pp_status r.status);
+      Http.s502 ~body:(s |> Cgi.Response.body ~ee:E.e1044)
+      |> Lwt.return
 end
 
 (*