diff options
author | Ryan Kavanagh <rak@rak.ac> | 2020-06-02 12:09:42 -0400 |
---|---|---|
committer | Ryan Kavanagh <rak@rak.ac> | 2020-06-07 11:39:58 -0400 |
commit | 301c28f2157d5822b60499c93e7ee77a92b8cfe8 (patch) | |
tree | ddee1b64412b7c50cf52017ffab896a3f9f639bc /gemini/geminiTransaction.ml | |
parent | Mime type parsing (diff) |
Rename request to geminiTransaction
Diffstat (limited to 'gemini/geminiTransaction.ml')
-rw-r--r-- | gemini/geminiTransaction.ml | 123 |
1 files changed, 123 insertions, 0 deletions
diff --git a/gemini/geminiTransaction.ml b/gemini/geminiTransaction.ml new file mode 100644 index 0000000..282d6e7 --- /dev/null +++ b/gemini/geminiTransaction.ml @@ -0,0 +1,123 @@ +module type GEMINI_TRANSACTION = +sig + type request + + module M : MimeType.MIME_TYPE + + type status = + | INPUT + | SUCCESS + | SUCCESS_EOCSS + | REDIR_TEMP + | REDIR_PERM + | TEMP_FAIL + | SERVER_UNAVAILABLE + | CGI_ERROR + | PROXY_ERROR + | SLOW_DOWN + | PERM_FAIL + | NOT_FOUND + | GONE + | PROXY_REQ_REFUSED + | BAD_REQ + | CLIENT_CERT_REQUIRED + | TRANSIENT_CERT_REQUESTED + | AUTHORISED_CERT_REQUIRED + | CERT_NOT_ACCEPTED + | 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 transaction : request -> response option Lwt.t +end + +module GeminiTransaction (M : MimeType.MIME_TYPE) : GEMINI_TRANSACTION + with module M = M = +struct + exception InvalidRequest + + type request = { host : string; port : int; url : string; } + + module M = M + + type mime_type = M.t + + type status = + | INPUT + | SUCCESS + | SUCCESS_EOCSS + | REDIR_TEMP + | REDIR_PERM + | TEMP_FAIL + | SERVER_UNAVAILABLE + | CGI_ERROR + | PROXY_ERROR + | SLOW_DOWN + | PERM_FAIL + | NOT_FOUND + | GONE + | PROXY_REQ_REFUSED + | BAD_REQ + | CLIENT_CERT_REQUIRED + | TRANSIENT_CERT_REQUESTED + | AUTHORISED_CERT_REQUIRED + | CERT_NOT_ACCEPTED + | FUTURE_CERT_REJECTED + | EXPIRED_CERT_REJECTED + + 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 + | 21 -> Some SUCCESS_EOCSS + | 30 -> Some REDIR_TEMP + | 31 -> Some REDIR_PERM + | 40 -> Some TEMP_FAIL + | 41 -> Some SERVER_UNAVAILABLE + | 42 -> Some CGI_ERROR + | 43 -> Some PROXY_ERROR + | 44 -> Some SLOW_DOWN + | 50 -> Some PERM_FAIL + | 51 -> Some NOT_FOUND + | 52 -> Some GONE + | 53 -> Some PROXY_REQ_REFUSED + | 54 -> Some BAD_REQ + | 60 -> Some CLIENT_CERT_REQUIRED + | 61 -> Some TRANSIENT_CERT_REQUESTED + | 62 -> Some AUTHORISED_CERT_REQUIRED + | 63 -> Some CERT_NOT_ACCEPTED + | 64 -> Some FUTURE_CERT_REJECTED + | 65 -> Some EXPIRED_CERT_REJECTED + | _ -> None + + let transaction r = + let authenticator ~host:_ _ = Ok None in + let ()= ignore r in + let%lwt (ic, oc) = Tls_lwt.connect_ext + Tls.Config.(client ~authenticator ~ciphers:Ciphers.default ()) + (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 |