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
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 _ = ((72))
alignment _ = alignment (undefined :: CInt)
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 "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
type EventHandler = (CInt -> CShort -> Ptr () -> IO ())
type USecs = CInt
type Secs = CInt
data Time = Time Secs USecs deriving (Show)
instance Storable Time where
sizeOf _ = ((8))
alignment _ = 4
peek ptr = do
s <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr
u <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr
return $ Time s u
poke ptr (Time s u) = do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr s
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr u
type HTTPCmd = CShort
httpGET :: HTTPCmd
httpGET = 0
httpPOST :: HTTPCmd
httpPOST = 1
httpHEAD :: HTTPCmd
httpHEAD = 2
type ReqPtr = Ptr Req
type Req = ()
reqURI :: ReqPtr -> IO String
reqURI ptr = ((\hsc_ptr -> peekByteOff hsc_ptr 40)) ptr >>= peekCString
reqHeaders :: ReqPtr -> IO [(String, String)]
reqHeaders reqP = do
headersPtr <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) reqP
firstPtr <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) headersPtr
headers' firstPtr
where
headers' h
| h == nullPtr = return []
| otherwise = do
key <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) h >>= peekCString
val <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) h >>= peekCString
next <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) h
rest <- headers' next
return $ (key, val) : rest
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 :: Application -> IO ()
run app = runWithConfig def app
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
requestEventProcessor chan reqP _ = do
env <- extractEnv reqP
writeChan chan (reqP, env)
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
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 $ ((((\hsc_ptr -> peekByteOff hsc_ptr 36)) 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
extractBody :: ReqPtr -> IO ByteString
extractBody reqP = do
inputBufferP <- (((\hsc_ptr -> peekByteOff hsc_ptr 56)) reqP :: IO BufPtr)
bufP <- (((\hsc_ptr -> peekByteOff hsc_ptr 0)) inputBufferP :: IO CString)
off <- fmap fromIntegral $ (((\hsc_ptr -> peekByteOff hsc_ptr 16)) inputBufferP :: IO CSize)
fmap toLazyByteString $ BS.packCStringLen (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 <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) 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