{- |
Copyright: 2006, Bjorn Bringert.
Copyright: 2009, Henning Thielemann.
-}
module Network.MoHWS.Part.CGI (
   Configuration, desc,
   mkCGIEnv, mkCGIResponse,
   ) where

import qualified Network.MoHWS.Module as Module
import qualified Network.MoHWS.Module.Description as ModuleDesc
import qualified Network.MoHWS.HTTP.Header as Header
import qualified Network.MoHWS.HTTP.Request as Request
import qualified Network.MoHWS.HTTP.Response as Response
import qualified Network.MoHWS.Stream as Stream
import qualified Network.MoHWS.Server.Request as ServerRequest
import qualified Network.MoHWS.Server.Context as ServerContext
import Network.MoHWS.Logger.Error (debug, abort, debugOnAbort, logError, )
import qualified Network.MoHWS.Utility as Util

import qualified Network.MoHWS.Configuration as Config
import qualified Network.MoHWS.Configuration.Accessor as ConfigA
import qualified Network.MoHWS.Configuration.Parser as ConfigParser
import qualified Data.Accessor.Basic as Accessor
import Data.Accessor.Basic ((.>))
import qualified Text.ParserCombinators.Parsec as Parsec
import Network.MoHWS.ParserUtility (trimLWS, )

