{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
-- | Backend for Common Gateway Interface. Almost all users should use the
-- 'run' function.
module Network.Wai.Handler.CGI
    ( run
    , runSendfile
    , runGeneric
    , requestBodyFunc
    ) where

#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (mconcat, mempty, mappend)
#endif
import Control.Arrow ((***))
import Control.Monad (unless, void)
import Data.ByteString.Builder (byteString, char7, string8, toLazyByteString)
import Data.ByteString.Builder.Extra (flush)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Lazy.Internal (defaultChunkSize)
import qualified Data.CaseInsensitive as CI
import Data.Char (toLower)
import Data.Function (fix)
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)
import qualified Data.Streaming.ByteString.Builder as Builder
import qualified Data.String as String
import Network.HTTP.Types (Status (..), hContentLength, hContentType, hRange)
import qualified Network.HTTP.Types as H
import Network.Socket (addrAddress, getAddrInfo)
import Network.Wai
import Network.Wai.Internal
import System.IO (Handle)
import qualified System.IO

#if WINDOWS
import System.Environment (getEnvironment)
#else
import qualified System.Posix.Env.ByteString as Env

getEnvironment :: IO [(String, String)]
getEnvironment :: IO [(String, String)]
getEnvironment = forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> String
B.unpack forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> String
B.unpack) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO [(ByteString, ByteString)]
Env.getEnvironment
#endif

safeRead :: Read a => a -> String -> a
safeRead :: forall a. Read a => a -> String -> a
safeRead a
d String
s =
  case forall a. Read a => ReadS a
reads String
s of
    ((a
x, String
_):[(a, String)]
_) -> a
x
    [] -> a
d

lookup' :: String -> [(String, String)] -> String
lookup' :: String -> [(String, String)] -> String
lookup' String
key [(String, String)]
pairs = forall a. a -> Maybe a -> a
fromMaybe String
"" forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
key [(String, String)]
pairs

-- | Run an application using CGI.
run :: Application -> IO ()
run :: Application -> IO ()
run Application
app = do
    [(String, String)]
vars <- IO [(String, String)]
getEnvironment
    let input :: Int -> IO (IO ByteString)
input = Handle -> Int -> IO (IO ByteString)
requestBodyHandle Handle
System.IO.stdin
        output :: ByteString -> IO ()
output = Handle -> ByteString -> IO ()
B.hPut Handle
System.IO.stdout
    [(String, String)]
-> (Int -> IO (IO ByteString))
-> (ByteString -> IO ())
-> Maybe ByteString
-> Application
-> IO ()
runGeneric [(String, String)]
vars Int -> IO (IO ByteString)
input ByteString -> IO ()
output forall a. Maybe a
Nothing Application
app

-- | Some web servers provide an optimization for sending files via a sendfile
-- system call via a special header. To use this feature, provide that header
-- name here.
runSendfile :: B.ByteString -- ^ sendfile header
            -> Application -> IO ()
runSendfile :: ByteString -> Application -> IO ()
runSendfile ByteString
sf Application
app = do
    [(String, String)]
vars <- IO [(String, String)]
getEnvironment
    let input :: Int -> IO (IO ByteString)
input = Handle -> Int -> IO (IO ByteString)
requestBodyHandle Handle
System.IO.stdin
        output :: ByteString -> IO ()
output = Handle -> ByteString -> IO ()
B.hPut Handle
System.IO.stdout
    [(String, String)]
-> (Int -> IO (IO ByteString))
-> (ByteString -> IO ())
-> Maybe ByteString
-> Application
-> IO ()
runGeneric [(String, String)]
vars Int -> IO (IO ByteString)
input ByteString -> IO ()
output (forall a. a -> Maybe a
Just ByteString
sf) Application
app

-- | A generic CGI helper, which allows other backends (FastCGI and SCGI) to
-- use the same code as CGI. Most users will not need this function, and can
-- stick with 'run' or 'runSendfile'.
runGeneric
     :: [(String, String)] -- ^ all variables
     -> (Int -> IO (IO B.ByteString)) -- ^ responseBody of input
     -> (B.ByteString -> IO ()) -- ^ destination for output
     -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?
     -> Application
     -> IO ()
