    {-# 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
        vars <- IO [(String, String)]
    getEnvironment
        let input = Handle -> Int -> IO (IO ByteString)
    requestBodyHandle Handle
    System.IO.stdin
            output = Handle -> ByteString -> IO ()
    B.hPut Handle
    System.IO.stdout
        runGeneric vars input output Nothing 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
        vars <- IO [(String, String)]
    getEnvironment
        let input = Handle -> Int -> IO (IO ByteString)
    requestBodyHandle Handle
    System.IO.stdin
            output = Handle -> ByteString -> IO ()
    B.hPut Handle
    System.IO.stdout
        runGeneric vars input output (Just sf) 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
        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
        requestBody' <- inputH contentLength
        let 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 = ((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 =
                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
                        }
        void $ app env $ \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
    $ LazyByteString -> [ByteString]
    L.toChunks (LazyByteString -> [ByteString]) -> LazyByteString -> [ByteString]
    forall a b. (a -> b) -> a -> b
    $ Builder -> LazyByteString
    toLazyByteString (Builder -> LazyByteString) -> Builder -> LazyByteString
    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
                    (blazeRecv, blazeFinish) <- BufferAllocStrategy -> IO (BuilderRecv, BuilderFinish)
    Builder.newBuilderRecv BufferAllocStrategy
    Builder.defaultStrategy
                    wb $ \StreamingBody
    b -> do
                        let sendBuilder :: Builder -> IO ()
    sendBuilder Builder
    builder = do
                                popper <- BuilderRecv
    blazeRecv Builder
    builder
                                fix $ \IO ()
    loop -> do
                                    bs <- IO ByteString
    popper
                                    unless (B.null bs) $ do
                                        outputH bs
                                        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)
                    blazeFinish >>= maybe (return ()) outputH
                    return 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
        bs <- Handle -> Int -> IO ByteString
    B.hGet Handle
    h Int
    i
        return $ if B.null bs then Nothing else Just 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
        ref <- Int -> IO (IORef Int)
    forall a. a -> IO (IORef a)
    newIORef Int
    count0
        return $ do
            count <- readIORef ref
            if count <= 0
                then return B.empty
                else do
                    mbs <- get $ min count defaultChunkSize
                    writeIORef ref $ count - maybe 0 B.length mbs
                    return $ fromMaybe B.empty mbs