CGI.hs

-- Copyright 2006, Bjorn Bringert.
module Module.CGI (desc,
                   mkCGIEnv, mkCGIResponse
                  ) where

import Config
import Headers
import Parse
import Request
import Response
import ServerRequest
import ServerState
import Util

import Control.Concurrent
import Control.Exception as Exception
import Control.Monad
import Data.Char (toUpper)
import Data.List
import Network.BSD (hostName)
import Network.Socket (inet_ntoa)
import Network.URI
import System.IO
import System.IO.Error
import System.Posix
import System.Process (runInteractiveProcess, waitForProcess)
import Text.ParserCombinators.Parsec


desc :: ModuleDesc
desc = emptyModuleDesc {
                        moduleName = "cgi",
                        moduleLoad = return funs
                       }

funs :: Module
funs = emptyModule {
                    moduleHandleRequest = cgiHandleRequest
                   }

cgiHandleRequest :: ServerState -> ServerRequest -> IO (Maybe Response)
cgiHandleRequest st sreq =
    do m_prog <- findProg st (serverFilename sreq)
       case m_prog of
         Nothing -> do debug st $ "CGI: not handling " ++ serverFilename sreq
                       return Nothing
         Just (path_prog, path_info) ->
             do if ".cgi" `isSuffixOf` path_prog -- FIXME: add AddHandler mechanism
                 then do let hndle = cgiHandleRequest2 st sreq path_prog path_info
                         liftM Just $ case reqCmd (clientRequest sreq) of
                                        GetReq  -> hndle False
                                        PostReq -> hndle True
                                        _       -> return $ notImplementedResponse conf
                 else do debug st $ "CGI: not handling " ++ serverFilename sreq ++ ", wrong suffix"
                         return Nothing
  where conf = serverConfig st

cgiHandleRequest2 :: ServerState -> ServerRequest -> FilePath -> String -> Bool -> IO Response
cgiHandleRequest2 st sreq path_prog path_info useReqBody =
    do let conf = serverConfig st
       let req = clientRequest sreq

       env <- mkCGIEnv st sreq path_info
       let wdir = dirname path_prog
           prog = "./" ++ basename path_prog

       debug st $ "Running CGI program: " ++ prog ++ " in " ++ wdir

       (inp,out,err,pid)
           <- runInteractiveProcess prog [] (Just wdir) (Just env)


       if useReqBody then forkIO (writeBody inp req) >> return ()
                     else hClose inp

       -- log process stderr to the error log
       forkIO (logErrorsFromHandle st err)

       -- FIXME: exception handling
       -- FIXME: close handle?
       output <- hGetContents out

       -- wait in a separate thread, so that this thread can continue.
       -- this is needed since output is lazy.
       forkIO (waitForProcess pid >> return ())

       case parseCGIOutput output of
         Left errp -> do logError st errp
                         return $ internalServerErrorResponse conf
         Right (outputHeaders, content) -> mkCGIResponse outputHeaders content

mkCGIResponse :: Headers -> String -> IO Response
mkCGIResponse outputHeaders content =
    do let stat = lookupHeader (HdrCustom "Status") outputHeaders
           loc  = lookupHeader HdrLocation outputHeaders
       (code,dsc) <- case stat of
                        Nothing -> let c = maybe 200 (\_ -> 302) loc
                                    in return (c, responseDescription c)
                        Just s  -> case reads s of
                                     [(c,r)] -> return (c,trimLWS r)
                                     _       -> fail "Bad Status line"
       -- FIXME: don't use response constructor directly
       return (Response code dsc outputHeaders [] (HereItIs content) True)

-- Split the requested file system path into the path to an
-- existing file, and some extra path info
findProg :: ServerState -> FilePath -> IO (Maybe (FilePath,String))
findProg st filename = case splitPath filename of
                           []    -> return Nothing -- this should never happen
                           [""]  -> return Nothing -- we got an empty path
                           "":p  -> firstFile st "/" p -- absolute path
                           p:r   -> firstFile st p r -- relative path

