path: root/gemini/geminiTransaction.ml

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, string) result 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 status_parser : (status, string) result Angstrom.t =
    let open Angstrom in
    let status_of_string s =
      match int_of_string_opt s with
      | Some n -> (match int_to_status n with
          | Some s -> Ok s
          | None -> Error ("Invalid status: " ^ s))
      | None -> Error ("Invalid status: " ^ s) in
    lift status_of_string (take 2) <?> "status"

  let transaction r =
    let open Angstrom in
    let open ParseCommon.ParseCommon in
    let open Angstrom_lwt_unix in
    let authenticator ~host:_ _ = Ok None in
    let parser =
      lift3 (fun status_result -> fun m -> fun r ->
          Result.bind status_result (fun status -> Ok (status, M.from_string m, r)))
        status_parser
        (char ' ' *> take_till_cr)
        (take_while (fun _ -> true) <* end_of_input)
      <?> "transaction" 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 (_, parsed) = parse parser ic in
    Lwt.return (Result.join parsed)
end