From 7444155d05a63fdbad93ee6f54d92efe32f2e337 Mon Sep 17 00:00:00 2001
From: Clombrong <cromblong@egregore.fun>
Date: Wed, 11 Jun 2025 19:24:26 +0200
Subject: feat: move auth to sasl

---
 lib/auth.ml                 | 49 ---------------------------------------------
 lib/flesh.ml                |  2 +-
 lib/sasl.ml                 | 49 +++++++++++++++++++++++++++++++++++++++++++++
 test/js/websockets_hello.ml |  4 ++--
 4 files changed, 52 insertions(+), 52 deletions(-)
 delete mode 100644 lib/auth.ml
 create mode 100644 lib/sasl.ml

diff --git a/lib/auth.ml b/lib/auth.ml
deleted file mode 100644
index 606beb6..0000000
--- a/lib/auth.ml
+++ /dev/null
@@ -1,49 +0,0 @@
-open Lwt.Syntax
-
-type auth_mechanism = PLAIN  [@@deriving show { with_path = false }]
-
-type sasl_error =
-  | NotAuthorized
-  | MalformedRequest
-
-let read_sasl_error = function
-  | "not-authorized" -> NotAuthorized
-  | "malformed-request" -> MalformedRequest
-  | _ -> failwith "Unsupported SASL error returned by the server."
-
-type sasl_auth = (string option, sasl_error * (string * string) option) result
-
-let send_auth_stanza (stream, push) jid pass mechanism =
-  let gen_auth = function
-    | PLAIN -> Base64.encode_exn ("\x00" ^ jid ^ "\x00" ^ pass)
-  and parse_sasl_response stanza =
-    let open Markup in
-    let parse_additional_info = function
-      | `Text t :: _ -> Some (String.concat "" t)
-      | _ -> None
-    and parse_descriptive_text = function
-      | `Start_element ((_, "text"), [((_, "lang"), lang)]) :: `Text desc :: _ -> Some (lang, String.concat "" desc)
-      | `Start_element ((_, "text"), []) :: `Text desc :: _ -> Some ("en", String.concat "" desc)
-      | _ -> None
-    in
-    let parse_sasl_error = function
-      | `Start_element ((_, error), _) :: `End_element :: rest -> (read_sasl_error error, parse_descriptive_text rest)
-      | _ -> raise (Stream.InvalidStanza stanza)
-    in match (string stanza |> parse_xml |> signals |> to_list) with
-       | `Start_element ((_, "success"), _) :: rest -> Ok (parse_additional_info rest)
-       | `Start_element ((_, "failure"), _) :: rest -> Error (parse_sasl_error rest)
-       | _ -> raise (Stream.InvalidStanza stanza)
-  in let xmlns = "urn:ietf:params:xml:ns:xmpp-sasl" in
-     let stanza_list = [`Start_element
-                          ((xmlns, "auth"),
-                           [(("", "xmlns"), xmlns);
-                            (("", "mechanism"), show_auth_mechanism mechanism)]);
-                        `Text [gen_auth mechanism];
-                        `End_element]
-     in Markup.(stanza_list |> of_list |> write_xml |> to_string) |> Option.some |> push;
-        let* response = Lwt_stream.get stream
-        in try
-          match response with
-          | Some stanza -> parse_sasl_response stanza |> Lwt.return
-          | None -> Lwt.fail Stream.ClosedStream
-        with exn -> Lwt.fail exn
diff --git a/lib/flesh.ml b/lib/flesh.ml
index 6bf7fa0..d8aca97 100644
--- a/lib/flesh.ml
+++ b/lib/flesh.ml
@@ -1,2 +1,2 @@
 module Stream = Stream
-module Auth = Auth
+module Sasl = Sasl
diff --git a/lib/sasl.ml b/lib/sasl.ml
new file mode 100644
index 0000000..606beb6
--- /dev/null
+++ b/lib/sasl.ml
@@ -0,0 +1,49 @@
+open Lwt.Syntax
+
+type auth_mechanism = PLAIN  [@@deriving show { with_path = false }]
+
+type sasl_error =
+  | NotAuthorized
+  | MalformedRequest
+
+let read_sasl_error = function
+  | "not-authorized" -> NotAuthorized
+  | "malformed-request" -> MalformedRequest
+  | _ -> failwith "Unsupported SASL error returned by the server."
+
+type sasl_auth = (string option, sasl_error * (string * string) option) result
+
+let send_auth_stanza (stream, push) jid pass mechanism =
+  let gen_auth = function
+    | PLAIN -> Base64.encode_exn ("\x00" ^ jid ^ "\x00" ^ pass)
+  and parse_sasl_response stanza =
+    let open Markup in
+    let parse_additional_info = function
+      | `Text t :: _ -> Some (String.concat "" t)
+      | _ -> None
+    and parse_descriptive_text = function
+      | `Start_element ((_, "text"), [((_, "lang"), lang)]) :: `Text desc :: _ -> Some (lang, String.concat "" desc)
+      | `Start_element ((_, "text"), []) :: `Text desc :: _ -> Some ("en", String.concat "" desc)
+      | _ -> None
+    in
+    let parse_sasl_error = function
+      | `Start_element ((_, error), _) :: `End_element :: rest -> (read_sasl_error error, parse_descriptive_text rest)
+      | _ -> raise (Stream.InvalidStanza stanza)
+    in match (string stanza |> parse_xml |> signals |> to_list) with
+       | `Start_element ((_, "success"), _) :: rest -> Ok (parse_additional_info rest)
+       | `Start_element ((_, "failure"), _) :: rest -> Error (parse_sasl_error rest)
+       | _ -> raise (Stream.InvalidStanza stanza)
+  in let xmlns = "urn:ietf:params:xml:ns:xmpp-sasl" in
+     let stanza_list = [`Start_element
+                          ((xmlns, "auth"),
+                           [(("", "xmlns"), xmlns);
+                            (("", "mechanism"), show_auth_mechanism mechanism)]);
+                        `Text [gen_auth mechanism];
+                        `End_element]
+     in Markup.(stanza_list |> of_list |> write_xml |> to_string) |> Option.some |> push;
+        let* response = Lwt_stream.get stream
+        in try
+          match response with
+          | Some stanza -> parse_sasl_response stanza |> Lwt.return
+          | None -> Lwt.fail Stream.ClosedStream
+        with exn -> Lwt.fail exn
diff --git a/test/js/websockets_hello.ml b/test/js/websockets_hello.ml
index 292b365..6882c5b 100644
--- a/test/js/websockets_hello.ml
+++ b/test/js/websockets_hello.ml
@@ -18,9 +18,9 @@ let rec run t =
 
 let main (stream, push) jid password =
   let* _stream = Lwt_stream.get stream
-  in let+ _auth = Auth.send_auth_stanza (stream, push)
+  in let+ _auth = Sasl.send_auth_stanza (stream, push)
                     jid password
-                    Auth.PLAIN
+                    Sasl.PLAIN
      in push None;
         match _auth with
         | Error (NotAuthorized, Some (_, text)) -> print_endline ("Not authorized: " ^ text)
-- 
cgit v1.2.3