{-# LINE 1 "Hack/Handler/EvHTTP.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, CPP #-}
{-# LINE 2 "Hack/Handler/EvHTTP.hsc" #-}
-- 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


{-# LINE 29 "Hack/Handler/EvHTTP.hsc" #-}

{-# LINE 30 "Hack/Handler/EvHTTP.hsc" #-}

{-# LINE 31 "Hack/Handler/EvHTTP.hsc" #-}

-- 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

httpGET  :: HTTPCmd
httpGET  =  0
httpPOST  :: HTTPCmd
httpPOST  =  1
httpHEAD  :: HTTPCmd
httpHEAD  =  2

{-# LINE 84 "Hack/Handler/EvHTTP.hsc" #-}

type ReqPtr = Ptr Req
type Req = ()

reqURI :: ReqPtr -> IO String
reqURI ptr = ((\hsc_ptr -> peekByteOff hsc_ptr 40)) ptr >>= peekCString
{-# LINE 90 "Hack/Handler/EvHTTP.hsc" #-}

reqHeaders :: ReqPtr -> IO [(String, String)]
reqHeaders reqP = do  
    headersPtr <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) reqP
{-# LINE 94 "Hack/Handler/EvHTTP.hsc" #-}
    firstPtr <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) headersPtr
{-# LINE 95 "Hack/Handler/EvHTTP.hsc" #-}
    headers' firstPtr
    where
        headers' h 
            | h == nullPtr = return []
            | otherwise = do
                key <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) h >>= peekCString
{-# LINE 101 "Hack/Handler/EvHTTP.hsc" #-}
                val <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) h >>= peekCString
{-# LINE 102 "Hack/Handler/EvHTTP.hsc" #-}
                next <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) h
{-# LINE 103 "Hack/Handler/EvHTTP.hsc" #-}
                rest <- headers' next
                return $ (key, val) : rest


{-# LINE 107 "Hack/Handler/EvHTTP.hsc" #-}

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 $ ((((\hsc_ptr -> peekByteOff hsc_ptr 36)) reqP) :: IO HTTPCmd)
{-# LINE 190 "Hack/Handler/EvHTTP.hsc" #-}
        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 <- (((\hsc_ptr -> peekByteOff hsc_ptr 56)) reqP :: IO BufPtr)
{-# LINE 214 "Hack/Handler/EvHTTP.hsc" #-}
    bufP <- (((\hsc_ptr -> peekByteOff hsc_ptr 0)) inputBufferP :: IO CString)
{-# LINE 215 "Hack/Handler/EvHTTP.hsc" #-}
    off <- fmap fromIntegral $ (((\hsc_ptr -> peekByteOff hsc_ptr 16)) inputBufferP :: IO CSize)
{-# LINE 216 "Hack/Handler/EvHTTP.hsc" #-}
    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 <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) reqP
{-# LINE 224 "Hack/Handler/EvHTTP.hsc" #-}
                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