blob: e79e40d423ff0bd15254afd3d145d020dc6a6553 (
plain) (
tree)
|
|
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 make_request : url: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 make_request ~url: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
|