summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--bin/leda.ml10
-rw-r--r--gemini/geminiTransaction.ml90
-rw-r--r--gemini/geminiTransaction.mli16
3 files changed, 57 insertions, 59 deletions
diff --git a/bin/leda.ml b/bin/leda.ml
index 80c07af..a509c37 100644
--- a/bin/leda.ml
+++ b/bin/leda.ml
@@ -17,10 +17,12 @@ let () =
let w = Curses.initscr () in
let () = Curses.wclear w in
(match%lwt R.session request with
- | Ok (s, c) ->
- let _ = Curses.mvwaddstr w 0 0 ("STATUS: " ^ (R.name_of_status s)) in
- let _ = Curses.mvwaddstr w 1 0 ("STATUS LINE: " ^ (R.string_of_status s)) in
- let _ = Curses.mvwaddstr w 2 0 c in
+ | Ok r ->
+ let _ = Curses.mvwaddstr w 0 0 ("STATUS: " ^ (R.name_of_response r)) in
+ let _ = Curses.mvwaddstr w 1 0 ("STATUS LINE: " ^ (R.header_of_response r)) in
+ let _ = match r with
+ | SUCCESS (_, c) | SUCCESS_EOCSS (_, c) -> Curses.mvwaddstr w 2 0 c
+ | _ -> false in
let _ = Curses.refresh () in
let _ = Curses.getch () in
let _ = Curses.endwin () in
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 18:23:28 +0000