hack-handler-evhttp (empty) → 2009.7.29
raw patch · 5 files changed
+285/−0 lines, 5 filesdep +basedep +bytestringdep +bytestring-classsetup-changed
Dependencies added: base, bytestring, bytestring-class, containers, data-default, hack, hack-contrib, network
Files
- Hack/Handler/EvHTTP.hsc +237/−0
- LICENSE +2/−0
- Setup.hs +6/−0
- examples/Basic.hs +19/−0
- hack-handler-evhttp.cabal +21/−0
+ Hack/Handler/EvHTTP.hsc view
@@ -0,0 +1,237 @@+{-# 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+
+ LICENSE view
@@ -0,0 +1,2 @@+GPL V3 or later+
+ Setup.hs view
@@ -0,0 +1,6 @@+#!/usr/bin/env runhaskell++import Distribution.Simple++main = defaultMain+
+ examples/Basic.hs view
@@ -0,0 +1,19 @@++module Main where++import Data.Default+import Data.ByteString.Class+import Hack+import Hack.Handler.EvHTTP++main :: IO ()+main = do+ print "hi"+ run $ \_ -> do+ return $ def {+ status = 200,+ body = toLazyByteString "<html><body><h1>Basic</h1></body></html>",+ headers = [("Content-Type", "text/html")]+ }+ return ()+
+ hack-handler-evhttp.cabal view
@@ -0,0 +1,21 @@+Name: hack-handler-evhttp+Version: 2009.7.29+Build-type: Simple+Synopsis: Hack EvHTTP (libevent) Handler+Description: Hack EvHTTP (libevent) Handler+License: GPL+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+data-files: examples/Basic.hs++library+ ghc-options: -Wall+ build-depends: base >= 3 && < 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