status -> response

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