path: root/gemini/geminiTransaction.ml

module type GEMINI_TRANSACTION =
sig
  type request

  module T : TlsUtils.TLS_UTILS

  module M : MimeType.MIME_TYPE

  type mime_type = M.t

  type response =
    | INPUT
    | SENSITIVE_INPUT
    | SUCCESS of mime_type * string
    | SUCCESS_EOCSS of mime_type * string
    | REDIR_TEMP of string
    | REDIR_PERM of string
    | TEMP_FAIL
    | SERVER_UNAVAILABLE
    | CGI_ERROR
    | PROXY_ERROR
    | SLOW_DOWN of int
    | 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

  val make_request : ?authenticator:T.authenticator
    -> ?max_redirects:int -> string -> (request, string) Base.Result.t

  val update_request : ?authenticator:T.authenticator
    -> ?max_redirects:int -> ?url:string
    -> request -> (request, string) Base.Result.t

  val response_of_string : string -> (response, string) Base.Result.t

  val int_of_response : response -> int

  val name_of_response : response -> string

  val header_of_response : response -> string

  val transaction : request -> (response, string) Base.Result.t Lwt.t

  val session : request -> (response, string) Base.Result.t Lwt.t
end

module GeminiTransaction (M : MimeType.MIME_TYPE) (T : TlsUtils.TLS_UTILS)
  : GEMINI_TRANSACTION with module M = M and module T = T =
