From 369fe2b94ea49962be43ec968638b5d93c6f32f8 Mon Sep 17 00:00:00 2001
From: Daniel Schadt <kingdread@gmx.de>
Date: Wed, 30 Jun 2021 13:25:41 +0200
Subject: implement basic CGI handler

---
 src/Cana/Extra.hs | 32 ++++++++++++++++++++++++++++++++
 1 file changed, 32 insertions(+)

diff --git a/src/Cana/Extra.hs b/src/Cana/Extra.hs
index efcdb8c..6076155 100644
--- a/src/Cana/Extra.hs
+++ b/src/Cana/Extra.hs
@@ -8,10 +8,12 @@
 module Cana.Extra
     ( -- * High-Level handlers
       staticFiles
+    , runCGI
     ) where
 
 import           Cana.Types
 import           Cana.Protocol
+import           Cana.Monad
 
 import           Control.Applicative
 import           Control.Monad
@@ -22,6 +24,8 @@ import           Data.Maybe
 import qualified Data.Text                  as T
 import           System.FilePath
 import           System.Directory
+import           System.Process
+import           System.Exit                (ExitCode(..))
 import           Control.Monad.IO.Class
 import qualified Data.ByteString.Lazy       as BSL
 import           Data.ByteString.Lazy.Char8 (pack)
@@ -90,3 +94,31 @@ staticFiles basedir request = do
       | takeExtension path == ".gmi" = geminiMime
       | otherwise                    = BSL.fromStrict
         . defaultMimeLookup . T.pack $ takeFileName path
+
+-- | Returns a handler that calls an external script for each request.
+runCGI :: FilePath -- ^ CGI script
+       -> [String] -- ^ Script arguments
+       -> Handler
+runCGI script args request = do
+  (code, stdout, stderr) <- liftIO
+    $ readProcessWithExitCode script args (show $ requestUri request)
+
+  case code of
+    ExitFailure _ -> do
+      logError ("CGI script " ++ script ++ " exited with an error:")
+      liftIO $ putStrLn stderr
+      return invalidResponse
+
+    ExitSuccess  -> case parseResponse $ pack stdout of
+      Nothing -> do
+        logError ("CGI script " ++ script ++ " returned malformed response")
+        return invalidResponse
+      Just r  -> return r
+
+  where
+    invalidResponse :: GeminiResponse
+    invalidResponse = GeminiResponse
+      { responseStatus = codeCGIError
+      , responseMeta   = "Dynamic content generation has failed"
+      , responseData   = ""
+      }
-- 
cgit v1.2.3