diff --git a/Hack/Handler/EvHTTP.hsc b/Hack/Handler/EvHTTP.hsc --- a/Hack/Handler/EvHTTP.hsc +++ b/Hack/Handler/EvHTTP.hsc @@ -2,13 +2,13 @@ -- Binding to the libevent http library -- module Hack.Handler.EvHTTP (run, - eventVersion, - eventMethod, + eventVersion, + eventMethod, Config(..), runWithConfig ) where -import Control.Concurrent (forkOS, forkIO, yield) +import Control.Concurrent import Control.Concurrent.Chan import Control.Monad @@ -18,6 +18,7 @@ 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 @@ -41,15 +42,22 @@ foreign import ccall threadsafe "event_base_loop" baseLoop :: BasePtr -> CInt -> IO CInt -foreign import ccall threadsafe "event_get_version" +foreign import ccall threadsafe "event_get_version" eventVersion' :: IO CString -foreign import ccall threadsafe "event_base_get_method" +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 +eventMethod = do baseP <- baseNew s <- baseMethod baseP >>= peekCString baseFree baseP @@ -74,6 +82,36 @@ 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, , @@ -89,12 +127,12 @@ reqURI ptr = (#peek struct evhttp_request, uri) ptr >>= peekCString reqHeaders :: ReqPtr -> IO [(String, String)] -reqHeaders reqP = do +reqHeaders reqP = do headersPtr <- (#peek struct evhttp_request, input_headers) reqP firstPtr <- (#peek struct evkeyvalq, tqh_first) headersPtr headers' firstPtr where - headers' h + headers' h | h == nullPtr = return [] | otherwise = do key <- (#peek struct evkeyval, key) h >>= peekCString @@ -111,7 +149,7 @@ type HTTPPtr = Ptr () type BufPtr = Ptr () - + data Config = Config { cfgAddr :: String, cfgPort :: Int, @@ -119,89 +157,107 @@ } instance Default Config where - def = Config "0.0.0.0" 8080 25 + def = Config "0.0.0.0" 8080 10 -- Run a Hack application inside evhttp run :: Application -> IO () -run app = runWithConfig def app +run app = runWithConfig def app -- Run a Hack application inside evhttp runWithConfig :: Config -> Application -> IO () runWithConfig config app = do - workChan <- newChan - resultChan <- newChan + done <- newEmptyMVar + requestChan <- newChan + responseChan <- 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 + 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 - -- Request callback function: for each request that comes in, the evhttp machinery + 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 - recv oChan reqP _ = do + requestEventProcessor chan reqP _ = do env <- extractEnv reqP - writeChan oChan (reqP, env) + writeChan chan (reqP, env) - socketLoop basePtr resultChan = forever $ do - baseLoop basePtr 2 - socketLoop' basePtr resultChan + -- 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 - 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 + -- 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 oChan (reqP, response) + writeChan responseChan (reqP, response) extractEnv reqP = do uri <- reqURI reqP - theHeaders <- reqHeaders reqP + theHeaders <- reqHeaders reqP theBody <- extractBody reqP - method <- extractRequestMethod reqP - return $ def { + method <- extractRequestMethod reqP + return $ def { scriptName="", - pathInfo="", + pathInfo=takeWhile ('?' /=) $ takeWhile ('#' /=) uri, requestMethod=method, http=theHeaders, hackInput=theBody, hackUrlScheme=HTTP, - queryString=qs uri, + 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) - 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 + 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 +toRequestMethod x | x == httpGET = GET | x == httpPOST = POST | x == httpHEAD = HEAD @@ -209,29 +265,30 @@ -- Extract the input buffer from the request body and marshall it to a Lazy ByteString extractBody :: ReqPtr -> IO ByteString -extractBody reqP = do +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 +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 + 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 + sendReply reqP code msg' buf + bufFree buf statusMessage :: Int -> String statusMessage code = fromMaybe "" $ Data.Map.lookup code Hack.Contrib.Constants.status_code - + + diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,2 @@ -#!/usr/bin/env runhaskell - import Distribution.Simple - main = defaultMain - diff --git a/examples/Basic.hs b/examples/Basic.hs --- a/examples/Basic.hs +++ b/examples/Basic.hs @@ -8,7 +8,6 @@ main :: IO () main = do - print "hi" run $ \_ -> do return $ def { status = 200, diff --git a/hack-handler-evhttp.cabal b/hack-handler-evhttp.cabal --- a/hack-handler-evhttp.cabal +++ b/hack-handler-evhttp.cabal @@ -1,5 +1,5 @@ Name: hack-handler-evhttp -Version: 2009.7.29 +Version: 2009.8.2 Build-type: Simple Synopsis: Hack EvHTTP (libevent) Handler Description: Hack EvHTTP (libevent) Handler @@ -7,7 +7,6 @@ License-file: LICENSE Author: Bickford, Brandon Maintainer: Bickford, Brandon -Build-Depends: base Cabal-version: >= 1.2 category: Web homepage: http://github.com/bickfordb/hack-handler-evhttp @@ -15,7 +14,7 @@ library ghc-options: -Wall - build-depends: base >= 3 && < 5, bytestring, bytestring-class, containers, network, data-default >= 0.2, hack >= 2009.5.19, hack-contrib + build-depends: base >= 4 && < 5, bytestring, bytestring-class, containers, network, data-default >= 0.2, hack >= 2009.5.19, hack-contrib exposed-modules: Hack.Handler.EvHTTP extra-libraries: event extensions: ForeignFunctionInterface