diff options
| -rw-r--r-- | src/Cana/Extra.hs | 32 |
1 files changed, 32 insertions, 0 deletions
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 = "" + } |