struct
  module T = T

  type request = { url : Uri.t;
                   authenticator : T.authenticator;
                   max_redirects : int; }

  module M = M

  type mime_type = M.t

  type response =
    | INPUT
    | SENSITIVE_INPUT
    | SUCCESS of mime_type * string
    | SUCCESS_EOCSS of mime_type * string
    | REDIR_TEMP of string
    | REDIR_PERM of string
    | TEMP_FAIL
    | SERVER_UNAVAILABLE
    | CGI_ERROR
    | PROXY_ERROR
    | SLOW_DOWN of int
    | 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

  let url_of_string r =
    let url = Uri.of_string r in
    let open Base.Result.Monad_infix in
    (match Uri.scheme url with
     | Some "gemini" -> Ok ()
     | _ -> Error "We only support gemini") >>= (fun () ->
        match Uri.host url with
        | Some _ -> Ok ()
        | _ -> Error "No host in url?") >>= (fun () ->
        match Uri.port url with
        | Some _ -> Ok url
        | None -> Ok (Uri.with_port url (Some 1965)))

  let make_request ?(authenticator=T.null_auth)
      ?(max_redirects=5) url =
    let open Base.Result.Monad_infix in
    url_of_string url >>= (fun url ->
        Ok { url; authenticator; max_redirects; })

  let update_request ?authenticator ?max_redirects ?url req =
    let open Base in
    let url_result = match url with
    | Some url -> url_of_string url
    | None -> Ok req.url in
    Result.bind url_result ~f:(fun url ->
        Ok {
          authenticator = Option.value authenticator ~default:req.authenticator;
          max_redirects = Option.value max_redirects ~default:req.max_redirects;
          url;
        })

  let int_of_response = function
    | INPUT -> 10
    | SENSITIVE_INPUT -> 11
    | SUCCESS _ -> 20
    | SUCCESS_EOCSS _ -> 21
    | REDIR_TEMP _ -> 30
    | REDIR_PERM _ -> 31
    | TEMP_FAIL -> 40
    | SERVER_UNAVAILABLE -> 41
    | CGI_ERROR -> 42
    | PROXY_ERROR -> 43
    | SLOW_DOWN _ -> 44
    | PERM_FAIL -> 50
    | NOT_FOUND -> 51
    | GONE -> 52
    | PROXY_REQ_REFUSED -> 53
    | BAD_REQ -> 54
    | CLIENT_CERT_REQUIRED -> 60
    | TRANSIENT_CERT_REQUESTED -> 61
    | AUTHORISED_CERT_REQUIRED -> 62
    | CERT_NOT_ACCEPTED -> 63
    | FUTURE_CERT_REJECTED -> 64
    | EXPIRED_CERT_REJECTED -> 65

  let name_of_response = function
    | INPUT -> "10 INPUT"
    | SENSITIVE_INPUT -> "11 SENSITIVE INPUT"
    | SUCCESS _ -> "20 SUCCESS"
    | SUCCESS_EOCSS _ -> "21 SUCCESS - END OF CLIENT CERTIFICATE SESSION"
    | REDIR_TEMP _ -> "30 REDIRECT - TEMPORARY"
    | REDIR_PERM _ -> "31 REDIRECT - PERMANENT"
    | TEMP_FAIL -> "40 TEMPORARY FAILURE"
    | SERVER_UNAVAILABLE -> "41 SERVER UNAVAILABLE"
    | CGI_ERROR -> "42 CGI ERROR"
    | PROXY_ERROR -> "43 PROXY ERROR"
    | SLOW_DOWN _ -> "44 SLOW DOWN"
    | PERM_FAIL -> "50 PERMANENT FAILURE"
    | NOT_FOUND -> "51 NOT FOUND"
    | GONE -> "52 GONE"
    | PROXY_REQ_REFUSED -> "53 PROXY REQUEST REFUSED"
    | BAD_REQ -> "59 BAD REQUEST"
    | CLIENT_CERT_REQUIRED -> "60 CLIENT CERTIFICATE REQUIRED"
    | TRANSIENT_CERT_REQUESTED -> "61 TRANSIENT CERTIFICATE REQUESTED"
    | AUTHORISED_CERT_REQUIRED -> "62 AUTHORISED CERTIFICATE REQUIRED"
    | CERT_NOT_ACCEPTED -> "63 CERTIFICATE NOT ACCEPTED"
    | FUTURE_CERT_REJECTED -> "64 FUTURE CERTIFICATE REJECTED"
    | EXPIRED_CERT_REJECTED -> "65 EXPIRED CERTIFICATE REJECTED"

  let header_of_response = function
    | INPUT -> "10 "
    | SENSITIVE_INPUT -> "11 "
    | SUCCESS (m, _) -> "20 " ^ (M.to_canonical m)
    | SUCCESS_EOCSS (m, _) -> "21 " ^ (M.to_canonical m)
    | REDIR_TEMP u -> "30 " ^ u
    | REDIR_PERM u -> "31 " ^ u
    | TEMP_FAIL -> "40 "
    | SERVER_UNAVAILABLE -> "41 "
    | CGI_ERROR -> "42 "
    | PROXY_ERROR -> "43 "
    | SLOW_DOWN n -> "44 " ^ (string_of_int n)
    | PERM_FAIL -> "50 "
    | NOT_FOUND -> "51 "
    | GONE -> "52 "
    | PROXY_REQ_REFUSED -> "53 "
    | BAD_REQ -> "59 "
    | CLIENT_CERT_REQUIRED -> "60 "
    | TRANSIENT_CERT_REQUESTED -> "61 "
    | AUTHORISED_CERT_REQUIRED -> "62 "
    | CERT_NOT_ACCEPTED -> "63 "
    | FUTURE_CERT_REJECTED -> "64 "
    | EXPIRED_CERT_REJECTED -> "65 "

  let response_parser : response Angstrom.t =
    let open Angstrom in
    let open ParseCommon.ParseCommon in
    (string "10 " *> return INPUT)
    <|> (string "11 " *> return SENSITIVE_INPUT)
    <|> lift2 (fun m -> fun b -> SUCCESS (M.from_string m, b))
      (string "20 " *> take_till_cr)
      (take_while (fun _ -> true) <* end_of_input)
    <|> lift2 (fun m -> fun b -> SUCCESS_EOCSS (M.from_string m, b))
      (string "21 " *> take_till_cr)
      (take_while (fun _ -> true) <* end_of_input)
    <|> lift (fun u -> REDIR_TEMP u) (string "30 " *> take_till_cr)
    <|> lift (fun u -> REDIR_PERM u) (string "31 " *> take_till_cr)
    <|> (string "40 " *> return TEMP_FAIL)
    <|> (string "41 " *> return SERVER_UNAVAILABLE)
    <|> (string "42 " *> return CGI_ERROR)
    <|> (string "43 " *> return PROXY_ERROR)
    <|> lift (fun n -> SLOW_DOWN (int_of_string n))
      (string "44 " *> take_till_cr)
    <|> (string "50 " *> return PERM_FAIL)
    <|> (string "51 " *> return NOT_FOUND)
    <|> (string "52 " *> return GONE)
    <|> (string "53 " *> return PROXY_REQ_REFUSED)
    <|> (string "59 " *> return BAD_REQ)
    <|> (string "60 " *> return CLIENT_CERT_REQUIRED)
    <|> (string "61 " *> return TRANSIENT_CERT_REQUESTED)
    <|> (string "62 " *> return AUTHORISED_CERT_REQUIRED)
    <|> (string "63 " *> return CERT_NOT_ACCEPTED)
    <|> (string "64 " *> return FUTURE_CERT_REJECTED)
    <|> (string "65 " *> return EXPIRED_CERT_REJECTED)
    <|> fail "Invalid response"
    <?> "response"

  let response_of_string = Angstrom.parse_string ~consume:All response_parser

  let transaction r =
    let open Angstrom_lwt_unix in
    let host = Base.Option.value_exn (Uri.host r.url)
        ~message:"URL with no host?" in
    let port = Base.Option.value_exn (Uri.port r.url)
        ~message:"URL with no port?" in
    let%lwt authenticator = r.authenticator in
    try%lwt
      let%lwt (ic, oc) = Tls_lwt.connect_ext
          Tls.Config.(client ~peer_name:host ~authenticator
                        ~ciphers:Ciphers.supported ()) (host, port) in
      let%lwt () = Lwt_io.write oc (Uri.to_string r.url ^ "\r\n") in
      let%lwt (_, parsed) = parse response_parser ic in
      Lwt.return parsed
    with
    | Tls_lwt.Tls_alert alert ->
      Lwt.return (Error (Tls.Packet.alert_type_to_string alert))
    | Tls_lwt.Tls_failure failure ->
      Lwt.return (Error (Tls.Engine.string_of_failure failure))

  let rec session req =
    match%lwt transaction req with
    | Ok (SUCCESS (m, r)) -> Lwt.return (Ok (SUCCESS (m, r)))
    | Ok (REDIR_TEMP url)
    | Ok (REDIR_PERM url) ->
      if req.max_redirects > 1 then
        match update_request ~url
                ~max_redirects:(req.max_redirects - 1) req with
        | Ok req -> session req
        | Error m -> Lwt.return (Error m)
      else
        Lwt.return (Error "Too many redirects")
    | Ok r -> Lwt.return (Error ("Unhandled response "
                                 ^ (header_of_response r)))
    | Error m -> Lwt.return (Error m)
end