diff options
| -rw-r--r-- | Cana.cabal | 1 | ||||
| -rw-r--r-- | src/Cana/Handlers.hs | 15 | ||||
| -rw-r--r-- | src/Cana/Util.hs | 20 | ||||
| -rw-r--r-- | test/Cana/UtilSpec.hs | 23 |
4 files changed, 57 insertions, 2 deletions
@@ -99,6 +99,7 @@ test-suite Cana-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Cana.ProtocolSpec Cana.UtilSpec Paths_Cana hs-source-dirs: 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) diff --git a/test/Cana/UtilSpec.hs b/test/Cana/UtilSpec.hs index 7a3292a..2ccbf5b 100644 --- a/test/Cana/UtilSpec.hs +++ b/test/Cana/UtilSpec.hs @@ -25,3 +25,26 @@ spec = do applyWhen True (+1) (3 :: Int) `shouldBe` 4 it "doesn't apply a function when False is given" $ do applyWhen False (+1) (3 :: Int) `shouldBe` 3 + + describe "insert" $ do + it "works on an empty list" $ do + insert "foo" "bar" [] `shouldBe` [("foo", "bar")] + it "replaces an existing element" $ do + let i = insert "foo" "bar" [("a", "b"), ("foo", "baz"), ("c", "d")] + i `shouldContain` [("a", "b")] + i `shouldContain` [("foo", "bar")] + i `shouldContain` [("c", "d")] + length i `shouldBe` 3 + it "inserts a missing element" $ do + let i = insert "foo" "bar" [("a", "b")] + i `shouldContain` [("a", "b")] + i `shouldContain` [("foo", "bar")] + length i `shouldBe` 2 + + describe "insertAll" $ do + it "inserts all elements" $ do + let i = insertAll [("foo", "bar"), ("qux", "baz")] [("a", "b"), ("foo", "gulp")] + i `shouldContain` [("foo", "bar")] + i `shouldContain` [("qux", "baz")] + i `shouldContain` [("a", "b")] + length i `shouldBe` 3 |