firstFile :: ServerState -> FilePath -> [String] -> IO (Maybe (FilePath,String))
firstFile st p pis =
    do m_lstat <- statSymLink p
       checkStat m_lstat
  where conf = serverConfig st

        mkPath x y | "/" `isSuffixOf` x = x ++ y
                   | otherwise          = x ++ "/" ++ y

        mkPathInfo [] = ""
        mkPathInfo q  = "/" ++ glue "/" q

        checkStat Nothing = do debug st $ "findProg: Not found: " ++ show p
                               return Nothing
        checkStat (Just stat)
            | isDirectory stat =
                case pis of
                  []    -> do debug st $ "findProg: " ++ show p ++ " is a directory"
                              return Nothing
                  f:pis' -> firstFile st (mkPath p f) pis'
            | isRegularFile stat  = return $ Just (p,mkPathInfo pis)
            | isSymbolicLink stat = if followSymLinks conf
                                      then statFile p >>= checkStat
                                      else do debug st $ "findProg: Not following symlink: " ++ show p
                                              return Nothing
            | otherwise         = do debug st $ "Strange file: " ++ show p
                                     return Nothing

mkCGIEnv :: ServerState -> ServerRequest -> String -> IO [(String,String)]
mkCGIEnv st sreq path_info
    = do let req = clientRequest sreq
         remoteAddr <- inet_ntoa (clientAddress sreq)
         let scriptName = serverURIPath sreq `dropSuffix` path_info
             -- FIXME: use canonical name if there is no ServerName
             serverEnv =
                 [
                  ("SERVER_SOFTWARE",   serverSoftware
                                        ++ "/" ++ serverVersion),
                  ("SERVER_NAME",       hostName (requestHostName sreq)),
                  ("GATEWAY_INTERFACE", "CGI/1.1")
                 ]
             requestEnv =
                 [
                  ("SERVER_PROTOCOL",   show (reqHTTPVer req)),
                  ("SERVER_PORT",       show (serverPort st)),
                  ("REQUEST_METHOD",    show (reqCmd req)),
                  ("PATH_TRANSLATED",   serverFilename sreq),
                  ("SCRIPT_NAME",       scriptName),
                  ("QUERY_STRING",      uriQuery (reqURI req) `dropPrefix` "?"),
                  ("REMOTE_ADDR",       remoteAddr),
                  ("PATH_INFO",         path_info)
                 ]
               ++ maybeHeader "AUTH_TYPE"      Nothing -- FIXME
               ++ maybeHeader "REMOTE_USER"    Nothing -- FIXME
               ++ maybeHeader "REMOTE_IDENT"   Nothing -- FIXME
               ++ maybeHeader "REMOTE_HOST"    (fmap hostName (clientName sreq))
               ++ maybeHeader "CONTENT_TYPE"   (getContentType req)
               ++ maybeHeader "CONTENT_LENGTH" (fmap show $ getContentLength req)
             hs = [] -- FIXME: convert headers to (name,value) pairs
             headerEnv = [("HTTP_"++ map toUpper n, v) | (n,v) <- hs]

         return $ serverEnv ++ requestEnv ++ headerEnv

-- Writes the body of a request to a handle.
writeBody :: Handle -> Request -> IO ()
writeBody h req = do hPutStr h (reqBody req)
                     hClose h

-- | Reads lines form the given 'Handle' and log them with 'logError'.
logErrorsFromHandle :: ServerState -> Handle -> IO ()
logErrorsFromHandle st h =
    (loop `Exception.catch` \e ->
        case e of
          IOException f | isEOFError f -> return ()
          _ -> logError st $ "CGI:" ++ show e)
      `Exception.finally` hClose h
  where loop = do l <- hGetLine h
                  logError st l
                  loop

maybeHeader :: String -> Maybe String -> [(String,String)]
maybeHeader n = maybe [] ((:[]) . (,) n)

parseCGIOutput :: String -> Either String (Headers,String)
parseCGIOutput s = case parse pCGIOutput "CGI output" s of
                    Left err -> Left (show err)
                    Right x  -> Right x

pCGIOutput :: Parser  (Headers,String)
pCGIOutput =
    do headers <- pHeaders
       pCRLF
       body <- getInput
       return (headers, body)