{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans                   #-}

-- |
-- Module      : Hack.Handler.Epoll
-- Copyright   : (c) 2010 Toralf Wittner
-- License     : LGPL
-- Maintainer  : toralf.wittner@gmail.com
-- Stability   : experimental
-- Portability : non-portable
--
-- Implements Hack Handler interface using System.Linux.Epoll.

module Hack.Handler.Epoll (
    run,
    runWithConfig,
    ServerConf(..)
) where

import Control.Applicative
import Control.Concurrent
import Control.Exception (Exception, bracket, finally)
import Control.Failure
import Control.Monad
import Data.Default
import Data.List
import Data.Maybe
import Data.Typeable (Typeable)
import Hack
import Network.HTTP (RequestData, parseRequestHead)
import Network.HTTP.Headers
import Network.Socket
import Network.Stream (ConnError)
import Network.URI
import System.IO
import System.Linux.Epoll
import System.Posix.Signals
import System.Posix.Types
import qualified Data.ByteString.Lazy.UTF8 as B
import qualified Data.Map as M
import Codec.Binary.UTF8.String


data ServerConf = ServerConf
    { host      :: String
    , port      :: Int
    , backlog   :: Int
    , epollSize :: Int
    } deriving Show

instance Default ServerConf where
    def = ServerConf "127.0.0.1" 8000 256 8192


data BodyLen = Chunked | Len Int | Unknown deriving (Eq, Show)


deriving instance Typeable ConnError
instance Exception ConnError


run :: Application -> IO ()
run = runWithConfig def


runWithConfig :: ServerConf -> Application -> IO ()
runWithConfig conf app =
    bracket (createRuntime (fromJust . toSize . epollSize $ conf))
            shutdownRuntime $ \epoll -> do

        ai <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]}))
                          (Just . host $ conf)
                          (Just . show . port $ conf)

        let serverAddr = head ai
        server <- socket (addrFamily serverAddr) Stream defaultProtocol

        setSocketOption server ReuseAddr 1
        bindSocket server (addrAddress serverAddr)
        listen server (backlog conf)

        installHandler sigPIPE Ignore Nothing

        forever $ do
            (sock, remoteAddr) <- accept server
            process conf epoll app sock remoteAddr


process :: ServerConf -> Runtime -> Application -> Socket -> SockAddr -> IO ThreadId
process c r app s ra = forkIO $ ensure (sClose s) $ do
    let fd = Fd . fdSocket $ s
    env <- parseEnv c r fd ra
    app env >>= writeResponse r fd
 where
    ensure = flip finally


parseEnv :: ServerConf -> Runtime -> Fd -> SockAddr -> IO Env
parseEnv c r fd ra = withIBuffer r fd $ \b -> do
    (hd, bd) <- headBody <$> readBuffer b
    header   <- try $ parseRequestHead . breakLines $ hd
    headerToEnv c header bd ra


headerToEnv :: ServerConf -> RequestData -> String -> SockAddr -> IO Env
headerToEnv conf (meth, uri, header) bdy remote = do
    (mrhost, _) <- getNameInfo [NI_NOFQDN] True False remote
    let rhost = mrhost ||| ""
        host' = lookupHeader HdrHost header ||| host conf
        body' = readBody bodyLen bdy
    return Env
        { requestMethod = read . show $ meth
        , scriptName = ""
        , pathInfo = uriPath uri
        , queryString = uriQuery uri
        , serverName = host'
        , serverPort = port conf
        , http = map (\(Header h v) -> (show h, v)) header
        , hackVersion = [2009, 10, 30]
        , hackUrlScheme = HTTP
        , hackInput = B.fromString body'
        , hackErrors = hPutStr stderr
        , hackHeaders = []
        , hackCache = []
        , remoteHost = rhost
        }
 where
    infixr 2 |||
    (|||) = flip fromMaybe

    bodyLen = transferEnc ||| contentLen ||| Unknown

    contentLen = (Len . abs . read) <$>
        lookupHeader HdrContentLength header

    transferEnc = (choose Chunked Unknown . (/= "identity")) <$>
        lookupHeader HdrTransferEncoding header


writeResponse :: Runtime -> Fd -> Response -> IO ()
writeResponse r fd resp = withOBuffer r fd $ \b -> do
    let st = status resp
        sm = M.findWithDefault "" st statusCode
        sl = showString "HTTP/1.1 " . shows st . showString " " . showString sm $ "\r\n"
        hd = map (\(k, v) -> (k ++ (": " ++ v))) $ headers resp
    writeBuffer b $ showString sl
        . showString (concat . intersperse "\r\n" $ hd)
        . showString "\r\n\r\n" $ encodeString . B.toString . body $ resp


readBody :: BodyLen -> String -> String
readBody Unknown _ = ""
readBody (Len n) b = take n b
readBody Chunked b = concat $ readChunks [] b
 where
    readChunks chs [] = reverse chs
    readChunks chs st =
        let (hd, tl) = line st
            n        = read $ "0x" ++ takeWhile (/= ';') hd
        in
            readChunks (take n tl:chs)
                       (dropWhile (isIn "\r\n") . drop n $ tl)


headBody :: String -> (String, String)
headBody = go []
 where
    go hd []                       = (reverse hd, [])
    go hd ('\r':'\n':'\r':'\n':bd) = (reverse hd, bd)
    go hd (x:xs)                   = go (x:hd) xs


breakLines :: String -> [String]
breakLines str = pre : case rest of
    '\r':'\n':suf -> breakLines suf
    '\r':suf      -> breakLines suf
    '\n':suf      -> breakLines suf
    _             -> []
 where
    (pre, rest) = break (isIn "\r\n") str


line :: String -> (String, String)
line s = let (hd, tl) = break (isIn "\r\n") s
         in  (hd, dropWhile (isIn "\r\n") tl)


isIn :: (Eq a) => [a] -> a -> Bool
isIn = flip elem

choose :: a -> a -> Bool -> a
choose x _ True  = x
choose _ y False = y

statusCode :: M.Map Int String
statusCode = M.fromAscList
    [ (100, "Continue")
    , (101, "Switching Protocols")
    , (200, "OK")
    , (201, "Created")
    , (202, "Accepted")
    , (203, "Non-Authoritative Information")
    , (204, "No Content")
    , (205, "Reset Content")
    , (206, "Partial Content")
    , (300, "Multiple Choices")
    , (301, "Moved Permanently")
    , (302, "Found")
    , (303, "See Other")
    , (304, "Not Modified")
    , (305, "Use Proxy")
    , (307, "Temporary Redirect")
    , (400, "Bad Request")
    , (401, "Unauthorized")
    , (402, "Payment Required")
    , (403, "Forbidden")
    , (404, "Not Found")
    , (405, "Method Not Allowed")
    , (406, "Not Acceptable")
    , (407, "Proxy Authentication Required")
    , (408, "Request Time-out")
    , (409, "Conflict")
    , (410, "Gone")
    , (411, "Length Required")
    , (412, "Precondition Failed")
    , (413, "Request Entity Too Large")
    , (414, "Request-URI Too Large")
    , (415, "Unsupported Media Type")
    , (416, "Requested range not satisfiable")
    , (417, "Expectation Failed")
    , (500, "Internal Server Error")
    , (501, "Not Implemented")
    , (502, "Bad Gateway")
    , (503, "Service Unavailable")
    , (504, "Gateway Time-out")
    , (505, "HTTP Version not supported")
    ]