module Hack.Handler.Epoll (
run,
runWithConfig,
ServerConf(..)
) where
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
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) <- readBuffer b >>= return . headBody
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 |||
(|||) m d = maybe d id m
bodyLen = transferEnc ||| contentLen ||| Unknown
contentLen = do
cl <- lookupHeader HdrContentLength header
return . Len . abs . read $ cl
transferEnc = do
tc <- lookupHeader HdrTransferEncoding header
if tc /= "identity" then return Chunked else return Unknown
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" $ 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
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")
]