import Data.Maybe.HT (toMaybe, )
import Data.Tuple.HT (mapFst, )
import Data.Bool.HT (if', )
import Control.Monad.Trans.Maybe (MaybeT, )
import Control.Concurrent (forkIO, )
import qualified Control.Exception as Exception
import Control.Monad.Trans.Class (lift, )
import Control.Monad (when, mzero, )
import Data.Char (toUpper, )
import Data.List (isSuffixOf, )
import Network.BSD (hostName, )
import Network.Socket (inet_ntoa, )
import Network.URI (uriQuery, )
import qualified System.IO as IO
import System.IO.Error (isEOFError, )
import System.Posix (isDirectory, isRegularFile, isSymbolicLink, )
import System.Process (runInteractiveProcess, waitForProcess, )
import Text.ParserCombinators.Parsec (parse, )


desc :: (Stream.C body) => ModuleDesc.T body Configuration
desc :: T body Configuration
desc =
   T Any Any
forall body ext. T body ext
ModuleDesc.empty {
      name :: String
ModuleDesc.name = String
"cgi",
      load :: T Configuration -> IO (T body)
ModuleDesc.load = T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return (T body -> IO (T body))
-> (T Configuration -> T body) -> T Configuration -> IO (T body)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T Configuration -> T body
forall body. C body => T Configuration -> T body
funs,
      configParser :: T () Configuration
ModuleDesc.configParser = T () Configuration
forall st. T st Configuration
parser,
      setDefltConfig :: Configuration -> Configuration
ModuleDesc.setDefltConfig = Configuration -> Configuration -> Configuration
forall a b. a -> b -> a
const Configuration
defltConfig
   }

data Configuration =
   Configuration {
      Configuration -> [String]
suffixes_ :: [String]
   }

defltConfig :: Configuration
defltConfig :: Configuration
defltConfig =
   Configuration :: [String] -> Configuration
Configuration {
      suffixes_ :: [String]
suffixes_ = [String
".cgi"]
   }

suffixes :: Accessor.T Configuration [String]
suffixes :: T Configuration [String]
suffixes =
   ([String] -> Configuration -> Configuration)
-> (Configuration -> [String]) -> T Configuration [String]
forall a r. (a -> r -> r) -> (r -> a) -> T r a
Accessor.fromSetGet (\[String]
x Configuration
c -> Configuration
c{suffixes_ :: [String]
suffixes_ = [String]
x}) Configuration -> [String]
suffixes_

parser :: ConfigParser.T st Configuration
parser :: T st Configuration
parser =
   String -> T st Configuration -> T st Configuration
forall st ext. String -> T st ext -> T st ext
ConfigParser.field String
"cgisuffixes" T st Configuration
forall st. T st Configuration
p_suffixes

p_suffixes :: ConfigParser.T st Configuration
p_suffixes :: T st Configuration
p_suffixes =
   T (T Configuration) [String]
-> GenParser Char st [String] -> T st Configuration
forall r a st.
T r a -> GenParser Char st a -> GenParser Char st (r -> r)
ConfigParser.set (T (T Configuration) Configuration
forall ext. T (T ext) ext
ConfigA.extension T (T Configuration) Configuration
-> T Configuration [String] -> T (T Configuration) [String]
forall a b c. T a b -> T b c -> T a c
.> T Configuration [String]
suffixes) (GenParser Char st [String] -> T st Configuration)
-> GenParser Char st [String] -> T st Configuration
forall a b. (a -> b) -> a -> b
$
   ParsecT String st Identity String -> GenParser Char st [String]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
Parsec.many ParsecT String st Identity String
forall st. GenParser Char st String
ConfigParser.stringLiteral

funs :: (Stream.C body) =>
   ServerContext.T Configuration -> Module.T body
funs :: T Configuration -> T body
funs T Configuration
st =
   T body
forall body. T body
Module.empty {
      handleRequest :: T body -> MaybeT IO (T body)
Module.handleRequest = T Configuration -> T body -> MaybeT IO (T body)
forall body.
C body =>
T Configuration -> T body -> MaybeT IO (T body)
handleRequest T Configuration
st
   }

handleRequest :: (Stream.C body) =>
   ServerContext.T Configuration -> ServerRequest.T body -> MaybeT IO (Response.T body)
handleRequest :: T Configuration -> T body -> MaybeT IO (T body)
handleRequest T Configuration
st T body
sreq =
    do let conf :: T Configuration
conf = T Configuration -> T Configuration
forall ext. T ext -> T ext
ServerContext.config T Configuration
st
       (String
pathProg, String
pathInfo) <-
          T Configuration
-> String
-> MaybeT IO (String, String)
-> MaybeT IO (String, String)
forall h a.
HasHandle h =>
h -> String -> MaybeT IO a -> MaybeT IO a
debugOnAbort T Configuration
st (String
"CGI: not handling " String -> String -> String
forall a. [a] -> [a] -> [a]
++ T body -> String
forall body. T body -> String
ServerRequest.serverFilename T body
sreq) (MaybeT IO (String, String) -> MaybeT IO (String, String))
-> MaybeT IO (String, String) -> MaybeT IO (String, String)
forall a b. (a -> b) -> a -> b
$
          T Configuration -> String -> MaybeT IO (String, String)
forall ext. T ext -> String -> MaybeT IO (String, String)
findProg T Configuration
st (T body -> String
forall body. T body -> String
ServerRequest.serverFilename T body
sreq)
       let sufs :: [String]
sufs = Configuration -> [String]
suffixes_ (Configuration -> [String]) -> Configuration -> [String]
forall a b. (a -> b) -> a -> b
$ T Configuration -> Configuration
forall ext. T ext -> ext
Config.extension T Configuration
conf
       Bool -> MaybeT IO () -> MaybeT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String -> String -> Bool) -> String -> String -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
pathProg) [String]
sufs)
          (T Configuration -> String -> MaybeT IO ()
forall h a. HasHandle h => h -> String -> MaybeT IO a
abort T Configuration
st (String -> MaybeT IO ()) -> String -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ String
"CGI: not handling " String -> String -> String
forall a. [a] -> [a] -> [a]
++ T body -> String
forall body. T body -> String
ServerRequest.serverFilename T body
sreq String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", wrong suffix")
       let hndle :: Bool -> IO (T body)
hndle = T Configuration
-> T body -> String -> String -> Bool -> IO (T body)
forall body ext.
C body =>
T ext -> T body -> String -> String -> Bool -> IO (T body)
handleRequest2 T Configuration
st T body
sreq String
pathProg String
pathInfo
       IO (T body) -> MaybeT IO (T body)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (T body) -> MaybeT IO (T body))
-> IO (T body) -> MaybeT IO (T body)
forall a b. (a -> b) -> a -> b
$
          case T body -> Command
forall body. T body -> Command
Request.command (T body -> T body
forall body. T body -> T body
ServerRequest.clientRequest T body
sreq) of
             Command
Request.GET  -> Bool -> IO (T body)
hndle Bool
False
             Command
Request.POST -> Bool -> IO (T body)
hndle Bool
True
             Command
