{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, CPP #-}
-- Binding to the libevent http library
--
module Hack.Handler.EvHTTP (run,
eventVersion,
eventMethod,
Config(..),
runWithConfig
) where
import Control.Concurrent
import Control.Concurrent.Chan
import qualified Data.ByteString as BS
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 Control.Concurrent.MVar
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
data Event = Event
type EventPtr = Ptr Event
instance Storable Event where
sizeOf _ = (#size struct event)
alignment _ = alignment (undefined :: CInt)
-- 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
--foreign import ccall threadsafe "event_base_once" once :: BasePtr -> CInt -> CShort -> FunPtr EventHandler -> Ptr () -> Ptr Time -> IO CInt
foreign import ccall "wrapper" wrapEventHandler :: EventHandler -> IO (FunPtr EventHandler)
foreign import ccall threadsafe "event_set" eventSet :: EventPtr -> CInt -> CShort -> FunPtr EventHandler -> Ptr () -> IO ()
foreign import ccall threadsafe "event_add" eventAdd :: EventPtr -> Ptr Time -> IO CInt
foreign import ccall threadsafe "event_base_set" baseSet :: BasePtr -> EventPtr -> IO CInt
--foreign import ccall threadsafe "read" c_read :: CInt -> Ptr () -> CSize -> IO CSize
--foreign import ccall threadsafe "write" c_write :: CInt -> Ptr () -> CSize -> IO CSize
type EventHandler = (CInt -> CShort -> Ptr () -> IO ())
type USecs = CInt
type Secs = CInt
data Time = Time Secs USecs deriving (Show)
instance Storable Time where
sizeOf _ = (#size struct timeval)
alignment _ = #{const __alignof__(struct timeval)}
peek ptr = do
s <- (#peek struct timeval, tv_sec) ptr
u <- (#peek struct timeval, tv_usec) ptr
return $ Time s u
poke ptr (Time s u) = do
(#poke struct timeval, tv_sec) ptr s
(#poke struct timeval, tv_usec) ptr u
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 10
-- 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
done <- newEmptyMVar
requestChan <- newChan
responseChan <- newChan
basePtr <- baseNew
httpPtr <- httpNew basePtr
eventPtr <- malloc
timePtr <- malloc
responseProcessorPtr <- wrapEventHandler $ responseProcessor basePtr responseChan eventPtr timePtr
eventSet eventPtr (-1) 0 responseProcessorPtr nullPtr
baseSet basePtr eventPtr
eventAdd eventPtr timePtr
forkOS $ do
replicateM_ (cfgWorkers config) $ forkIO $ requestProcessor requestChan responseChan
readMVar done
withCString (cfgAddr config) $ \addrPtr -> bindSocket httpPtr addrPtr port'
requestEventProcessorPtr <- wrapGen $ requestEventProcessor requestChan
httpSetGen httpPtr requestEventProcessorPtr nullPtr
baseLoop basePtr 0
freeHaskellFunPtr requestEventProcessorPtr
freeHaskellFunPtr responseProcessorPtr
free eventPtr
free timePtr
httpFree httpPtr
baseFree basePtr
where
port' = fromIntegral . cfgPort $ config
-- 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
requestEventProcessor chan reqP _ = do
env <- extractEnv reqP
writeChan chan (reqP, env)
-- Process responses in the evhttp channel by polling responseChan.
-- This would be more efficient if this were converted to a pipe or
-- some sort of unixy thing libevent could watch instead of a timer.
responseProcessor :: BasePtr -> Chan (ReqPtr, Response) -> Ptr Event -> Ptr Time -> CInt -> CShort -> Ptr () -> IO ()
responseProcessor basePtr responseChan evtP timeP fd what ctx = do
empty <- isEmptyChan responseChan
if empty
then do
eventAdd evtP timeP
return ()
else do
(reqP, resp) <- readChan responseChan
sendResponse reqP resp
responseProcessor basePtr responseChan evtP timeP fd what ctx
-- Process requests in worker thread
requestProcessor :: Chan (ReqPtr, Env) -> Chan (ReqPtr, Response) -> IO ()
requestProcessor requestChan responseChan = forever $ do
(reqP, env) <- readChan requestChan
response <- app env
writeChan responseChan (reqP, response)
extractEnv reqP = do
uri <- reqURI reqP
theHeaders <- reqHeaders reqP
theBody <- extractBody reqP
method <- extractRequestMethod reqP
return $ def {
scriptName="",
pathInfo=takeWhile ('?' /=) $ takeWhile ('#' /=) uri,
requestMethod=method,
http=theHeaders,
hackInput=theBody,
hackUrlScheme=HTTP,
queryString=takeWhile ('#' /=) $ safe_tail $ dropWhile ('?' /=) uri,
serverName=fst $ getServerName theHeaders,
serverPort=snd $ getServerName theHeaders
}
extractRequestMethod reqP = do
fmap toRequestMethod $ (((#peek struct evhttp_request, type) reqP) :: IO HTTPCmd)
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
safe_tail [] = []
safe_tail xs = tail xs
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 $ BS.packCStringLen (bufP, off)
-- Start sending the response
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' = toStrictByteString $ body response
let bodyLength = fromIntegral $ BS.length body'
BS.useAsCString (toStrictByteString $ body response) $ \bodyBytes -> do
buf <- bufNew
bufAdd buf bodyBytes bodyLength
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