From 04292d18c8ddd394acd683662caa9f848eced9d3 Mon Sep 17 00:00:00 2001
From: Daniel Schadt <kingdread@gmx.de>
Date: Wed, 30 Jun 2021 13:57:34 +0200
Subject: Give a reply to the server if a route fails

Otherwise, the server will never get a reply and instead we'll just
silently let the client timeout :-(

This change introduces the function "uncatch", which makes an error the
inner Cana computation explicit by returning the Either directly.

With the way this is written currently, we could probably get away with
using "catch" as well, along the lines of

  r geminiRequest `catch` (const $ writeResponse context ...)
---
 src/Cana.hs       | 12 ++++++++++--
 src/Cana/Monad.hs |  8 ++++++++
 2 files changed, 18 insertions(+), 2 deletions(-)

diff --git a/src/Cana.hs b/src/Cana.hs
index 5822ccb..5d80057 100644
--- a/src/Cana.hs
+++ b/src/Cana.hs
@@ -149,8 +149,16 @@ canaClient socket = do
   route <- findRoute geminiRequest
   case route of
     Just r  -> do
-      response <- r geminiRequest
-      writeResponse context response
+      response <- uncatch $ r geminiRequest
+      case response of
+        Left l -> do
+          writeResponse context $ GeminiResponse
+            { responseStatus = codeTemporaryFailure
+            , responseMeta   = "Internal server error"
+            , responseData   = ""
+            }
+          throw l
+        Right r -> writeResponse context r
     Nothing -> do
       writeResponse context $ GeminiResponse
         { responseStatus = codeNotFound
diff --git a/src/Cana/Monad.hs b/src/Cana/Monad.hs
index e63e89a..969c9cf 100644
--- a/src/Cana/Monad.hs
+++ b/src/Cana/Monad.hs
@@ -36,6 +36,14 @@ except = Cana . lift . Control.Monad.Trans.Except.except
 throw :: String -> Cana a
 throw = Cana . lift . Control.Monad.Trans.Except.throwE
 
+-- | Run a computation with an installed error handler.
+catch :: Cana a -> (String -> Cana a) -> Cana a
+catch (Cana f) h = Cana $ liftCatch catchE f (\e -> let (Cana inner) = h e in inner)
+
+-- | Retrieve the inner error value, if one exists.
+uncatch :: Cana a -> Cana (Either String a)
+uncatch f = catch (Right <$> f) (return . Left)
+
 -- | Log some information.
 logInfo :: MonadIO m => String -> m ()
 logInfo text = liftIO $ putStrLn ("[ INFO] " ++ text)
-- 
cgit v1.2.3