{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, CPP #-}
-- 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

#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

data Event = Event
type EventPtr = Ptr Event

instance Storable Event where
    sizeOf _ = (#size struct event)
    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 _ = (#size struct timeval)
    alignment _ = #{const __alignof__(struct timeval)}
    peek ptr = do
        s <- (#peek struct timeval, tv_sec) ptr
        u <- (#peek struct timeval, tv_usec) ptr
        return $ Time s u
    poke ptr (Time s u) = do
        (#poke struct timeval, tv_sec) ptr s
        (#poke struct timeval, tv_usec) ptr u

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 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 $ (((#peek struct evhttp_request, type) 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

-- 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 $ 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 <- (#peek struct evhttp_request, output_headers) 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