Clarify statuses and add preliminary transaction support

2 files changed, 215 insertions, 84 deletions

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
diff --git a/gemini/geminiTransaction.mli b/gemini/geminiTransaction.mli
index b31d9e0..ecd7349 100644
--- a/gemini/geminiTransaction.mli
+++ b/gemini/geminiTransaction.mli
@@ -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,17 +30,28 @@ 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
+
+  val update_request : ?authenticator:T.authenticator
+    -> ?max_redirects:int -> ?url:string
+    -> request -> (request, string) Base.Result.t
+
+  val status_of_string : string -> (status, string) Base.Result.t
+
+  val int_of_status : status -> int
 
-  type response = status * mime_type * string
+  val name_of_status : status -> string
 
-  val make_request : url:string -> request
+  val string_of_status : status -> string
 
-  val int_to_status : int -> status
+  val transaction : request -> (response, string) Base.Result.t Lwt.t
 
-  val transaction : request -> (response, string) result 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