path: root/gemini/request.ml

open Lwt.Infix

module type GEMINI_TRANSACTION =
sig
  module M : MimeType.MIME_TYPE

  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

  val int_to_status : int -> status option

  val request : string -> response option
end

module GeminiTransaction (M : MimeType.MIME_TYPE) : GEMINI_TRANSACTION
  with module M = M =
struct
  exception InvalidRequest

  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 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 do_request host port request =
    let authenticator ~host:_ _ = Ok None in
    Lwt_main.run (
      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)

end