diff options
Diffstat (limited to 'gemini')
-rw-r--r-- | gemini/geminiTransaction.ml | 90 | ||||
-rw-r--r-- | gemini/geminiTransaction.mli | 16 |
2 files changed, 51 insertions, 55 deletions
diff --git a/gemini/geminiTransaction.ml b/gemini/geminiTransaction.ml index 3cd9bde..1a73a93 100644 --- a/gemini/geminiTransaction.ml +++ b/gemini/geminiTransaction.ml @@ -8,10 +8,10 @@ sig type mime_type = M.t - type status = + type response = | INPUT - | SUCCESS of mime_type - | SUCCESS_EOCSS + | SUCCESS of mime_type * string + | SUCCESS_EOCSS of mime_type * string | REDIR_TEMP of string | REDIR_PERM of string | TEMP_FAIL @@ -31,8 +31,6 @@ sig | FUTURE_CERT_REJECTED | EXPIRED_CERT_REJECTED - type response = status * string - val make_request : ?authenticator:T.authenticator -> ?max_redirects:int -> string -> (request, string) Base.Result.t @@ -40,13 +38,13 @@ sig -> ?max_redirects:int -> ?url:string -> request -> (request, string) Base.Result.t - val status_of_string : string -> (status, string) Base.Result.t + val response_of_string : string -> (response, string) Base.Result.t - val int_of_status : status -> int + val int_of_response : response -> int - val name_of_status : status -> string + val name_of_response : response -> string - val string_of_status : status -> string + val header_of_response : response -> string val transaction : request -> (response, string) Base.Result.t Lwt.t @@ -66,10 +64,10 @@ struct type mime_type = M.t - type status = + type response = | INPUT - | SUCCESS of mime_type - | SUCCESS_EOCSS + | SUCCESS of mime_type * string + | SUCCESS_EOCSS of mime_type * string | REDIR_TEMP of string | REDIR_PERM of string | TEMP_FAIL @@ -89,8 +87,6 @@ struct | FUTURE_CERT_REJECTED | EXPIRED_CERT_REJECTED - type response = status * string - let url_of_string r = let url = Uri.of_string r in let open Base.Result.Monad_infix in @@ -116,14 +112,16 @@ struct | 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; }) + Ok { + authenticator = Option.value authenticator ~default:req.authenticator; + max_redirects = Option.value max_redirects ~default:req.max_redirects; + url; + }) - let int_of_status = function + let int_of_response = function | INPUT -> 10 | SUCCESS _ -> 20 - | SUCCESS_EOCSS -> 21 + | SUCCESS_EOCSS _ -> 21 | REDIR_TEMP _ -> 30 | REDIR_PERM _ -> 31 | TEMP_FAIL -> 40 @@ -143,10 +141,10 @@ struct | FUTURE_CERT_REJECTED -> 64 | EXPIRED_CERT_REJECTED -> 65 - let name_of_status = function + let name_of_response = function | INPUT -> "10 INPUT" | SUCCESS _ -> "20 SUCCESS" - | SUCCESS_EOCSS -> "21 SUCCESS - END OF CLIENT CERTIFICATE SESSION" + | SUCCESS_EOCSS _ -> "21 SUCCESS - END OF CLIENT CERTIFICATE SESSION" | REDIR_TEMP _ -> "30 REDIRECT - TEMPORARY" | REDIR_PERM _ -> "31 REDIRECT - PERMANENT" | TEMP_FAIL -> "40 TEMPORARY FAILURE" @@ -166,10 +164,10 @@ struct | FUTURE_CERT_REJECTED -> "64 FUTURE CERTIFICATE REJECTED" | EXPIRED_CERT_REJECTED -> "65 EXPIRED CERTIFICATE REJECTED" - let string_of_status = function + let header_of_response = function | INPUT -> "10 " - | SUCCESS m -> "20 " ^ (M.to_canonical m) - | SUCCESS_EOCSS -> "21 " + | 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 " @@ -189,19 +187,24 @@ struct | FUTURE_CERT_REJECTED -> "64 " | EXPIRED_CERT_REJECTED -> "65 " - let status_parser : status Angstrom.t = + let response_parser : response Angstrom.t = let open Angstrom in 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) + <|> 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) + <|> 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) @@ -213,20 +216,13 @@ struct <|> (string "63 " *> return CERT_NOT_ACCEPTED) <|> (string "64 " *> return FUTURE_CERT_REJECTED) <|> (string "65 " *> return EXPIRED_CERT_REJECTED) - <|> fail "Invalid status" - <?> "status" + <|> fail "Invalid response" + <?> "response" - let status_of_string = Angstrom.parse_string ~consume:All status_parser + let response_of_string = Angstrom.parse_string ~consume:All response_parser let transaction r = - let open Angstrom in let open Angstrom_lwt_unix in - let parser = - lift2 (fun status -> fun r -> - Ok (status, r)) - status_parser - (take_while (fun _ -> true) <* end_of_input) - <?> "transaction" 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) @@ -237,15 +233,16 @@ struct 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%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)) 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, _) -> + | 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 @@ -253,6 +250,7 @@ struct | 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) + | Ok r -> Lwt.return (Error ("Unhandled response " + ^ (header_of_response r))) + | Error m -> Lwt.return (Error m) end diff --git a/gemini/geminiTransaction.mli b/gemini/geminiTransaction.mli index ecd7349..cc209d0 100644 --- a/gemini/geminiTransaction.mli +++ b/gemini/geminiTransaction.mli @@ -8,10 +8,10 @@ sig type mime_type = M.t - type status = + type response = | INPUT - | SUCCESS of mime_type - | SUCCESS_EOCSS + | SUCCESS of mime_type * string + | SUCCESS_EOCSS of mime_type * string | REDIR_TEMP of string | REDIR_PERM of string | TEMP_FAIL @@ -31,8 +31,6 @@ sig | FUTURE_CERT_REJECTED | EXPIRED_CERT_REJECTED - type response = status * string - val make_request : ?authenticator:T.authenticator -> ?max_redirects:int -> string -> (request, string) Base.Result.t @@ -40,13 +38,13 @@ sig -> ?max_redirects:int -> ?url:string -> request -> (request, string) Base.Result.t - val status_of_string : string -> (status, string) Base.Result.t + val response_of_string : string -> (response, string) Base.Result.t - val int_of_status : status -> int + val int_of_response : response -> int - val name_of_status : status -> string + val name_of_response : response -> string - val string_of_status : status -> string + val header_of_response : response -> string val transaction : request -> (response, string) Base.Result.t Lwt.t |