_ -> T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return (T body -> IO (T body)) -> T body -> IO (T body)
forall a b. (a -> b) -> a -> b
$ T Configuration -> T body
forall body ext. C body => T ext -> T body
Response.makeNotImplemented T Configuration
conf

handleRequest2 :: (Stream.C body) =>
   ServerContext.T ext -> ServerRequest.T body -> FilePath -> String -> Bool -> IO (Response.T body)
handleRequest2 :: T ext -> T body -> String -> String -> Bool -> IO (T body)
handleRequest2 T ext
st T body
sreq String
pathProg String
pathInfo Bool
useReqBody =
    do let conf :: T ext
conf = T ext -> T ext
forall ext. T ext -> T ext
ServerContext.config T ext
st
       let req :: T body
req = T body -> T body
forall body. T body -> T body
ServerRequest.clientRequest T body
sreq

       [(String, String)]
env <- T ext -> T body -> String -> IO [(String, String)]
forall ext body. T ext -> T body -> String -> IO [(String, String)]
mkCGIEnv T ext
st T body
sreq String
pathInfo
       let wdir :: String
wdir = String -> String
Util.dirname String
pathProg
           prog :: String
prog = String
"./" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
Util.basename String
pathProg

       T ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Running CGI program: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prog String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
wdir

       (Handle
inp,Handle
out,Handle
err,ProcessHandle
pid)
           <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess String
prog [] (String -> Maybe String
forall a. a -> Maybe a
Just String
wdir) ([(String, String)] -> Maybe [(String, String)]
forall a. a -> Maybe a
Just [(String, String)]
env)


       if Bool
useReqBody
         then IO () -> IO ThreadId
forkIO (Handle -> T body -> IO ()
forall body. C body => Handle -> T body -> IO ()
writeBody Handle
inp T body
req) IO ThreadId -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         else Handle -> IO ()
IO.hClose Handle
inp

       -- log process stderr to the error log
       ThreadId
_ <- IO () -> IO ThreadId
forkIO (T ext -> Handle -> IO ()
forall ext. T ext -> Handle -> IO ()
logErrorsFromHandle T ext
st Handle
err)

       -- FIXME: exception handling
       -- FIXME: close handle?
       body
output <- Int -> Handle -> IO body
forall stream. C stream => Int -> Handle -> IO stream
Stream.readAll (T ext -> Int
forall ext. T ext -> Int
Config.chunkSize T ext
conf) Handle
out

       -- wait in a separate thread, so that this thread can continue.
       -- this is needed since output is lazy.
       ThreadId
