CGI.hs

{-# LANGUAGE OverloadedStrings #-}

module Network.Wai.Application.Classic.CGI (
    cgiApp
  ) where

import Blaze.ByteString.Builder.ByteString
import Control.Applicative
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.Enumerator (Iteratee,Enumeratee,run_,($$),joinI)
import qualified Data.Enumerator as E (map)
import qualified Data.Enumerator.Binary as EB
import qualified Data.Enumerator.List as EL
import Network.Wai
import Network.Wai.Application.Classic.EnumLine as ENL
import Network.Wai.Application.Classic.Field
import Network.Wai.Application.Classic.Header
import Network.Wai.Application.Classic.Types
import Network.Wai.Application.Classic.Utils
import System.FilePath
import System.IO
import System.Process

----------------------------------------------------------------

type ENVVARS = [(String,String)]

gatewayInterface :: String
gatewayInterface = "CGI/1.1"

----------------------------------------------------------------

{-|
  Handle GET and POST for CGI.

The program to link this library must ignore SIGCHLD as follow:

>   installHandler sigCHLD Ignore Nothing
-}
cgiApp :: AppSpec -> CgiRoute -> Application
cgiApp spec cgii req = case method of
    "GET"  -> cgiApp' False spec cgii req
    "POST" -> cgiApp' True  spec cgii req
    _      -> return $ responseLBS statusNotAllowed textPlain "Method Not Allowed"
  where
    method = requestMethod req

cgiApp' :: Bool -> AppSpec -> CgiRoute -> Application
cgiApp' body spec cgii req = do
    naddr <- liftIO . getPeerAddr . remoteHost $ req
    (Just whdl,Just rhdl,_,_) <- liftIO . createProcess . proSpec $ naddr
    liftIO $ do
        hSetEncoding rhdl latin1
        hSetEncoding whdl latin1
    when body $ EL.consume >>= liftIO . mapM_ (BS.hPutStr whdl)
    liftIO . hClose $ whdl
    (return . ResponseEnumerator) (\build ->
        run_ $ EB.enumHandle 4096 rhdl $$ do
            m <- (>>= check) <$> parseHeader
            let (st, hdr, emp) = case m of
                    Nothing    -> (status500,[],True)
                    Just (s,h) -> (s,h,False)
                hdr' = addHeader hdr
            liftIO $ logger spec req st
            if emp
               then emptyBody =$ response build st hdr'
               else              response build st hdr')
  where
    proSpec naddr = CreateProcess {
        cmdspec = RawCommand prog []
      , cwd = Nothing
      , env = Just (makeEnv req naddr scriptName pathinfo (softwareName spec))
      , std_in = CreatePipe
      , std_out = CreatePipe
      , std_err = Inherit
      , close_fds = True
      }
    (prog, scriptName, pathinfo) = pathinfoToCGI (cgiSrc cgii)
                                                 (cgiDst cgii)
                                                 (pathInfo req)
    toBuilder = E.map fromByteString
    emptyBody = EB.isolate 0
    response build status hs = toBuilder =$ build status hs
    check hs = lookupField fkContentType hs >> case lookupField "status" hs of
        Nothing -> Just (status200, hs)
        Just l  -> toStatus l >>= \s -> Just (s,hs')
      where
        hs' = filter (\(k,_) -> ciLowerCase k /= "status") hs
    toStatus s = BS.readInt s >>= \x -> Just (Status (fst x) s)
    addHeader hdr = ("Server", softwareName spec) : hdr

----------------------------------------------------------------

makeEnv :: Request -> NumericAddress -> String -> String -> ByteString -> ENVVARS
makeEnv req naddr scriptName pathinfo sname = addLength . addType . addCookie $ baseEnv
  where
    baseEnv = [
        ("GATEWAY_INTERFACE", gatewayInterface)
      , ("SCRIPT_NAME",       scriptName)
      , ("REQUEST_METHOD",    BS.unpack . requestMethod $ req)
      , ("SERVER_NAME",       BS.unpack . serverName $ req)
      , ("SERVER_PORT",       show . serverPort $ req)
      , ("REMOTE_ADDR",       naddr)
      , ("SERVER_PROTOCOL",   "HTTP/" ++ (BS.unpack . httpVersion $ req))
      , ("SERVER_SOFTWARE",   BS.unpack sname)
      , ("PATH_INFO",         pathinfo)
      , ("QUERY_STRING",      query req)
      ]
    headers = requestHeaders req
    addLength = addEnv "CONTENT_LENGTH" $ lookupField fkContentLength headers
    addType   = addEnv "CONTENT_TYPE" $ lookupField fkContentType headers
    addCookie = addEnv "HTTP_COOKIE" $ lookupField fkCookie headers
    query = BS.unpack . safeTail . queryString
      where
        safeTail "" = ""
        safeTail bs = BS.tail bs

addEnv :: String -> Maybe ByteString -> ENVVARS -> ENVVARS
addEnv _   Nothing    envs = envs
addEnv key (Just val) envs = (key,BS.unpack val) : envs

----------------------------------------------------------------

parseHeader :: Iteratee ByteString IO (Maybe RequestHeaders)
parseHeader = takeHeader >>= maybe (return Nothing)
                                   (return . Just . map parseField)
  where
    parseField bs = (CIByteString key skey, val)
      where
        (key,val) = case BS.break (==':') bs of
            kv@(_,"") -> kv
            (k,v) -> let v' = BS.dropWhile (==' ') $ BS.tail v in (k,v')
        skey = BS.map toLower key

takeHeader :: Iteratee ByteString IO (Maybe [ByteString])
takeHeader = ENL.head >>= maybe (return Nothing) $. \l ->
    if l == ""
       then return (Just [])
       else takeHeader >>= maybe (return Nothing) (return . Just . (l:))

pathinfoToCGI :: ByteString -> FilePath -> ByteString -> (FilePath, String, String)
pathinfoToCGI src dst path = (prog, scriptName, pathinfo)
  where
    src' = BS.unpack src
    path' = drop (BS.length src) $ BS.unpack path
    (prog',pathinfo) = break (== '/') path'
    prog = dst </> prog'
    scriptName = src' </> prog'

----------------------------------------------------------------

infixr 0 =$

(=$) :: Monad m => Enumeratee ao ai m b -> Iteratee ai m b -> Iteratee ao m b
ee =$ ie = joinI $ ee $$ ie

----------------------------------------------------------------

infixr 6 $.

($.) :: (a -> b) -> a -> b
($.) = ($)