{-# 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

import Control.Arrow ((***))
import Control.Monad (unless, void)
import Data.ByteString.Builder (byteString, string8, toLazyByteString, word8)
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)
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (mconcat, mempty, mappend)
#endif
import qualified Data.Streaming.ByteString.Builder as Builder
import qualified Data.String as String
import Data.Word8 (_lf, _space)
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 = ((ByteString, ByteString) -> (String, String))
-> [(ByteString, ByteString)] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> String
B.unpack (ByteString -> String)
-> (ByteString -> String)
-> (ByteString, ByteString)
-> (String, String)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> String
B.unpack) ([(ByteString, ByteString)] -> [(String, String)])
-> IO [(ByteString, ByteString)] -> IO [(String, String)]
forall a b. (a -> b) -> IO a -> IO b
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 ReadS a
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 = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
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 Maybe ByteString
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 (ByteString -> Maybe ByteString
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 (String -> ByteString) -> String -> ByteString
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 = Int -> String -> Int
forall a. Read a => a -> String -> a
safeRead Int
0 (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> String
lookup' String
"CONTENT_LENGTH" [(String, String)]
vars
        remoteHost' :: String
remoteHost' =
            case String -> [(String, String)] -> Maybe String
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 -> String -> [(String, String)] -> String
lookup' String
"REMOTE_HOST" [(String, String)]
vars
        isSecure' :: Bool
isSecure' =
            case (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> String -> String
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]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo -> Maybe String -> Maybe String -> IO (t AddrInfo)
getAddrInfo Maybe AddrInfo
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
remoteHost') Maybe String
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
                [] -> String -> SockAddr
forall a. HasCallStack => String -> a
error (String -> SockAddr) -> String -> SockAddr
forall a b. (a -> b) -> a -> b
$ String
"Invalid REMOTE_ADDR or REMOTE_HOST: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
remoteHost'
        reqHeaders :: [(CI ByteString, ByteString)]
reqHeaders = ((String, String) -> (CI ByteString, ByteString))
-> [(String, String)] -> [(CI ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> CI ByteString
cleanupVarName (String -> CI ByteString)
-> (String -> ByteString)
-> (String, String)
-> (CI ByteString, ByteString)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
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 =
            IO ByteString -> Request -> Request
setRequestBodyChunks IO ByteString
requestBody' (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$
                Request
defaultRequest
                    { requestMethod = rmethod
                    , rawPathInfo = B.pack pinfo
                    , pathInfo = H.decodePathSegments $ B.pack pinfo
                    , rawQueryString = B.pack qstring
                    , queryString = H.parseQuery $ B.pack qstring
                    , requestHeaders = reqHeaders
                    , isSecure = isSecure'
                    , remoteHost = addr
                    , httpVersion = H.http11 -- FIXME
                    , vault = mempty
                    , requestBodyLength = KnownLength $ fromIntegral contentLength
                    , requestHeaderHost = lookup "host" reqHeaders
                    , requestHeaderRange = lookup hRange reqHeaders
#if MIN_VERSION_wai(3,2,0)
                    , requestHeaderReferer = lookup "referer" reqHeaders
                    , requestHeaderUserAgent = lookup "user-agent" reqHeaders
#endif
                    }
    IO ResponseReceived -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ResponseReceived -> IO ()) -> IO ResponseReceived -> IO ()
forall a b. (a -> b) -> a -> b
$ Application
app Request
env ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
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
                (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> IO ()
outputH ([ByteString] -> IO ()) -> [ByteString] -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
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
                ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
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) = Response
-> (Status, [(CI ByteString, ByteString)],
    (StreamingBody -> IO a) -> IO a)
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
                (StreamingBody -> IO ()) -> IO ()
forall {a}. (StreamingBody -> IO a) -> IO a
wb ((StreamingBody -> IO ()) -> IO ())
-> (StreamingBody -> IO ()) -> IO ()
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
                            (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
                                ByteString
bs <- IO ByteString
popper
                                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                                    ByteString -> IO ()
outputH ByteString
bs
                                    IO ()
loop
                    Builder -> IO ()
sendBuilder (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ Status -> [(CI ByteString, ByteString)] -> Builder
headers Status
s [(CI ByteString, ByteString)]
hs Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
word8 Word8
_lf
                    StreamingBody
b Builder -> IO ()
sendBuilder (Builder -> IO ()
sendBuilder Builder
flush)
                BuilderFinish
blazeFinish BuilderFinish -> (Maybe ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (ByteString -> IO ()) -> Maybe ByteString -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ByteString -> IO ()
outputH
                ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
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 = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (((Builder, Builder) -> Builder)
-> [(Builder, Builder)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Builder, Builder) -> Builder
header ([(Builder, Builder)] -> [Builder])
-> [(Builder, Builder)] -> [Builder]
forall a b. (a -> b) -> a -> b
$ Status -> (Builder, Builder)
status Status
s (Builder, Builder) -> [(Builder, Builder)] -> [(Builder, Builder)]
forall a. a -> [a] -> [a]
: ((CI ByteString, ByteString) -> (Builder, Builder))
-> [(CI ByteString, ByteString)] -> [(Builder, Builder)]
forall a b. (a -> b) -> [a] -> [b]
map (CI ByteString, ByteString) -> (Builder, Builder)
header' ([(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
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"
        , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
            [ String -> Builder
string8 (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i
            , Word8 -> Builder
word8 Word8
_space
            , ByteString -> Builder
byteString ByteString
m
            ]
        )
    header' :: (CI ByteString, ByteString) -> (Builder, Builder)
header' (CI ByteString
x, ByteString
y) = (ByteString -> Builder
byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
x, ByteString -> Builder
byteString ByteString
y)
    header :: (Builder, Builder) -> Builder
header (Builder
x, Builder
y) =
        [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
            [ Builder
x
            , ByteString -> Builder
byteString ByteString
": "
            , Builder
y
            , Word8 -> Builder
word8 Word8
_lf
            ]
    sfBuilder :: Status
-> [(CI ByteString, ByteString)] -> ByteString -> String -> Builder
sfBuilder Status
s [(CI ByteString, ByteString)]
hs ByteString
sf String
fp =
        [Builder] -> Builder
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)
            , Word8 -> Builder
word8 Word8
_lf
            , ByteString -> Builder
byteString ByteString
sf
            , ByteString -> Builder
byteString ByteString
" not supported"
            ]
    fixHeaders :: [(CI ByteString, b)] -> [(CI ByteString, b)]
fixHeaders [(CI ByteString, b)]
h =
        case CI ByteString -> [(CI ByteString, b)] -> Maybe b
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") (CI ByteString, b) -> [(CI ByteString, b)] -> [(CI ByteString, b)]
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 -> String -> CI ByteString
forall a. IsString a => String -> a
String.fromString (String -> CI ByteString) -> String -> CI ByteString
forall a b. (a -> b) -> a -> b
$ Char
a Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
helper' String
as
        String
_ -> String -> CI ByteString
forall a. IsString a => String -> a
String.fromString String
s -- FIXME remove?
  where
    helper' :: String -> String
helper' (Char
'_' : Char
x : String
rest) = Char
'-' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
helper' String
rest
    helper' (Char
x : String
rest) = Char -> Char
toLower Char
x Char -> String -> String
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 ((Int -> BuilderFinish) -> Int -> IO (IO ByteString))
-> (Int -> BuilderFinish) -> Int -> IO (IO ByteString)
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    ByteString
bs <- Handle -> Int -> IO ByteString
B.hGet Handle
h Int
i
    Maybe ByteString -> BuilderFinish
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> BuilderFinish)
-> Maybe ByteString -> BuilderFinish
forall a b. (a -> b) -> a -> b
$ if ByteString -> Bool
B.null ByteString
bs then Maybe ByteString
forall a. Maybe a
Nothing else ByteString -> Maybe ByteString
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 <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
count0
    IO ByteString -> IO (IO ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO ByteString -> IO (IO ByteString))
-> IO ByteString -> IO (IO ByteString)
forall a b. (a -> b) -> a -> b
$ do
        Int
count <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref
        if Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
            then ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
            else do
                Maybe ByteString
mbs <- Int -> BuilderFinish
get (Int -> BuilderFinish) -> Int -> BuilderFinish
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
count Int
defaultChunkSize
                IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ref (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> (ByteString -> Int) -> Maybe ByteString -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 ByteString -> Int
B.length Maybe ByteString
mbs
                ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
B.empty Maybe ByteString
mbs