summaryrefslogtreecommitdiff
path: root/gemini
diff options
context:
space:
mode:
Diffstat (limited to 'gemini')
-rw-r--r--gemini/dune3
-rw-r--r--gemini/request.ml55
-rw-r--r--gemini/request.mli6
3 files changed, 36 insertions, 28 deletions
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