From e4d7122dc3fe215fc73a6901be9b18d277387b3c Mon Sep 17 00:00:00 2001 From: Ryan Kavanagh Date: Sat, 6 Jun 2020 10:38:37 -0400 Subject: Clarify statuses and add preliminary transaction support --- gemini/geminiTransaction.ml | 262 ++++++++++++++++++++++++++++++++------------ 1 file changed, 189 insertions(+), 73 deletions(-) (limited to 'gemini/geminiTransaction.ml') diff --git a/gemini/geminiTransaction.ml b/gemini/geminiTransaction.ml index 65b80ea..3cd9bde 100644 --- a/gemini/geminiTransaction.ml +++ b/gemini/geminiTransaction.ml @@ -2,19 +2,23 @@ module type GEMINI_TRANSACTION = sig type request + module T : TlsUtils.TLS_UTILS + module M : MimeType.MIME_TYPE + type mime_type = M.t + type status = | INPUT - | SUCCESS + | SUCCESS of mime_type | SUCCESS_EOCSS - | REDIR_TEMP - | REDIR_PERM + | REDIR_TEMP of string + | REDIR_PERM of string | TEMP_FAIL | SERVER_UNAVAILABLE | CGI_ERROR | PROXY_ERROR - | SLOW_DOWN + | SLOW_DOWN of int | PERM_FAIL | NOT_FOUND | GONE @@ -26,25 +30,37 @@ sig | CERT_NOT_ACCEPTED | FUTURE_CERT_REJECTED | EXPIRED_CERT_REJECTED - | UNDEFINED of int - type mime_type = M.t + type response = status * string + + val make_request : ?authenticator:T.authenticator + -> ?max_redirects:int -> string -> (request, string) Base.Result.t - type response = status * mime_type * string + val update_request : ?authenticator:T.authenticator + -> ?max_redirects:int -> ?url:string + -> request -> (request, string) Base.Result.t - val make_request : url:string -> request + val status_of_string : string -> (status, string) Base.Result.t - val int_to_status : int -> status + val int_of_status : status -> int - val transaction : request -> (response, string) result Lwt.t + val name_of_status : status -> string + + val string_of_status : status -> 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) : GEMINI_TRANSACTION - with module M = M = +module GeminiTransaction (M : MimeType.MIME_TYPE) (T : TlsUtils.TLS_UTILS) + : GEMINI_TRANSACTION with module M = M and module T = T = struct - exception InvalidRequest + module T = T - type request = { host : string; port : int; url : string; } + type request = { url : Uri.t; + authenticator : T.authenticator; + max_redirects : int; } module M = M @@ -52,15 +68,15 @@ struct type status = | INPUT - | SUCCESS + | SUCCESS of mime_type | SUCCESS_EOCSS - | REDIR_TEMP - | REDIR_PERM + | REDIR_TEMP of string + | REDIR_PERM of string | TEMP_FAIL | SERVER_UNAVAILABLE | CGI_ERROR | PROXY_ERROR - | SLOW_DOWN + | SLOW_DOWN of int | PERM_FAIL | NOT_FOUND | GONE @@ -72,71 +88,171 @@ struct | CERT_NOT_ACCEPTED | FUTURE_CERT_REJECTED | EXPIRED_CERT_REJECTED - | UNDEFINED of int - type response = status * mime_type * string + type response = status * string - let make_request ~url:r = + let url_of_string 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 -> INPUT - | 20 -> SUCCESS - | 21 -> SUCCESS_EOCSS - | 30 -> REDIR_TEMP - | 31 -> REDIR_PERM - | 40 -> TEMP_FAIL - | 41 -> SERVER_UNAVAILABLE - | 42 -> CGI_ERROR - | 43 -> PROXY_ERROR - | 44 -> SLOW_DOWN - | 50 -> PERM_FAIL - | 51 -> NOT_FOUND - | 52 -> GONE - | 53 -> PROXY_REQ_REFUSED - | 54 -> BAD_REQ - | 60 -> CLIENT_CERT_REQUIRED - | 61 -> TRANSIENT_CERT_REQUESTED - | 62 -> AUTHORISED_CERT_REQUIRED - | 63 -> CERT_NOT_ACCEPTED - | 64 -> FUTURE_CERT_REJECTED - | 65 -> EXPIRED_CERT_REJECTED - | n -> UNDEFINED n - - let status_parser : (status, string) result Angstrom.t = + 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_status = function + | INPUT -> 10 + | 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_status = function + | INPUT -> "10 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 string_of_status = function + | INPUT -> "10 " + | SUCCESS m -> "20 " ^ (M.to_canonical m) + | SUCCESS_EOCSS -> "21 " + | 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 status_parser : status Angstrom.t = let open Angstrom in - let status_of_string s = - match int_of_string_opt s with - | Some n -> Ok (int_to_status n) - | None -> Error ("Invalid status: " ^ s) in - lift status_of_string (take 2) "status" + let open ParseCommon.ParseCommon in + (string "10 " *> return INPUT) + <|> lift (fun m -> SUCCESS (M.from_string m)) (string "20 " *> take_till_cr) + <|> (string "21 " *> return SUCCESS_EOCSS) + <|> 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 status" + "status" + + let status_of_string = Angstrom.parse_string ~consume:All status_parser 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))) + lift2 (fun status -> fun r -> + Ok (status, 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) + 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 parser ic in + Lwt.return (Result.join parsed) + with | Tls_lwt.Tls_alert alert -> Lwt.return (Error (Tls.Packet.alert_type_to_string alert)) + + 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 x -> Lwt.return (Ok x) + | Base.Error m -> Lwt.return (Error m) end -- cgit v1.2.3