diff options
| -rw-r--r-- | src/Cana.hs | 12 | ||||
| -rw-r--r-- | 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) |