runGeneric :: [(String, String)]
-> (Int -> IO (IO ByteString))
-> (ByteString -> IO ())
-> Maybe ByteString
-> Application
-> IO ()
runGeneric [(String, String)]
vars Int -> IO (IO ByteString)
inputH ByteString -> IO ()
outputH Maybe ByteString
xsendfile Application
app = do
    let rmethod :: ByteString
rmethod = String -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> String
lookup' String
"REQUEST_METHOD" [(String, String)]
vars
        pinfo :: String
pinfo = String -> [(String, String)] -> String
lookup' String
"PATH_INFO" [(String, String)]
vars
        qstring :: String
qstring = String -> [(String, String)] -> String
lookup' String
"QUERY_STRING" [(String, String)]
vars
        contentLength :: Int
contentLength = forall a. Read a => a -> String -> a
safeRead Int
0 forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> String
lookup' String
"CONTENT_LENGTH" [(String, String)]
vars
        remoteHost' :: String
remoteHost' =
            case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"REMOTE_ADDR" [(String, String)]
vars of
                Just String
x -> String
x
                Maybe String
Nothing ->
                    forall a. a -> Maybe a -> a
fromMaybe String
"" forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"REMOTE_HOST" [(String, String)]
vars
        isSecure' :: Bool
isSecure' =
            case forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> String
lookup' String
"SERVER_PROTOCOL" [(String, String)]
vars of
                String
"https" -> Bool
True
                String
_ -> Bool
False
    [AddrInfo]
addrs <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just String
remoteHost') forall a. Maybe a
Nothing
    IO ByteString
requestBody' <- Int -> IO (IO ByteString)
inputH Int
contentLength
    let addr :: SockAddr
addr =
            case [AddrInfo]
addrs of
                AddrInfo
a:[AddrInfo]
_ -> AddrInfo -> SockAddr
addrAddress AddrInfo
a
                [] -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Invalid REMOTE_ADDR or REMOTE_HOST: " forall a. [a] -> [a] -> [a]
++ String
remoteHost'
        reqHeaders :: [(CI ByteString, ByteString)]
reqHeaders = forall a b. (a -> b) -> [a] -> [b]
map (String -> CI ByteString
cleanupVarName forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> ByteString
B.pack) [(String, String)]
vars
        env :: Request
env = Request
            { requestMethod :: ByteString
requestMethod = ByteString
rmethod
            , rawPathInfo :: ByteString
rawPathInfo = String -> ByteString
B.pack String
pinfo
            , pathInfo :: [Text]
pathInfo = ByteString -> [Text]
H.decodePathSegments forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack String
pinfo
            , rawQueryString :: ByteString
rawQueryString = String -> ByteString
B.pack String
qstring
            , queryString :: Query
queryString = ByteString -> Query
H.parseQuery forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack String
qstring
            , requestHeaders :: [(CI ByteString, ByteString)]
requestHeaders = [(CI ByteString, ByteString)]
reqHeaders
            , isSecure :: Bool
isSecure = Bool
isSecure'
            , remoteHost :: SockAddr
remoteHost = SockAddr
addr
            , httpVersion :: HttpVersion
httpVersion = HttpVersion
H.http11 -- FIXME
            , requestBody :: IO ByteString
requestBody = IO ByteString
requestBody'
            , vault :: Vault
vault = forall a. Monoid a => a
mempty
            , requestBodyLength :: RequestBodyLength
requestBodyLength = Word64 -> RequestBodyLength
KnownLength forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
contentLength
            , requestHeaderHost :: Maybe ByteString
requestHeaderHost = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"host" [(CI ByteString, ByteString)]
reqHeaders
            , requestHeaderRange :: Maybe ByteString
requestHeaderRange = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
hRange [(CI ByteString, ByteString)]
reqHeaders
#if MIN_VERSION_wai(3,2,0)
            , requestHeaderReferer :: Maybe ByteString
requestHeaderReferer = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"referer" [(CI ByteString, ByteString)]
reqHeaders
            , requestHeaderUserAgent :: Maybe ByteString
requestHeaderUserAgent = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"user-agent" [(CI ByteString, ByteString)]
reqHeaders
#endif
            }
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Application
app Request
env forall a b. (a -> b) -> a -> b
$ \Response
res ->
        case (Maybe ByteString
xsendfile, Response
res) of
            (Just ByteString
sf, ResponseFile Status
s [(CI ByteString, ByteString)]
hs String
fp Maybe FilePart
Nothing) -> do
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> IO ()
outputH forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString forall a b. (a -> b) -> a -> b
$ Status
-> [(CI ByteString, ByteString)] -> ByteString -> String -> Builder
sfBuilder Status
s [(CI ByteString, ByteString)]
hs ByteString
sf String
fp
                forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
