module Hack.Handler.Epoll (
run,
runWithConfig,
ServerConf(..)
) where
import Control.Applicative
import Control.Concurrent
import Control.Exception (Exception, bracket, finally)
import Control.Failure
import Control.Monad
import Data.Default
import Data.List
import Data.Maybe
import Data.Typeable (Typeable)
import Hack
import Network.HTTP (RequestData, parseRequestHead)
import Network.HTTP.Headers
import Network.Socket
import Network.Stream (ConnError)
import Network.URI
import System.IO
import System.Linux.Epoll
import System.Posix.Signals
import System.Posix.Types
import qualified Data.ByteString.Lazy.UTF8 as B
import qualified Data.Map as M
import Codec.Binary.UTF8.String
data ServerConf = ServerConf
{ host :: String
, port :: Int
, backlog :: Int
, epollSize :: Int
} deriving Show
instance Default ServerConf where
def = ServerConf "127.0.0.1" 8000 256 8192
data BodyLen = Chunked | Len Int | Unknown deriving (Eq, Show)
deriving instance Typeable ConnError
instance Exception ConnError
run :: Application -> IO ()
run = runWithConfig def
runWithConfig :: ServerConf -> Application -> IO ()
runWithConfig conf app =
bracket (createRuntime (fromJust . toSize . epollSize $ conf))
shutdownRuntime $ \epoll -> do
ai <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]}))
(Just . host $ conf)
(Just . show . port $ conf)
let serverAddr = head ai
server <- socket (addrFamily serverAddr) Stream defaultProtocol
setSocketOption server ReuseAddr 1
bindSocket server (addrAddress serverAddr)
listen server (backlog conf)
installHandler sigPIPE Ignore Nothing
forever $ do
(sock, remoteAddr) <- accept server
process conf epoll app sock remoteAddr
process :: ServerConf -> Runtime -> Application -> Socket -> SockAddr -> IO ThreadId
process c r app s ra = forkIO $ ensure (sClose s) $ do
let fd = Fd . fdSocket $ s
env <- parseEnv c r fd ra
app env >>= writeResponse r fd
where
ensure = flip finally
parseEnv :: ServerConf -> Runtime -> Fd -> SockAddr -> IO Env
parseEnv c r fd ra = withIBuffer r fd $ \b -> do
(hd, bd) <- headBody <$> readBuffer b
header <- try $ parseRequestHead . breakLines $ hd
headerToEnv c header bd ra
headerToEnv :: ServerConf -> RequestData -> String -> SockAddr -> IO Env
headerToEnv conf (meth, uri, header) bdy remote = do
(mrhost, _) <- getNameInfo [NI_NOFQDN] True False remote
let rhost = mrhost ||| ""
host' = lookupHeader HdrHost header ||| host conf
body' = readBody bodyLen bdy
return Env
{ requestMethod = read . show $ meth
, scriptName = ""
, pathInfo = uriPath uri
, queryString = uriQuery uri
, serverName = host'
, serverPort = port conf
, http = map (\(Header h v) -> (show h, v)) header
, hackVersion = [2009, 10, 30]
, hackUrlScheme = HTTP
, hackInput = B.fromString body'
, hackErrors = hPutStr stderr
, hackHeaders = []
, hackCache = []
, remoteHost = rhost
}
where
infixr 2 |||
(|||) = flip fromMaybe
bodyLen = transferEnc ||| contentLen ||| Unknown
contentLen = (Len . abs . read) <$>
lookupHeader HdrContentLength header
transferEnc = (choose Chunked Unknown . (/= "identity")) <$>
lookupHeader HdrTransferEncoding header
writeResponse :: Runtime -> Fd -> Response -> IO ()
writeResponse r fd resp = withOBuffer r fd $ \b -> do
let st = status resp
sm = M.findWithDefault "" st statusCode
sl = showString "HTTP/1.1 " . shows st . showString " " . showString sm $ "\r\n"
hd = map (\(k, v) -> (k ++ (": " ++ v))) $ headers resp
writeBuffer b $ showString sl
. showString (concat . intersperse "\r\n" $ hd)
. showString "\r\n\r\n" $ encodeString . B.toString . body $ resp
readBody :: BodyLen -> String -> String
readBody Unknown _ = ""
readBody (Len n) b = take n b
readBody Chunked b = concat $ readChunks [] b
where
readChunks chs [] = reverse chs
readChunks chs st =
let (hd, tl) = line st
n = read $ "0x" ++ takeWhile (/= ';') hd
in
readChunks (take n tl:chs)
(dropWhile (isIn "\r\n") . drop n $ tl)
headBody :: String -> (String, String)
headBody = go []
where
go hd [] = (reverse hd, [])
go hd ('\r':'\n':'\r':'\n':bd) = (reverse hd, bd)
go hd (x:xs) = go (x:hd) xs
breakLines :: String -> [String]
breakLines str = pre : case rest of
'\r':'\n':suf -> breakLines suf
'\r':suf -> breakLines suf
'\n':suf -> breakLines suf
_ -> []
where
(pre, rest) = break (isIn "\r\n") str
line :: String -> (String, String)
line s = let (hd, tl) = break (isIn "\r\n") s
in (hd, dropWhile (isIn "\r\n") tl)
isIn :: (Eq a) => [a] -> a -> Bool
isIn = flip elem
choose :: a -> a -> Bool -> a
choose x _ True = x
choose _ y False = y
statusCode :: M.Map Int String
statusCode = M.fromAscList
[ (100, "Continue")
, (101, "Switching Protocols")
, (200, "OK")
, (201, "Created")
, (202, "Accepted")
, (203, "Non-Authoritative Information")
, (204, "No Content")
, (205, "Reset Content")
, (206, "Partial Content")
, (300, "Multiple Choices")
, (301, "Moved Permanently")
, (302, "Found")
, (303, "See Other")
, (304, "Not Modified")
, (305, "Use Proxy")
, (307, "Temporary Redirect")
, (400, "Bad Request")
, (401, "Unauthorized")
, (402, "Payment Required")
, (403, "Forbidden")
, (404, "Not Found")
, (405, "Method Not Allowed")
, (406, "Not Acceptable")
, (407, "Proxy Authentication Required")
, (408, "Request Time-out")
, (409, "Conflict")
, (410, "Gone")
, (411, "Length Required")
, (412, "Precondition Failed")
, (413, "Request Entity Too Large")
, (414, "Request-URI Too Large")
, (415, "Unsupported Media Type")
, (416, "Requested range not satisfiable")
, (417, "Expectation Failed")
, (500, "Internal Server Error")
, (501, "Not Implemented")
, (502, "Bad Gateway")
, (503, "Service Unavailable")
, (504, "Gateway Time-out")
, (505, "HTTP Version not supported")
]