From 6e2e977dcf5ca288be9f4207723211692f4b1e08 Mon Sep 17 00:00:00 2001
From: Daniel Schadt <kingdread@gmx.de>
Date: Wed, 30 Jun 2021 13:38:29 +0200
Subject: CGI: Don't silently ignore exceptions

---
 src/Cana/Extra.hs | 12 ++++++++++--
 1 file changed, 10 insertions(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/Cana/Extra.hs b/src/Cana/Extra.hs
index 6076155..f4d9f73 100644
--- a/src/Cana/Extra.hs
+++ b/src/Cana/Extra.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, PartialTypeSignatures #-}
 -- |
 -- Module     : Cana.Extra
 --
@@ -18,6 +18,7 @@ import           Cana.Monad
 import           Control.Applicative
 import           Control.Monad
 import           Control.Monad.Trans.Maybe
+import           Control.Exception          (SomeException, try)
 
 import           Data.String
 import           Data.Maybe
@@ -100,9 +101,12 @@ runCGI :: FilePath -- ^ CGI script
        -> [String] -- ^ Script arguments
        -> Handler
 runCGI script args request = do
-  (code, stdout, stderr) <- liftIO
+  (scriptResult :: Either SomeException rest_) <- liftIO . try
     $ readProcessWithExitCode script args (show $ requestUri request)
 
+  (code, stdout, stderr) <- except
+    $ mapLeft (\e -> "CGI execution error: " ++ show e) scriptResult
+
   case code of
     ExitFailure _ -> do
       logError ("CGI script " ++ script ++ " exited with an error:")
@@ -122,3 +126,7 @@ runCGI script args request = do
       , responseMeta   = "Dynamic content generation has failed"
       , responseData   = ""
       }
+
+    mapLeft :: (a -> b) -> Either a c -> Either b c
+    mapLeft f (Left x)  = Left (f x)
+    mapLeft _ (Right x) = Right x
-- 
cgit v1.2.3