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