From 4541e48f22aac7d3073d14bedc9aad69a092a375 Mon Sep 17 00:00:00 2001
From: Ryan Kavanagh <rak@rak.ac>
Date: Fri, 12 Jun 2020 22:36:10 -0400
Subject: Better error handling

---
 bin/leda.ml                  | 18 ++++++++++++++----
 gemini/geminiTransaction.ml  | 23 +++++++++++++++++------
 gemini/geminiTransaction.mli |  8 +++++++-
 3 files changed, 38 insertions(+), 11 deletions(-)

diff --git a/bin/leda.ml b/bin/leda.ml
index 98e6244..c32f3a5 100644
--- a/bin/leda.ml
+++ b/bin/leda.ml
@@ -16,7 +16,7 @@ module R = Gemini.GeminiTransaction.GeminiTransaction(T)(Gemini.TlsUtils.TlsUtil
 let () =
   Lwt_main.run begin
     let%lwt () = Mirage_crypto_rng_lwt.initialize () in
-    let request : (R.request, string) Base.Result.t = R.make_request (Sys.get_argv()).(1) in
+    let request = R.make_request (Sys.get_argv()).(1) in
     let rec loop t =
       match%lwt Lwt_stream.next (Term.events t) with
       | `Key _ -> Lwt.return ()
@@ -44,8 +44,18 @@ let () =
          let%lwt () = Term.image t (h <-> c) in
          let%lwt () = Term.refresh t in
          loop t
-       | Error m ->
+       | Error R.TOO_MANY_REDIRECTS ->
          let%lwt () = Term.release t in
-         Lwt_io.printl m)
-    | Error m -> Lwt_io.printl m
+         Lwt_io.printl "Too many redirects"
+       | Error (R.X_DOMAIN_REDIR _) ->
+         let%lwt () = Term.release t in
+         Lwt_io.printl ("Attempted to redirect across domains")
+       | Error (UNKNOWN_RESPONSE s) ->
+         let%lwt () = Term.release t in
+         Lwt_io.printl ("Unknown response: " ^ s)
+       | Error (MISC s) ->
+         let%lwt () = Term.release t in
+         Lwt_io.printl ("Error: " ^ s))
+    | Error m ->
+      Lwt_io.printl m
   end
diff --git a/gemini/geminiTransaction.ml b/gemini/geminiTransaction.ml
index 9f079af..1221177 100644
--- a/gemini/geminiTransaction.ml
+++ b/gemini/geminiTransaction.ml
@@ -32,6 +32,12 @@ sig
     | FUTURE_CERT_REJECTED
     | EXPIRED_CERT_REJECTED
 
+  type session_error =
+    | TOO_MANY_REDIRECTS
+    | X_DOMAIN_REDIR of Uri.t * Uri.t
+    | UNKNOWN_RESPONSE of string
+    | MISC of string
+
   val make_request : ?authenticator:T.authenticator
     -> ?max_redirects:int -> string -> (request, string) Base.Result.t
 
@@ -49,7 +55,7 @@ sig
 
   val transaction : request -> (response, string) Base.Result.t Lwt.t
 
-  val session : request -> (response, string) Base.Result.t Lwt.t
+  val session : request -> (response, session_error) Base.Result.t Lwt.t
 end
 
 module GeminiTransaction (M : MimeType.MIME_TYPE) (T : TlsUtils.TLS_UTILS)
@@ -89,6 +95,12 @@ struct
     | FUTURE_CERT_REJECTED
     | EXPIRED_CERT_REJECTED
 
+  type session_error =
+    | TOO_MANY_REDIRECTS
+    | X_DOMAIN_REDIR of Uri.t * Uri.t
+    | UNKNOWN_RESPONSE of string
+    | MISC of string
+
   let url_of_string r =
     let url = Uri.of_string r in
     let open Base.Result.Monad_infix in
@@ -255,10 +267,9 @@ struct
         match update_request ~url
                 ~max_redirects:(req.max_redirects - 1) req with
         | Ok req -> session req
-        | Error m -> Lwt.return (Error m)
+        | Error m -> Lwt.return (Error (MISC m))
       else
-        Lwt.return (Error "Too many redirects")
-    | Ok r -> Lwt.return (Error ("Unhandled response "
-                                 ^ (header_of_response r)))
-    | Error m -> Lwt.return (Error m)
+        Lwt.return (Error TOO_MANY_REDIRECTS)
+    | Ok r -> Lwt.return (Error (UNKNOWN_RESPONSE (header_of_response r)))
+    | Error m -> Lwt.return (Error (MISC m))
 end
diff --git a/gemini/geminiTransaction.mli b/gemini/geminiTransaction.mli
index 4a89ab1..d103afe 100644
--- a/gemini/geminiTransaction.mli
+++ b/gemini/geminiTransaction.mli
@@ -32,6 +32,12 @@ sig
     | FUTURE_CERT_REJECTED
     | EXPIRED_CERT_REJECTED
 
+  type session_error =
+    | TOO_MANY_REDIRECTS
+    | X_DOMAIN_REDIR of Uri.t * Uri.t
+    | UNKNOWN_RESPONSE of string
+    | MISC of string
+
   val make_request : ?authenticator:T.authenticator
     -> ?max_redirects:int -> string -> (request, string) Base.Result.t
 
@@ -49,7 +55,7 @@ sig
 
   val transaction : request -> (response, string) Base.Result.t Lwt.t
 
-  val session : request -> (response, string) Base.Result.t Lwt.t
+  val session : request -> (response, session_error) Base.Result.t Lwt.t
 end
 
 module GeminiTransaction (M : MimeType.MIME_TYPE) (T : TlsUtils.TLS_UTILS)
-- 
cgit v1.2.3