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_crlf) (take_while (fun _ -> true) <* end_of_input) <|> lift2 (fun m -> fun b -> SUCCESS_EOCSS (M.from_string m, b)) (string "21 " *> take_till_crlf) (take_while (fun _ -> true) <* end_of_input) <|> lift (fun u -> REDIR_TEMP u) (string "30 " *> take_till_crlf) <|> lift (fun u -> REDIR_PERM u) (string "31 " *> take_till_crlf) <|> (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_crlf) <|> (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.default ()) (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