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


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

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

{-# LINE 33 "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

data Event = Event
type EventPtr = Ptr Event

instance Storable Event where
    sizeOf _ = ((72))
{-# LINE 57 "Hack/Handler/EvHTTP.hsc" #-}
    alignment _ = alignment (undefined :: CInt)

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

--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 _ = ((8))
{-# LINE 107 "Hack/Handler/EvHTTP.hsc" #-}
    alignment _ = 4
{-# LINE 108 "Hack/Handler/EvHTTP.hsc" #-}
    peek ptr = do
        s <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr
{-# LINE 110 "Hack/Handler/EvHTTP.hsc" #-}
        u <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr
{-# LINE 111 "Hack/Handler/EvHTTP.hsc" #-}
        return $ Time s u
    poke ptr (Time s u) = do
        ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr s
{-# LINE 114 "Hack/Handler/EvHTTP.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr u
{-# LINE 115 "Hack/Handler/EvHTTP.hsc" #-}

type HTTPCmd = CShort

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

{-# LINE 123 "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 129 "Hack/Handler/EvHTTP.hsc" #-}

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


{-# LINE 146 "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 10

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

        -- 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
        requestEventProcessor chan reqP _ = do
            env <- extractEnv reqP
            writeChan chan (reqP, env)

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

        -- 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 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)
{-# LINE 245 "Hack/Handler/EvHTTP.hsc" #-}
        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

-- 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 271 "Hack/Handler/EvHTTP.hsc" #-}
    bufP <- (((\hsc_ptr -> peekByteOff hsc_ptr 0)) inputBufferP :: IO CString)
{-# LINE 272 "Hack/Handler/EvHTTP.hsc" #-}
    off <- fmap fromIntegral $ (((\hsc_ptr -> peekByteOff hsc_ptr 16)) inputBufferP :: IO CSize)
{-# LINE 273 "Hack/Handler/EvHTTP.hsc" #-}
    fmap toLazyByteString $ BS.packCStringLen (bufP, off)

-- Start sending the response
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 282 "Hack/Handler/EvHTTP.hsc" #-}
                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