{-# 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(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(..))
import Network.CGI as CGI
import Network.URI (parseRelativeReference)
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.WebHelper

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 :: ReaderT WebData (ErrorT String m) a -> WebCGI m a
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)
    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 $
        do let varname = "REDIRECT_REQUEST_URI"
           mreq <- liftM (>>= parseRelativeReference) $ getVar varname
           case mreq of
             Just req -> return req
             Nothing ->
                 do reqUri <- CGI.requestURI
                    return reqUri
    webContainerUri = liftCGI CGI.progURI
    webGetCookies = liftCGI (liftM parseVar (CGI.getVar "HTTP_COOKIE"))
        where parseVar = readCookies . fromMaybe ""
    webSetCookie aCookie = liftCGI (CGI.setCookie aCookie)
    webUnsetCookie aCookie = liftCGI (CGI.deleteCookie aCookie)
    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
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


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