From 98c8032f47316d5f6808cd9901c4d42600ed676f Mon Sep 17 00:00:00 2001
From: Ryan Kavanagh <rak@rak.ac>
Date: Mon, 1 Jun 2020 10:44:17 -0400
Subject: Revise with better understanding of lwt library

---
 bin/dune           |  3 ++-
 bin/leda.ml        | 12 ++++++++----
 gemini/dune        |  3 ++-
 gemini/request.ml  | 55 ++++++++++++++++++++++++++++--------------------------
 gemini/request.mli |  6 +++++-
 5 files changed, 46 insertions(+), 33 deletions(-)

diff --git a/bin/dune b/bin/dune
index e161175..c24d8bf 100644
--- a/bin/dune
+++ b/bin/dune
@@ -1,4 +1,5 @@
 (executable
  (public_name leda)
  (name leda)
- (libraries base gemini))
+ (libraries base gemini lwt lwt_ppx)
+ (preprocess (pps lwt_ppx)))
diff --git a/bin/leda.ml b/bin/leda.ml
index 40074ff..8b98762 100644
--- a/bin/leda.ml
+++ b/bin/leda.ml
@@ -5,7 +5,11 @@ let test_parse s = M.gemini_to_canon_str (M.str_to_gemini s)
 module T = Gemini.MimeType.MimeType
 module R = Gemini.Request.GeminiTransaction(T)
 
-let main =
-  match R.request "gemini://gemini.circumlunar.space/\r\n" with
-  | Some (_, _, s) -> print_endline s
-  | _ -> print_endline "oops"
+let () =
+  Lwt_main.run begin
+    let req = R.string_to_request "gemini://gemini.circumlunar.space/\r\n" in
+    let%lwt response = R.transaction req in
+    match response with
+    | Some (_, _, s) -> Lwt_io.printl s
+    | _ -> Lwt_io.printl "ooops"
+    end
diff --git a/gemini/dune b/gemini/dune
index 7b93751..133054e 100644
--- a/gemini/dune
+++ b/gemini/dune
@@ -1,3 +1,4 @@
 (library
  (name gemini)
- (libraries base angstrom lwt tls.lwt uri))
+ (libraries base angstrom lwt lwt_ppx tls.lwt uri)
+ (preprocess (pps lwt_ppx)))
diff --git a/gemini/request.ml b/gemini/request.ml
index f67f6f2..282d6e7 100644
--- a/gemini/request.ml
+++ b/gemini/request.ml
@@ -1,10 +1,8 @@
-open Lwt.Infix
-
 module type GEMINI_TRANSACTION =
 sig
-  module M : MimeType.MIME_TYPE
+  type request
 
-  type mime_type = M.t
+  module M : MimeType.MIME_TYPE
 
   type status =
     | INPUT
@@ -29,11 +27,15 @@ sig
     | FUTURE_CERT_REJECTED
     | EXPIRED_CERT_REJECTED
 
+  type mime_type = M.t
+
   type response = status * mime_type * string
 
+  val string_to_request : string -> request
+
   val int_to_status : int -> status option
 
-  val request : string -> response option
+  val transaction : request -> response option Lwt.t
 end
 
 module GeminiTransaction (M : MimeType.MIME_TYPE) : GEMINI_TRANSACTION
@@ -41,6 +43,8 @@ module GeminiTransaction (M : MimeType.MIME_TYPE) : GEMINI_TRANSACTION
 struct
   exception InvalidRequest
 
+  type request = { host : string; port : int; url : string; }
+
   module M = M
 
   type mime_type = M.t
@@ -70,6 +74,19 @@ struct
 
   type response = status * mime_type * string
 
+  let string_to_request r =
+    let url = Uri.of_string r in
+    let () = match Uri.scheme url with
+      | Some "gemini" -> ()
+      | _ -> raise InvalidRequest in
+    let host = match Uri.host url with
+      | Some h -> h
+      | _ -> raise InvalidRequest in
+    let port = match Uri.port url with
+      | Some p -> p
+      | _ -> 1965 in
+    { host = host; port = port; url = r; }
+
   let int_to_status = function
     | 10 -> Some INPUT
     | 20 -> Some SUCCESS
@@ -94,27 +111,13 @@ struct
     | 65 -> Some EXPIRED_CERT_REJECTED
     | _ -> None
 
-  let do_request host port request =
+  let transaction r =
     let authenticator ~host:_ _ = Ok None in
-    Lwt_main.run (
-      Tls_lwt.connect_ext
+    let ()= ignore r in
+    let%lwt (ic, oc) = Tls_lwt.connect_ext
         Tls.Config.(client ~authenticator ~ciphers:Ciphers.default ())
-        (host, port) >>= fun (ic, oc) ->
-      Lwt_io.(write oc request >>= fun () ->
-              read ic >>= Lwt.return))
-
-  let request r =
-    let url = Uri.of_string r in
-    let () = match Uri.scheme url with
-      | Some "gemini" -> ()
-      | _ -> raise InvalidRequest in
-    let host = match Uri.host url with
-      | Some s -> s
-      | _ -> raise InvalidRequest in
-    let port = match Uri.port url with
-      | Some p -> p
-      | _ -> 1965 in
-    let response = do_request host port r in
-    Some (PERM_FAIL, M.from_string "text/plain", response)
-
+        (r.host, r.port) in
+    let%lwt () = Lwt_io.write oc r.url in
+    let%lwt response = Lwt_io.read ic in
+    Lwt.return (Some (PERM_FAIL, M.from_string "text/plain", response))
 end
diff --git a/gemini/request.mli b/gemini/request.mli
index b96a5ae..45049f1 100644
--- a/gemini/request.mli
+++ b/gemini/request.mli
@@ -1,5 +1,7 @@
 module type GEMINI_TRANSACTION =
 sig
+  type request
+
   module M : MimeType.MIME_TYPE
 
   type status =
@@ -29,9 +31,11 @@ sig
 
   type response = status * mime_type * string
 
+  val string_to_request : string -> request
+
   val int_to_status : int -> status option
 
-  val request : string -> response option
+  val transaction : request -> response option Lwt.t
 end
 
 module GeminiTransaction (M : MimeType.MIME_TYPE) : GEMINI_TRANSACTION with module M = M
-- 
cgit v1.2.3