aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Cana/Handlers.hs15
-rw-r--r--src/Cana/Util.hs20
2 files changed, 33 insertions, 2 deletions
diff --git a/src/Cana/Handlers.hs b/src/Cana/Handlers.hs
index acf4e7c..81d3266 100644
--- a/src/Cana/Handlers.hs
+++ b/src/Cana/Handlers.hs
@@ -32,6 +32,8 @@ import qualified Data.Text as T
import System.FilePath
import System.Directory
import System.Process.ByteString.Lazy
+import System.Process.ListLike (CreateProcess(..), proc)
+import System.Environment
import System.Exit (ExitCode(..))
import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy as BSL
@@ -163,9 +165,18 @@ runCGI :: FilePath -- ^ CGI script
-> [String] -- ^ Script arguments
-> Handler
runCGI script args request = do
- let uri = UTF8.fromString . show . requestUri $ request
+ let uri = show . requestUri $ request
+ procspec = proc script args
+ -- Define CGI variables here
+ cgiEnv =
+ [ ("GEMINI_URL", uri)
+ , ("SCRIPT_NAME", script)
+ ]
+
+ newEnv <- insertAll cgiEnv <$> liftIO getEnvironment
+ let procspec' = procspec { env = Just newEnv }
(scriptResult :: Either SomeException rest_) <- liftIO . try
- $ readProcessWithExitCode script args uri
+ $ readCreateProcessWithExitCode procspec' ""
(code, stdout, stderr) <- except
$ mapLeft (\e -> "CGI execution error: " ++ show e) scriptResult
diff --git a/src/Cana/Util.hs b/src/Cana/Util.hs
index fd61c31..25c7411 100644
--- a/src/Cana/Util.hs
+++ b/src/Cana/Util.hs
@@ -8,9 +8,12 @@ module Cana.Util
, mapLeft
, unwrapMaybe
, applyWhen
+ , insert
+ , insertAll
) where
import Control.Monad.Trans.Except
+import Data.List (foldl')
-- | Split a list on the given element, useful for 'String's.
--
@@ -44,3 +47,20 @@ unwrapMaybe _ (Just x) = return x
applyWhen :: Bool -> (a -> a) -> a -> a
applyWhen True f = f
applyWhen _ _ = id
+
+-- | Inserts an item into an associative list.
+--
+-- Note that the performance is rather bad, so prefer to use proper Maps for
+-- larger structures.
+insert :: Eq a => a -> b -> [(a, b)] -> [(a, b)]
+insert key val [] = [(key, val)]
+insert key val ((k, v):xs)
+ | key == k = (key, val):xs
+ | otherwise = (k, v) : insert key val xs
+
+-- | Inserts all key-value-pairs from the first list into the second one.
+--
+-- Note that the performance is rather bad, so prefer to use proper Maps for
+-- larger structures.
+insertAll :: Eq a => [(a, b)] -> [(a, b)] -> [(a, b)]
+insertAll = flip $ foldl' (\c (k, v) -> insert k v c)