{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
module Factis.Haskoon.WebCGI (WebCGI, runFastCgi, runFastWebCGI
                             ,runWebCGI, runWebCGIResult) where

----------------------------------------
-- STDLIB
----------------------------------------
import Control.Arrow (first)
import Control.Concurrent (forkIO)
import Control.Monad (MonadPlus, liftM, mplus)
import Control.Monad.Trans (MonadTrans(lift))
import Control.Monad.Reader (MonadReader(ask,local),ReaderT(runReaderT),asks)
import Control.Monad.Error (ErrorT(..), throwError)

import Data.Char (toLower)
import Data.Maybe (fromMaybe, maybeToList)
import Data.List (isPrefixOf)

----------------------------------------
-- SITE-PACKAGES
----------------------------------------
import Network.CGI.Monad (MonadCGI(..), CGIT)
import Network.CGI.Cookie (readCookies)
import Network.CGI as CGI
import Network.FastCGI (runFastCGIConcurrent')

import System.Log.Logger (getRootLogger, saveGlobalLogger, setLevel, addHandler
                         ,Priority(..), logM)
import System.Log.Handler.Syslog (openlog,Facility(..))

import Control.Monad.Maybe (MaybeT(..))

import qualified Data.ByteString.Lazy.Char8 as BSLChar

----------------------------------------
-- LOCAL
----------------------------------------
import Factis.Haskoon.Web
import Factis.Haskoon.WebRqAccessM

data WebData = WebData { webd_repls :: [String] }

webd_repls_set :: [String] -> WebData -> WebData
webd_repls_set r wd = wd { webd_repls = r }

newtype WebCGI m a = WebCGI { unWebCGI :: ReaderT WebData (ErrorT String m) a}
    deriving (Monad, MonadIO)

inWebCGI x = WebCGI x

liftCGI :: (MonadIO m, MonadCGI m) =>
           (forall m. (MonadIO m, MonadCGI m) => m a)
        -> WebCGI m a
liftCGI cgi = inWebCGI (lift (lift cgi))

instance (MonadIO m, MonadCGI m) => Web (WebCGI m) where
    type WebRes (WebCGI m) = CGI.CGIResult
    webPathInfo = liftCGI CGI.pathInfo
    webSendBSL bs = liftCGI (CGI.outputFPS bs)
    webSendError code msg =
        liftCGI $
        do vars <- CGI.getVars
           let details = map (\(x,y) -> x ++ ": " ++ y) vars
           CGI.outputError code msg details
    webLog name prio msg = liftIO (logM name prio msg)
    webSetHeader name value = liftCGI (CGI.setHeader name value)
    webGetBody =
        liftCGI $
        do mctype <- CGI.requestContentType
           let ctype = parseContentType (fromMaybe "text/plain" mctype)
           case ctype of
             Just (ContentType "application" "x-www-form-urlencoded" _) ->
                 do inputs <- CGI.getInputs
                    let body = CGI.formEncode inputs
                    return (BSLChar.pack body)
             Just (ContentType "multipart" "form-data" ps) -> fail msg
             _ -> CGI.getBodyFPS
        where
          msg = "Content-Type multipart/form-data not supported by WebCGI."
    webGetParams = liftCGI CGI.getInputs
    webGetHeaders =
        liftCGI $
        do vars <- liftM (filter (\(k,_) -> "HTTP_" `isPrefixOf` k)) CGI.getVars
           mctype <- CGI.requestContentType
           let varToHdr = first $ map toLower . replaceCh '_' '-' . drop 5
               hs = maybeToList (fmap ((,) "content-type") mctype)
                    ++ map varToHdr vars
           return hs
    webGetRepls =  inWebCGI (asks webd_repls)
    webWithRepls r (WebCGI cont) = inWebCGI (local (webd_repls_set r) cont)
    webRunFromRq =
        do meth <- webMethod
           headers <- webGetHeaders
           repls <- webGetRepls
           params <- webGetParams
           cookies <- webGetCookies
           let rqdata = RqData meth params headers repls cookies
           return (runRqAccessM fromRq rqdata)
    webFail msg = inWebCGI (throwError msg)
    webDocumentRoot =
        do mdocroot <- liftCGI (CGI.getVar "DOCUMENT_ROOT")
           case mdocroot of
             Nothing -> webFail "CGI variable `DOCUMENT_ROOT' not set."
             Just value -> return value
    webRequestUri = liftCGI CGI.requestURI
    webContainerUri = liftCGI CGI.progURI
    webGetCookies = liftCGI (liftM parseVar (CGI.getVar "HTTP_COOKIE"))
        where parseVar = readCookies . fromMaybe ""
    webSetCookie cookie = liftCGI (CGI.setCookie cookie)
    webUnsetCookie cookie = liftCGI (CGI.deleteCookie cookie)
    webMethod = liftCGI CGI.requestMethod
    webSetStatus code mmsg = liftCGI (CGI.setStatus code $ fromMaybe "n/a" msg)
        where msg = mmsg `mplus` lookup code statusCodeMessageMap

instance MonadCGI m => MonadCGI (MaybeT m) where
    cgiAddHeader n v = lift (cgiAddHeader n v)
    cgiGet f = lift (cgiGet f)

instance (MonadCGI m, MonadIO m) => WebIO (WebCGI m)

initialWebData = WebData []

runWebCGI :: (MonadCGI m, MonadIO m) => WebCGI m a -> m (Either String a)
runWebCGI webCGI =
    let readerT = unWebCGI webCGI
        errorT = runReaderT readerT initialWebData
        base = runErrorT errorT
    in base

runWebCGIResult :: (MonadIO m, MonadCGI m) =>
                   WebCGI m (WebRes (WebCGI m))
                -> m CGIResult
runWebCGIResult webCGI =
    let cgiResOrErr = runWebCGI webCGI
        cgi = do result <- cgiResOrErr
                 case result of
                   Left msg -> CGI.outputError 500 msg [""]
                   Right res -> return res
    in cgi

runFastWebCGI :: String -> WebWebRes (WebCGI (CGIT IO)) -> IO ()
runFastWebCGI name webCGI = runFastCgi name (runWebCGIResult webCGI)

runFastCgi :: String -> CGIT IO CGIResult -> IO ()
runFastCgi name cgi =
    do logger <- getRootLogger
       syslog <- openlog name [] USER DEBUG
       saveGlobalLogger (addHandler syslog (setLevel DEBUG logger))
       logM name NOTICE (name ++ " FastCGI process started.")
       runFastCGIConcurrent' forkIO 10 cgi

statusCodeMessageMap :: [(Int, String)]
statusCodeMessageMap =
    [(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")
    ]

replaceCh :: Char -> Char -> String -> String
replaceCh from to s = map replChar s
    where replChar ch | ch == from = to
                      | otherwise = ch