_ <- IO () -> IO ThreadId
forkIO (ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid IO ExitCode -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

       case body -> Either String (Group, body)
forall body. C body => body -> Either String (Group, body)
parseCGIOutput body
output of
         Left String
errp ->
            do T ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logError T ext
st String
errp
               T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return (T body -> IO (T body)) -> T body -> IO (T body)
forall a b. (a -> b) -> a -> b
$ T ext -> T body
forall body ext. C body => T ext -> T body
Response.makeInternalServerError T ext
conf
         Right (Group
outputHeaders, body
content) ->
            Group -> body -> Handle -> IO (T body)
forall body. Group -> body -> Handle -> IO (T body)
mkCGIResponse Group
outputHeaders body
content Handle
out

mkCGIResponse :: Header.Group -> body -> IO.Handle -> IO (Response.T body)
mkCGIResponse :: Group -> body -> Handle -> IO (T body)
mkCGIResponse Group
outputHeaders body
content Handle
h =
    do let stat :: Maybe String
stat = Name -> Group -> Maybe String
forall a. HasHeaders a => Name -> a -> Maybe String
Header.lookup (String -> Name
Header.HdrCustom String
"Status") Group
outputHeaders
           loc :: Maybe String
loc  = Name -> Group -> Maybe String
forall a. HasHeaders a => Name -> a -> Maybe String
Header.lookup Name
Header.HdrLocation Group
outputHeaders
       (Int
code,String
dsc) <-
          case Maybe String
stat of
             Maybe String
Nothing -> let c :: Int
c = Int -> (String -> Int) -> Maybe String -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
200 (\String
_ -> Int
302) Maybe String
loc
                        in  (Int, String) -> IO (Int, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
c, Int -> String
Response.descriptionFromCode Int
c)
             Just String
s  -> case ReadS Int
forall a. Read a => ReadS a
reads String
s of
                          [(Int
c,String
r)] -> (Int, String) -> IO (Int, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
c, String -> String
trimLWS String
r)
                          [(Int, String)]
_       -> String -> IO (Int, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Bad Status line"

       let body :: Body body
body =
              Body :: forall body. String -> Maybe Integer -> IO () -> body -> Body body
Response.Body {
                 size :: Maybe Integer
Response.size = Maybe Integer
forall a. Maybe a
Nothing,
                 source :: String
Response.source = String
"CGI script",
                 close :: IO ()
Response.close = Handle -> IO ()
IO.hClose Handle
h,
                 content :: body
Response.content = body
content
              }

       -- FIXME: don't use response constructor directly
       T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return (T body -> IO (T body)) -> T body -> IO (T body)
forall a b. (a -> b) -> a -> b
$
          Int
-> String
-> Group
-> [TransferCoding]
-> Bool
-> Body body
-> T body
forall body.
Int
-> String
-> Group
-> [TransferCoding]
-> Bool
-> Body body
-> T body
Response.Cons Int
code String
dsc Group
outputHeaders [TransferCoding
Header.ChunkedTransferCoding] Bool
True Body body
body

-- Split the requested file system path into the path to an
-- existing file, and some extra path info
findProg :: ServerContext.T ext -> FilePath -> MaybeT IO (FilePath,String)
findProg :: T ext -> String -> MaybeT IO (String, String)
findProg T ext
st String
filename =
   case String -> [String]
Util.splitPath String
filename of
      []    -> MaybeT IO (String, String)
forall (m :: * -> *) a. MonadPlus m => m a
mzero -- this should never happen
      [String
""]  -> MaybeT IO (String, String)
forall (m :: * -> *) a. MonadPlus m => m a
mzero -- we got an empty path
      String
"":[String]
p  -> T ext -> String -> [String] -> MaybeT IO (String, String)
forall ext.
T ext -> String -> [String] -> MaybeT IO (String, String)
firstFile T ext
st String
"/" [String]
p -- absolute path
      String
p:[String]
r   -> T ext -> String -> [String] -> MaybeT IO (String, String)
forall ext.
T ext -> String -> [String] -> MaybeT IO (String, String)
firstFile T ext
st String
p [String]
r -- relative path

-- similar to Module.File.handleRequest
firstFile :: ServerContext.T ext -> FilePath -> [String] -> MaybeT IO (FilePath,String)
firstFile :: T ext -> String -> [String] -> MaybeT IO (String, String)
firstFile T ext
st String
p [String]
pis =
   let conf :: T ext
conf = T ext -> T ext
forall ext. T ext -> T ext
ServerContext.config T ext
st

       mkPath :: String -> String -> String
mkPath String
x String
y =
          if String -> Bool
Util.hasTrailingSlash String
x
            then String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y
            else String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y

       mkPathInfo :: [String] -> String
mkPathInfo [] = String
""
       mkPathInfo [String]
q  = String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
Util.glue String
"/" [String]
q

       checkStat :: FileStatus -> MaybeT IO (String, String)
checkStat FileStatus
stat =
          Bool
-> MaybeT IO (String, String)
-> MaybeT IO (String, String)
-> MaybeT IO (String, String)
forall a. Bool -> a -> a -> a
if' (FileStatus -> Bool
isDirectory FileStatus
stat)
             (case [String]
pis of
                []     -> T ext -> String -> MaybeT IO (String, String)
forall h a. HasHandle h => h -> String -> MaybeT IO a
abort T ext
st (String -> MaybeT IO (String, String))
-> String -> MaybeT IO (String, String)
forall a b. (a -> b) -> a -> b
$ String
"findProg: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is a directory"
                String
f:[String]
pis' -> T ext -> String -> [String] -> MaybeT IO (String, String)
forall ext.
T ext -> String -> [String] -> MaybeT IO (String, String)
firstFile T ext
st (String -> String -> String
mkPath String
p String
f) [String]
pis') (MaybeT IO (String, String) -> MaybeT IO (String, String))
-> MaybeT IO (String, String) -> MaybeT IO (String, String)
forall a b. (a -> b) -> a -> b
$
          Bool
-> MaybeT IO (String, String)
-> MaybeT IO (String, String)
-> MaybeT IO (String, String)
forall a. Bool -> a -> a -> a
if' (FileStatus -> Bool
isRegularFile FileStatus
stat) ((String, String) -> MaybeT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
p,[String] -> String
mkPathInfo [String]
pis)) (MaybeT IO (String, String) -> MaybeT IO (String, String))
-> MaybeT IO (String, String) -> MaybeT IO (String, String)
forall a b. (a -> b) -> a -> b
$
          Bool
