hack-handler-evhttp 2009.7.29 → 2009.8.2
raw patch · 4 files changed
+113/−62 lines, 4 filesdep ~basesetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Hack.Handler.EvHTTP: instance Show Time
+ Hack.Handler.EvHTTP: instance Storable Event
+ Hack.Handler.EvHTTP: instance Storable Time
Files
- Hack/Handler/EvHTTP.hsc +111/−54
- Setup.hs +0/−4
- examples/Basic.hs +0/−1
- hack-handler-evhttp.cabal +2/−3
Hack/Handler/EvHTTP.hsc view
@@ -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- ++
Setup.hs view
@@ -1,6 +1,2 @@-#!/usr/bin/env runhaskell- import Distribution.Simple- main = defaultMain-
examples/Basic.hs view
@@ -8,7 +8,6 @@ main :: IO () main = do- print "hi" run $ \_ -> do return $ def { status = 200,
hack-handler-evhttp.cabal view
@@ -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 <bickfordb@gmail.com> Maintainer: Bickford, Brandon <bickfordb@gmail.com>-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