ResponseReceived
            (Maybe ByteString, Response)
_ -> do
                let (Status
s, [(CI ByteString, ByteString)]
hs, (StreamingBody -> IO a) -> IO a
wb) = forall a.
Response
-> (Status, [(CI ByteString, ByteString)],
    (StreamingBody -> IO a) -> IO a)
responseToStream Response
res
                (BuilderRecv
blazeRecv, BuilderFinish
blazeFinish) <- BufferAllocStrategy -> IO (BuilderRecv, BuilderFinish)
Builder.newBuilderRecv BufferAllocStrategy
Builder.defaultStrategy
                forall {a}. (StreamingBody -> IO a) -> IO a
wb forall a b. (a -> b) -> a -> b
$ \StreamingBody
b -> do
                    let sendBuilder :: Builder -> IO ()
sendBuilder Builder
builder = do
                            IO ByteString
popper <- BuilderRecv
blazeRecv Builder
builder
                            forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
                                ByteString
bs <- IO ByteString
popper
                                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
bs) forall a b. (a -> b) -> a -> b
$ do
                                    ByteString -> IO ()
outputH ByteString
bs
                                    IO ()
loop
                    Builder -> IO ()
sendBuilder forall a b. (a -> b) -> a -> b
$ Status -> [(CI ByteString, ByteString)] -> Builder
headers Status
s [(CI ByteString, ByteString)]
hs forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char7 Char
'\n'
                    StreamingBody
b Builder -> IO ()
sendBuilder (Builder -> IO ()
sendBuilder Builder
flush)
                BuilderFinish
blazeFinish forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) ByteString -> IO ()
outputH
                forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
ResponseReceived
  where
    headers :: Status -> [(CI ByteString, ByteString)] -> Builder
headers Status
s [(CI ByteString, ByteString)]
hs = forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (Builder, Builder) -> Builder
header forall a b. (a -> b) -> a -> b
$ Status -> (Builder, Builder)
status Status
s forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (CI ByteString, ByteString) -> (Builder, Builder)
header' (forall {b}.
IsString b =>
[(CI ByteString, b)] -> [(CI ByteString, b)]
fixHeaders [(CI ByteString, ByteString)]
hs))
    status :: Status -> (Builder, Builder)
status (Status Int
i ByteString
m) = (ByteString -> Builder
byteString ByteString
"Status", forall a. Monoid a => [a] -> a
mconcat
        [ String -> Builder
string8 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
i
        , Char -> Builder
char7 Char
' '
        , ByteString -> Builder
byteString ByteString
m
        ])
    header' :: (CI ByteString, ByteString) -> (Builder, Builder)
header' (CI ByteString
x, ByteString
y) = (ByteString -> Builder
byteString forall a b. (a -> b) -> a -> b
$ forall s. CI s -> s
CI.original CI ByteString
x, ByteString -> Builder
byteString ByteString
y)
    header :: (Builder, Builder) -> Builder