-> MaybeT IO (String, String)
-> MaybeT IO (String, String)
-> MaybeT IO (String, String)
forall a. Bool -> a -> a -> a
if' (FileStatus -> Bool
isSymbolicLink FileStatus
stat)
             (if T ext -> Bool
forall ext. T ext -> Bool
Config.followSymbolicLinks T ext
conf
                then String -> MaybeT IO FileStatus
Util.statFile String
p MaybeT IO FileStatus
-> (FileStatus -> MaybeT IO (String, String))
-> MaybeT IO (String, String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FileStatus -> MaybeT IO (String, String)
checkStat
                else T ext -> String -> MaybeT IO (String, String)
forall h a. HasHandle h => h -> String -> MaybeT IO a
abort T ext
st (String
"findProg: Not following symlink: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
p)) (MaybeT IO (String, String) -> MaybeT IO (String, String))
-> MaybeT IO (String, String) -> MaybeT IO (String, String)
forall a b. (a -> b) -> a -> b
$
          (T ext -> String -> MaybeT IO (String, String)
forall h a. HasHandle h => h -> String -> MaybeT IO a
abort T ext
st (String -> MaybeT IO (String, String))
-> String -> MaybeT IO (String, String)
forall a b. (a -> b) -> a -> b
$ String
"Strange file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
p)
   in  T ext -> String -> MaybeT IO FileStatus -> MaybeT IO FileStatus
forall h a.
HasHandle h =>
h -> String -> MaybeT IO a -> MaybeT IO a
debugOnAbort T ext
st (String
"findProg: Not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
p) (String -> MaybeT IO FileStatus
Util.statSymLink String
p) MaybeT IO FileStatus
-> (FileStatus -> MaybeT IO (String, String))
-> MaybeT IO (String, String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
       FileStatus -> MaybeT IO (String, String)
checkStat

mkCGIEnv :: ServerContext.T ext -> ServerRequest.T body -> String -> IO [(String,String)]
mkCGIEnv :: T ext -> T body -> String -> IO [(String, String)]
mkCGIEnv T ext
_st T body
sreq String
pathInfo =
      do let req :: T body
req = T body -> T body
forall body. T body -> T body
ServerRequest.clientRequest T body
sreq
         String
remoteAddr <- HostAddress -> IO String
inet_ntoa (T body -> HostAddress
forall body. T body -> HostAddress
ServerRequest.clientAddress T body
sreq)
         let scriptName :: String
scriptName = T body -> String
forall body. T body -> String
ServerRequest.serverURIPath T body
sreq String -> String -> String
forall a. Eq a => [a] -> [a] -> [a]
`Util.dropSuffix` String
pathInfo
             -- FIXME: use canonical name if there is no ServerName
             serverEnv :: [(String, String)]
serverEnv =
                 [
                  (String
"SERVER_SOFTWARE",   String
Config.serverSoftware
                                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
Config.serverVersion),
                  (String
"SERVER_NAME",       HostEntry -> String
hostName (T body -> HostEntry
forall body. T body -> HostEntry
ServerRequest.requestHostName T body
sreq)),
                  (String
"GATEWAY_INTERFACE", String
"CGI/1.1")
                 ]
             requestEnv :: [(String, String)]
requestEnv =
                 [
                  (String
"SERVER_PROTOCOL",   T -> String
forall a. Show a => a -> String
show (T body -> T
forall body. T body -> T
Request.httpVersion T body
req)),
                  (String
"SERVER_PORT",       PortNumber -> String
forall a. Show a => a -> String
show (T body -> PortNumber
forall body. T body -> PortNumber
ServerRequest.serverPort T body
sreq)),
                  (String
"REQUEST_METHOD",    Command -> String
forall a. Show a => a -> String
show (T body -> Command
forall body. T body -> Command
Request.command T body
req)),
                  (String
"PATH_TRANSLATED",   T body -> String
forall body. T body -> String
ServerRequest.serverFilename T body
sreq),
                  (String
"SCRIPT_NAME",       String
scriptName),
                  (String
"QUERY_STRING",      URI -> String
uriQuery (T body -> URI
forall body. T body -> URI
Request.uri T body
req) String -> String -> String
forall a. Eq a => [a] -> [a] -> [a]
`Util.dropPrefix` String
"?"),
                  (String
"REMOTE_ADDR",       String
remoteAddr),
                  (String
"PATH_INFO",         String
pathInfo),
                  (String
"PATH",              String
"/usr/local/bin:/usr/bin:/bin")
                 ]
               [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> [(String, String)]
maybeHeader String
"AUTH_TYPE"      Maybe String
forall a. Maybe a
Nothing -- FIXME
               [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> [(String, String)]
maybeHeader String
"REMOTE_USER"    Maybe String
forall a. Maybe a
Nothing -- FIXME
               [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> [(String, String)]
maybeHeader String
"REMOTE_IDENT"   Maybe String
forall a. Maybe a
Nothing -- FIXME
               [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> [(String, String)]
maybeHeader String
"REMOTE_HOST"    ((HostEntry -> String) -> Maybe HostEntry -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HostEntry -> String
hostName (T body -> Maybe HostEntry
forall body. T body -> Maybe HostEntry
ServerRequest.clientName T body
sreq))
               [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> [(String, String)]
maybeHeader String
"CONTENT_TYPE"   (T body -> Maybe String
forall a. HasHeaders a => a -> Maybe String
Header.getContentType T body
req)
               [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> [(String, String)]
maybeHeader String
"CONTENT_LENGTH" ((Integer -> String) -> Maybe Integer -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> String
forall a. Show a => a -> String
show (Maybe Integer -> Maybe String) -> Maybe Integer -> Maybe String
forall a b. (a -> b) -> a -> b
$ T body -> Maybe Integer
forall a. HasHeaders a => a -> Maybe Integer
Header.getContentLength T body
req)
             hs :: [a]
hs = [] -- FIXME: convert headers to (name,value) pairs
             headerEnv :: [(String, b)]
headerEnv = [(String
"HTTP_"String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
n, b
v) | (String
n,b
v) <- [(String, b)]
forall a. [a]
hs]

         [(String, String)] -> IO [(String, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, String)] -> IO [(String, String)])
-> [(String, String)] -> IO [(String, String)]
forall a b. (a -> b) -> a -> b
$ [(String, String)]
serverEnv [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String, String)]
requestEnv [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String, String)]
forall b. [(String, b)]
headerEnv

-- Writes the body of a request to a handle.
writeBody :: (Stream.C body) =>
   IO.Handle -> Request.T body -> IO ()
writeBody :: Handle -> T body -> IO ()
writeBody Handle
h T body
req =
   Handle -> body -> IO ()
forall stream. C stream => Handle -> stream -> IO ()
Stream.write Handle
h (T body -> body
forall body. T body -> body
Request.body T body
req)
   IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`Exception.finally`
   Handle -> IO ()
IO.hClose Handle
h

-- | Reads lines form the given 'Handle' and log them with 'logError'.
logErrorsFromHandle :: ServerContext.T ext -> IO.Handle -> IO ()
logErrorsFromHandle :: T ext -> Handle -> IO ()
logErrorsFromHandle T ext
st Handle
h =
    ((IOError -> Maybe IOError) -> IO () -> (IOError -> IO ()) -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
Exception.catchJust (\ IOError
e -> Bool -> IOError -> Maybe IOError
forall a. Bool -> a -> Maybe a
toMaybe (IOError -> Bool
isEOFError IOError
e) IOError
e)
        IO ()
forall b. IO b
loop (IO () -> IOError -> IO ()
forall a b. a -> b -> a
const (IO () -> IOError -> IO ()) -> IO () -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
     IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
     \(Exception.SomeException e
e) -> T ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logError T ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"CGI:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e)
      IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`Exception.finally` Handle -> IO ()
IO.hClose Handle
h
  where loop :: IO b
loop = do String
l <- Handle -> IO String
IO.hGetLine Handle
h
                  T ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logError T ext
st String
l
                  IO b
loop

maybeHeader :: String -> Maybe String -> [(String,String)]
maybeHeader :: String -> Maybe String -> [(String, String)]
maybeHeader String
n = [(String, String)]
-> (String -> [(String, String)])
-> Maybe String
-> [(String, String)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (((String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:[]) ((String, String) -> [(String, String)])
-> (String -> (String, String)) -> String -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) String
n)

{-
expects CRLF line endings, which is too strict

parseCGIOutput :: B.ByteString -> Either String (Header.Group, B.ByteString)
parseCGIOutput s =
   let (hdrsStr, body) = breakHeaders s
   in  case parse Header.pGroup "CGI output" hdrsStr of
          Left err -> Left (show err)
          Right hdrs  -> Right (hdrs, body)

breakHeaders :: B.ByteString -> (String, B.ByteString)
breakHeaders =
   (\(hdrs, body) ->
      mapFst (map B.head hdrs ++) $
      if B.null $ head body
        then ("", B.empty)
        else (crLf, body!!4)) .
   break (\suffix -> B.isPrefixOf (B.pack (crLf++crLf)) suffix || B.null suffix) .
   B.tails
-}

parseCGIOutput :: (Stream.C body) => body -> Either String (Header.Group, body)
parseCGIOutput :: body -> Either String (Group, body)
parseCGIOutput body
s =
   let ([String]
hdrLines, body
body) = body -> ([String], body)
forall body. C body => body -> ([String], body)
breakHeaders body
s
   in  -- parse headers in one go in order to handle multi-line headers correctly
       case Parsec String () Group
-> String -> String -> Either ParseError Group
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () Group
Header.pGroup String
"CGI output" (String -> Either ParseError Group)
-> String -> Either ParseError Group
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
hdrLines of
          Left ParseError
err -> String -> Either String (Group, body)
forall a b. a -> Either a b
Left (ParseError -> String
forall a. Show a => a -> String
show ParseError
err)
          Right Group
hdrs -> (Group, body) -> Either String (Group, body)
forall a b. b -> Either a b
Right (Group
hdrs, body
body)

breakHeaders :: (Stream.C body) => body -> ([String], body)
breakHeaders :: body -> ([String], body)
breakHeaders body
str =
   let (body
hdr,body
rest0) = (Char -> Bool) -> body -> (body, body)
forall stream.
C stream =>
(Char -> Bool) -> stream -> (stream, stream)
Stream.break (\Char
c -> Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\r' Bool -> Bool -> Bool
|| Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') body
str
       skip :: Int
skip =
          if body -> body -> Bool
forall stream. C stream => stream -> stream -> Bool
Stream.isPrefixOf (Int -> String -> body
forall stream. C stream => Int -> String -> stream
Stream.fromString Int
2 String
"\r\n") body
rest0 Bool -> Bool -> Bool
||
             body -> body -> Bool
forall stream. C stream => stream -> stream -> Bool
Stream.isPrefixOf (Int -> String -> body
forall stream. C stream => Int -> String -> stream
Stream.fromString Int
2 String
"\n\r") body
rest0
            then Int
2 else Int
1
       rest1 :: body
rest1 = Int -> body -> body
forall stream. C stream => Int -> stream -> stream
Stream.drop Int
skip body
rest0
   in  if body -> Bool
forall stream. C stream => stream -> Bool
Stream.isEmpty body
hdr
         then ([], body
rest1)
         else ([String] -> [String]) -> ([String], body) -> ([String], body)
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (body -> String
forall stream. C stream => stream -> String
Stream.toString body
hdr String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) (([String], body) -> ([String], body))
-> ([String], body) -> ([String], body)
forall a b. (a -> b) -> a -> b
$ body -> ([String], body)
forall body. C body => body -> ([String], body)
breakHeaders body
rest1