diff options
| -rw-r--r-- | lib/sasl.ml | 2 | ||||
| -rw-r--r-- | lib/stream.ml | 6 | ||||
| -rw-r--r-- | portal/portal.mli | 7 | ||||
| -rw-r--r-- | portal/tcp/portal.ml | 13 | ||||
| -rw-r--r-- | portal/ws/portal.ml | 13 | ||||
| -rw-r--r-- | test/hello.ml | 14 |
6 files changed, 32 insertions, 23 deletions
diff --git a/lib/sasl.ml b/lib/sasl.ml index 137d84a..02c9222 100644 --- a/lib/sasl.ml +++ b/lib/sasl.ml @@ -29,7 +29,7 @@ let parse_sasl_error = function type sasl_auth = (string option, sasl_error * (string * string) option) result -let send_auth_stanza (stream, push) localpart pass mechanism = +let send_auth_stanza ({stream; push} : Portal.t) localpart pass mechanism = let gen_auth = function | PLAIN -> Base64.encode_exn ("\x00" ^ localpart ^ "\x00" ^ pass) | Unknown s -> failwith "Unsupported authentication mechanism " ^ s diff --git a/lib/stream.ml b/lib/stream.ml index ff3b939..a4795ef 100644 --- a/lib/stream.ml +++ b/lib/stream.ml @@ -43,7 +43,7 @@ let parse_features (el : Xml.element) : features = Basically, it conforms to {{: https://datatracker.ietf.org/doc/html/rfc6120#section-4.3 }}. *) -let negotiate (domain : string) ((stream, push) : Portal.t) : features Lwt.t = - let* _id = Portal.header domain (stream, push) - in let+ features = Xml.get stream >|= parse_features +let negotiate (domain : string) (portal : Portal.t) : features Lwt.t = + let* _id = Portal.header domain portal + in let+ features = Xml.get portal.stream >|= parse_features in features diff --git a/portal/portal.mli b/portal/portal.mli index d57a839..1fe90ef 100644 --- a/portal/portal.mli +++ b/portal/portal.mli @@ -2,10 +2,13 @@ open Markup exception MalformedStanza of location * Error.t -type t = (signal, async) stream * ((signal, sync) stream option -> unit) - type socket +type t = { + stream : (signal, async) stream; + push : (signal, sync) stream option -> unit; + } + (** This is the XML namespace of the underlying element stream. You can rely on it on your code, as an escape hatch, but you should probably not, diff --git a/portal/tcp/portal.ml b/portal/tcp/portal.ml index 3477429..931cf93 100644 --- a/portal/tcp/portal.ml +++ b/portal/tcp/portal.ml @@ -2,15 +2,18 @@ open Lwt.Syntax open Lwt_unix open Markup -type t = (signal, async) stream * ((signal, sync) stream option -> unit) - type socket = file_descr +type t = { + stream : (signal, async) stream; + push : (signal, sync) stream option -> unit; + } + let xmlns = "http://etherx.jabber.org/streams" exception MalformedStanza of Markup.location * Markup.Error.t -let header ?from domain ((stream, push) : t) = +let header ?from domain ({stream; push} : t) = let stanza = let attributes = [(("", "to"), domain); (("", "version"), "1.0"); @@ -48,7 +51,7 @@ let header ?from domain ((stream, push) : t) = | None -> Lwt.fail_with "Invalid stream opening server-side." -let close (_, push) = [`End_element] |> Markup.of_list |> Option.some |> push +let close {push; _} = [`End_element] |> Markup.of_list |> Option.some |> push (** [xmpp_port domain] is the port where [domain]'s XMPP server is hosted. @@ -99,4 +102,4 @@ let connect (domain : string) : t Lwt.t = in Lwt.async (fun () -> let* _ = lwt_stream xml_stream |> Markup_lwt.write_xml |> iter send in Lwt_unix.close tcp_socket); - stream, push + {stream; push} diff --git a/portal/ws/portal.ml b/portal/ws/portal.ml index b2d21e1..ee4b636 100644 --- a/portal/ws/portal.ml +++ b/portal/ws/portal.ml @@ -5,10 +5,13 @@ open Markup let jss = Js.string let sjs = Js.to_string -type t = (signal, async) stream * ((signal, sync) stream option -> unit) - type socket = WebSockets.webSocket Js.t +type t = { + stream : (signal, async) stream; + push : (signal, sync) stream option -> unit; + } + let xmlns = "urn:ietf:params:xml:ns:xmpp-framing" (* sic. XEP-0156: "host-meta files MUST be fetched only over HTTPS". I don't make the @@ -18,7 +21,7 @@ let well_known_of (domain : string) = "https://" ^ domain ^ "/.well-known/host-m (** [open_stanza domain] is an <open /> stanza for [domain]. If [from] is specified, the <open /> stanza has the from parameter. *) -let header ?from domain (stream, push) = +let header ?from domain {stream; push} = let stanza = let attributes = let open Option in @@ -46,7 +49,7 @@ let header ?from domain (stream, push) = | Some id -> Lwt.return id | None -> Lwt.fail_with "Invalid stream opening server-side." -let close (_, p) = +let close {push=p; _} = {|<close xmlns="|} ^ xmlns ^ {|" />|} |> string |> parse_xml |> signals |> Option.some |> p exception MalformedStanza of Markup.location * Markup.Error.t @@ -150,4 +153,4 @@ let connect domain = |> map (fun x -> write_xml x |> to_string) |> to_lwt_stream |> Lwt_stream.iter (fun s -> ws_push (Some s))); - stream, push + {stream; push} diff --git a/test/hello.ml b/test/hello.ml index 1659787..9b58de1 100644 --- a/test/hello.ml +++ b/test/hello.ml @@ -2,15 +2,15 @@ open! Lwt.Syntax open! Lwt.Infix open! Flesh -let program (stream, push) config (features : Stream.features) = - let+ _auth = Sasl.authenticate (stream, push) config features.mechanisms +let program (p : Portal.t) config (features : Stream.features) = + let+ _auth = Sasl.authenticate p config features.mechanisms in begin match _auth with | Error (NotAuthorized, Some (_, text)) -> print_endline ("Not authorized: " ^ text) | Error (MalformedRequest, Some (_, text)) -> print_endline ("Malformed request: " ^ text) | Error _ -> print_endline "Error!" | Ok _ -> print_endline "Success!" end; - Portal.close (stream, push) + Portal.close p let main = let config : Sasl.auth_config = { @@ -19,12 +19,12 @@ let main = preferred_mechanisms = [Sasl.PLAIN] } in let domain = (List.nth (String.split_on_char '@' config.jid) 1) in - let* stream, push = Portal.connect domain in - let* features = Stream.negotiate domain (stream, push) in + let* portal = Portal.connect domain in + let* features = Stream.negotiate domain portal in Lwt.catch - (fun () -> program (stream, push) config features >|= (fun () -> push None)) + (fun () -> program portal config features >|= (fun () -> portal.push None)) (fun exn -> - push None; + portal.push None; (* I suspect JavaScript's [wrap_callback] swallows the Exceptions thrown by OCaml, so... The next best thing is probably printing something. *) print_endline |