feat(portal_tcp, portal_ws): error handling in negotiate

2 files changed, 26 insertions, 29 deletions

diff --git a/portal/tcp/portal.ml b/portal/tcp/portal.ml
index e44732d..290975c 100644
--- a/portal/tcp/portal.ml
+++ b/portal/tcp/portal.ml
@@ -29,22 +29,21 @@ let header ?from domain ((stream, push) : t) =
 
            If you have Github, feel free to get the word out to aantron. *)
         `Comment ""]
-  and error = Lwt.fail_with "TODO"
   in push (Some (of_list stanza));
-     let* xml = Markup_lwt.next stream
-     in match xml with
-        | Some `Xml {version="1.0"; encoding=None; standalone=None} ->
-           let* stream_open = Markup_lwt.next stream in
-           begin
-             match stream_open with
-             | Some `Start_element ((ns, "stream"), attributes) when ns = xmlns->
-                List.find_map
-                  (fun ((_, name), value) -> if name = "id" then Some value else None)
-                  attributes
-                |> Option.fold ~none:error ~some:Lwt.return
-             | _ -> error
-           end
-        | _ -> error
+     let some_id ((_, name), value) = if name = "id" then Some value else None in
+     let* xml = Markup_lwt.next stream in
+     let* id = match xml with
+       | Some `Xml {version="1.0"; encoding=None; standalone=None} ->
+          let* stream_open = Markup_lwt.next stream in
+          begin match stream_open with
+          | Some `Start_element ((ns, "stream"), attributes) when ns = xmlns->
+             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 (_, push) = [`End_element] |> Markup.of_list |> Option.some |> push
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