{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, CPP #-}
-- Binding to the libevent http library
--
module Hack.Handler.EvHTTP (run,
eventVersion,
eventMethod,
Config(..),
runWithConfig
) where
import Control.Concurrent (forkOS, forkIO, yield)
import Control.Concurrent.Chan
import Control.Monad
import Data.ByteString.Class
import Data.ByteString.Lazy (ByteString)
import Data.Char (toLower)
import Data.Default (def, Default)
import Data.Map (lookup)
import Data.Maybe (fromMaybe, listToMaybe)
import Foreign
import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr
import Hack
import Hack.Contrib.Constants
#include <event.h>
#include <evhttp.h>
#include <evdns.h>
-- Base types
type Base = ()
type BasePtr = Ptr Base
foreign import ccall threadsafe "event_base_new" baseNew :: IO BasePtr
foreign import ccall threadsafe "event_base_free" baseFree :: BasePtr -> IO ()
foreign import ccall threadsafe "event_base_loop"
baseLoop :: BasePtr -> CInt -> IO CInt
foreign import ccall threadsafe "event_get_version"
eventVersion' :: IO CString
foreign import ccall threadsafe "event_base_get_method"
baseMethod :: BasePtr -> IO CString
-- Get the libevent method we're using such as "epoll" or "kqueue" or "select"
eventMethod :: IO String
eventMethod = do
baseP <- baseNew
s <- baseMethod baseP >>= peekCString
baseFree baseP
return s
eventVersion :: IO String
eventVersion = eventVersion' >>= peekCString
foreign import ccall threadsafe "evhttp_new" httpNew :: BasePtr -> IO HTTPPtr
foreign import ccall threadsafe "evhttp_bind_socket" bindSocket :: HTTPPtr -> CString -> CShort -> IO CInt
foreign import ccall threadsafe "evhttp_free" httpFree :: HTTPPtr -> IO ()
foreign import ccall threadsafe "evhttp_set_gencb" httpSetGen :: HTTPPtr -> FunPtr (Gen a) -> Ptr a -> IO ()
foreign import ccall threadsafe "evhttp_send_reply" sendReply :: ReqPtr -> CInt -> CString -> BufPtr -> IO ()
foreign import ccall "wrapper" wrapGen :: Gen a -> IO (FunPtr (Gen a))
foreign import ccall threadsafe "evbuffer_new" bufNew :: IO BufPtr
foreign import ccall threadsafe "evbuffer_free" bufFree :: BufPtr -> IO ()
foreign import ccall threadsafe "evbuffer_add" bufAdd :: BufPtr -> CString -> CSize -> IO CInt
foreign import ccall threadsafe "evhttp_add_header" addHeader :: Ptr KeyValQ -> CString -> CString -> IO CInt
type HTTPCmd = CShort
#{enum HTTPCmd, ,
httpGET = EVHTTP_REQ_GET,
httpPOST = EVHTTP_REQ_POST,
httpHEAD = EVHTTP_REQ_HEAD
}
type ReqPtr = Ptr Req
type Req = ()
reqURI :: ReqPtr -> IO String
reqURI ptr = (#peek struct evhttp_request, uri) ptr >>= peekCString
reqHeaders :: ReqPtr -> IO [(String, String)]
reqHeaders reqP = do
headersPtr <- (#peek struct evhttp_request, input_headers) reqP
firstPtr <- (#peek struct evkeyvalq, tqh_first) headersPtr
headers' firstPtr
where
headers' h
| h == nullPtr = return []
| otherwise = do
key <- (#peek struct evkeyval, key) h >>= peekCString
val <- (#peek struct evkeyval, value) h >>= peekCString
next <- (#peek struct evkeyval, next) h
rest <- headers' next
return $ (key, val) : rest
#def struct evkeyvalq { struct evkeyval *tqh_first; struct evkeyval **tqh_last; };
type KeyValQ = ()
type Gen a = (ReqPtr -> Ptr a -> IO ())
type HTTPPtr = Ptr ()
type BufPtr = Ptr ()
data Config = Config {
cfgAddr :: String,
cfgPort :: Int,
cfgWorkers :: Int
}
instance Default Config where
def = Config "0.0.0.0" 8080 25
-- Run a Hack application inside evhttp
run :: Application -> IO ()
run app = runWithConfig def app
-- Run a Hack application inside evhttp
runWithConfig :: Config -> Application -> IO ()
runWithConfig config app = do
workChan <- newChan
resultChan <- newChan
basePtr <- baseNew
httpPtr <- httpNew basePtr
let port = fromIntegral . cfgPort $ config
replicateM_ (cfgWorkers config) $ forkIO $ process workChan resultChan
withCString (cfgAddr config) $ \addrPtr -> bindSocket httpPtr addrPtr port
genPtr <- wrapGen (recv workChan)
httpSetGen httpPtr genPtr nullPtr
forkOS $ socketLoop basePtr resultChan
forever $ yield
freeHaskellFunPtr genPtr
httpFree httpPtr
baseFree basePtr
where
-- Request callback function: for each request that comes in, the evhttp machinery
-- will callback to this function. At this point all of the post data
-- appears to already been read
recv oChan reqP _ = do
env <- extractEnv reqP
writeChan oChan (reqP, env)
socketLoop basePtr resultChan = forever $ do
baseLoop basePtr 2
socketLoop' basePtr resultChan
socketLoop' basePtr resultChan = do
isEmpty <- isEmptyChan resultChan
if isEmpty
then return ()
else do
(reqP, resp) <- readChan resultChan
sendResponse reqP resp
socketLoop' basePtr resultChan
process iChan oChan = forever $ do
(reqP, env) <- readChan iChan
response <- app env
writeChan oChan (reqP, response)
extractEnv reqP = do
uri <- reqURI reqP
theHeaders <- reqHeaders reqP
theBody <- extractBody reqP
method <- extractRequestMethod reqP
return $ def {
scriptName="",
pathInfo="",
requestMethod=method,
http=theHeaders,
hackInput=theBody,
hackUrlScheme=HTTP,
queryString=qs uri,
serverName=fst $ getServerName theHeaders,
serverPort=snd $ getServerName theHeaders
}
extractRequestMethod reqP = do
fmap toRequestMethod $ (((#peek struct evhttp_request, type) reqP) :: IO HTTPCmd)
qs uri = takeWhile ('#' /=) $ tail $ dropWhile ('?' /=) uri
getServerName [] = (cfgAddr config, cfgPort config)
getServerName ((h, v) : xs) = if (map toLower h) == "host" then parseHost v else getServerName xs
where parseHost s = (host s, port s)
host s = takeWhile (':' /=) s
port :: String -> Int
port s = case (maybeRead $ tail $ dropWhile (':' /=) s) of
Just p -> p
Nothing -> cfgPort config
maybeRead :: Read a => String -> Maybe a
maybeRead = fmap fst . listToMaybe . reads
toRequestMethod :: CShort -> RequestMethod
toRequestMethod x
| x == httpGET = GET
| x == httpPOST = POST
| x == httpHEAD = HEAD
| otherwise = GET
-- Extract the input buffer from the request body and marshall it to a Lazy ByteString
extractBody :: ReqPtr -> IO ByteString
extractBody reqP = do
inputBufferP <- ((#peek struct evhttp_request, input_buffer) reqP :: IO BufPtr)
bufP <- ((#peek struct evbuffer, buffer) inputBufferP :: IO CString)
off <- fmap fromIntegral $ ((#peek struct evbuffer, off) inputBufferP :: IO CSize)
fmap toLazyByteString $ peekCStringLen (bufP, off)
sendResponse :: ReqPtr -> Response -> IO ()
sendResponse reqP response = do
forM_ (headers response) $ \(key, val) -> do
withCString key $ \k' -> do
withCString val $ \v' -> do
outHeadersP <- (#peek struct evhttp_request, output_headers) reqP
addHeader outHeadersP k' v'
let body' = (fromLazyByteString $ body response)
withCString body' $ \bodyBytes -> do
buf <- bufNew
bufAdd buf bodyBytes $ fromIntegral . length $ body'
let msg = statusMessage $ status response
let code = fromIntegral $ status response
withCString msg $ \msg' -> do
sendReply reqP code msg' buf
bufFree buf
statusMessage :: Int -> String
statusMessage code = fromMaybe "" $ Data.Map.lookup code Hack.Contrib.Constants.status_code