diff options
| -rw-r--r-- | portal/tcp/portal.ml | 19 |
1 files changed, 17 insertions, 2 deletions
diff --git a/portal/tcp/portal.ml b/portal/tcp/portal.ml index 32ff507..1ff4058 100644 --- a/portal/tcp/portal.ml +++ b/portal/tcp/portal.ml @@ -8,7 +8,7 @@ let xmlns = "jabber:client" exception MalformedStanza of Markup.location * Markup.Error.t -let stanza_open ?from domain : (signal, sync) stream = +let negotiate ?from domain ((stream, push) : t) = let stanza = let attributes = [(("", "to"), domain); (("", "version"), "1.0"); @@ -29,7 +29,22 @@ let stanza_open ?from domain : (signal, sync) stream = If you have Github, feel free to get the word out to aantron. *) `Comment ""] - in stanza |> of_list + 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 (("http://etherx.jabber.org/streams", "stream"), attributes) -> + 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 stanza_close : (signal, sync) stream = [`End_element] |> Markup.of_list |