CGI: Use envvars to pass request URL

This is more conforming to other CGI environments, see for example [1]
and [2].

This also allows us to easily add more fields in the future, for example
to pass the remote address, the TLS certificate, the server version, ...

[1]: https://en.wikipedia.org/wiki/Common_Gateway_Interface#Example
[2]: https://sr.ht/~int80h/gemserv/

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)