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 ...)

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)