header (Builder
x, Builder
y) = forall a. Monoid a => [a] -> a
mconcat
        [ Builder
x
        , ByteString -> Builder
byteString ByteString
": "
        , Builder
y
        , Char -> Builder
char7 Char
'\n'
        ]
    sfBuilder :: Status
-> [(CI ByteString, ByteString)] -> ByteString -> String -> Builder
sfBuilder Status
s [(CI ByteString, ByteString)]
hs ByteString
sf String
fp = forall a. Monoid a => [a] -> a
mconcat
        [ Status -> [(CI ByteString, ByteString)] -> Builder
headers Status
s [(CI ByteString, ByteString)]
hs
        , (Builder, Builder) -> Builder
header (ByteString -> Builder
byteString ByteString
sf, String -> Builder
string8 String
fp)
        , Char -> Builder
char7 Char
'\n'
        , ByteString -> Builder
byteString ByteString
sf
        , ByteString -> Builder
byteString ByteString
" not supported"
        ]
    fixHeaders :: [(CI ByteString, b)] -> [(CI ByteString, b)]
fixHeaders [(CI ByteString, b)]
h =
        case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
hContentType [(CI ByteString, b)]
h of
            Maybe b
Nothing -> (CI ByteString
hContentType, b
"text/html; charset=utf-8") forall a. a -> [a] -> [a]
: [(CI ByteString, b)]
h
            Just b
_ -> [(CI ByteString, b)]
h

cleanupVarName :: String -> CI.CI B.ByteString
cleanupVarName :: String -> CI ByteString
cleanupVarName String
"CONTENT_TYPE" = CI ByteString
hContentType
cleanupVarName String
"CONTENT_LENGTH" = CI ByteString
hContentLength
cleanupVarName String
"SCRIPT_NAME" = CI ByteString
"CGI-Script-Name"
cleanupVarName String
s =
    case String
s of
        Char
'H':Char
'T':Char
'T':Char
'P':Char
'_':Char
a:String
as -> forall a. IsString a => String -> a
String.fromString forall a b. (a -> b) -> a -> b
$ Char
a forall a. a -> [a] -> [a]
: String -> String
helper' String
as
        String
_ -> forall a. IsString a => String -> a
String.fromString String
s -- FIXME remove?
  where
    helper' :: String -> String
helper' (Char
'_':Char
x:String
rest) = Char
'-' forall a. a -> [a] -> [a]
: Char
x forall a. a -> [a] -> [a]
: String -> String
helper' String
rest
    helper' (Char
x:String
rest) = Char -> Char
toLower Char
x forall a. a -> [a] -> [a]
: String -> String
helper' String
rest
    helper' [] = []

requestBodyHandle :: Handle -> Int -> IO (IO B.ByteString)
requestBodyHandle :: Handle -> Int -> IO (IO ByteString)
requestBodyHandle Handle
h = (Int -> BuilderFinish) -> Int -> IO (IO ByteString)
requestBodyFunc forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    ByteString
bs <- Handle -> Int -> IO ByteString
B.hGet Handle
h Int
i
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if ByteString -> Bool
B.null ByteString
bs then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just ByteString
bs

requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> IO (IO B.ByteString)
requestBodyFunc :: (Int -> BuilderFinish) -> Int -> IO (IO ByteString)
requestBodyFunc Int -> BuilderFinish
get Int
count0 = do
    IORef Int
ref <- forall a. a -> IO (IORef a)
newIORef Int
count0
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
        Int
count <- forall a. IORef a -> IO a
readIORef IORef Int
ref
        if Int
count forall a. Ord a => a -> a -> Bool
<= Int
0
            then forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
            else do
                Maybe ByteString
mbs <- Int -> BuilderFinish
get forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min Int
count Int
defaultChunkSize
                forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ref forall a b. (a -> b) -> a -> b
$ Int
count forall a. Num a => a -> a -> a
- forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 ByteString -> Int
B.length Maybe ByteString
mbs
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe ByteString
B.empty Maybe ByteString
mbs