diff options
Diffstat (limited to 'gemini')
| -rw-r--r-- | gemini/dune | 3 | ||||
| -rw-r--r-- | gemini/request.ml | 55 | ||||
| -rw-r--r-- | gemini/request.mli | 6 |
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 |