feat(portal_tcp, portal_ws): error handling in negotiate

1 files changed, 12 insertions, 14 deletions

diff --git a/portal/ws/portal.ml b/portal/ws/portal.ml
index fd67ad2..5cfc88a 100644
--- a/portal/ws/portal.ml
+++ b/portal/ws/portal.ml
@@ -29,22 +29,20 @@ let header ?from domain (stream, push) =
        ((xmlns, "open"),
         attributes);
      `End_element]
-  and error = Lwt.fail_with "TODO"
   in push (Some (of_list stanza));
+     let some_id ((_, name), value) = if name = "id" then Some value else None in
      let* stanza_open = Markup_lwt.next stream in
-     let some id =
-       let* close = Markup_lwt.next stream in
-       match close with
-       | Some `End_element -> Lwt.return id
-       | _ -> error
-     in
-     match stanza_open with
-     | Some `Start_element ((ns, "open"), attributes) when ns = xmlns ->
-        List.find_map
-          (fun ((_, name), value) -> if name = "id" then Some value else None)
-          attributes
-        |> Option.fold ~none:error ~some
-     | _ -> error
+     let* id = match stanza_open with
+       | Some `Start_element ((ns, "open"), attributes) when ns = xmlns ->
+          let* close = Markup_lwt.next stream in
+          begin match close with
+          | Some `End_element -> List.find_map some_id attributes |> Lwt.return
+          | _ -> Lwt.return_none
+          end
+       | _ -> Lwt.return_none
+     in match id with
+        | Some id -> Lwt.return id
+        | None -> Lwt.fail_with "Invalid stream opening server-side."
 
 let close (_, p) =
   {|<close xmlns="|} ^ xmlns ^ {|" />|} |> string |> parse_xml |> signals |> Option.some |> p