{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
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 :: 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
runSendfile
:: B.ByteString
-> 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
runGeneric
:: [(String, String)]
-> (Int -> IO (IO B.ByteString))
-> (B.ByteString -> IO ())
-> Maybe B.ByteString
-> 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
, 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
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