{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

module Factis.Haskoon.Web
    (Web,WebRes,WebIO,RqAccess(..),FromRq(..),ToWebRes(..), WebWebRes
    ,webDocumentRoot,webContainerUri,webRequestUri,webPathInfo,webMethod
    ,webGetBody,webGetParams,webGetHeaders,webGetCookies,webSetStatus
    ,webSendBSL,webFail,webSetHeader,webUnsetCookie,webGetRepls
    ,webWithRepls,webRunFromRq,webLog,webSendError,webGetHeader
    ,webGetParam,webRepl,webOk,webNotFound,webFileNotFound,webBadRequest
    ,webSendString,webGetCookie,webRedirect,webWithData,webCheckData
    ,webSendFile, webSetCookie, notEmpty, optional
    ,webLogNotice,webLogTrace,webLogDebug
    ,Cookie(..), newCookie, findCookie, deleteCookie, showCookie, readCookies
) where

----------------------------------------
-- STDLIB
----------------------------------------
import Control.Monad (MonadPlus(mplus), liftM)
import Control.Monad.Trans (MonadIO,liftIO)

import Data.Char (toLower)
import Data.Maybe (listToMaybe, catMaybes)
import Data.List (find, isSuffixOf)

import System.FilePath.Posix ((</>))
import System.Directory (doesFileExist)

----------------------------------------
-- SITE-PACKAGES
----------------------------------------
import System.Log.Logger (getRootLogger, saveGlobalLogger, setLevel, addHandler
                         ,Priority(..), noticeM)
import System.Log.Handler.Syslog (openlog,Facility(..))

import qualified Data.ByteString.Lazy.UTF8 as BSLU
import qualified Data.ByteString.Lazy as BSL

import Network.URI (URI)
import Network.CGI.Cookie (Cookie(..), newCookie, findCookie, deleteCookie
                          ,showCookie, readCookies)

class Monad m => Web m where
    type WebRes m
    -- general
    webDocumentRoot :: m FilePath
    webContainerUri :: m URI
    -- request
    webRequestUri :: m URI
    webPathInfo :: m String
    webMethod :: m String
    webGetBody :: m BSL.ByteString
    webGetParams :: m [(String,String)]
    webGetHeaders :: m [(String,String)]
    webGetCookies :: m [(String,String)]
    -- response
    webSetStatus :: Int -> Maybe String -> m ()
    webSendBSL :: BSL.ByteString -> m (WebRes m)
    webSetHeader :: String -> String -> m ()
    webFail :: String -> m a
    webSetCookie :: Cookie -> m ()
    webUnsetCookie :: Cookie -> m ()
    -- request processing
    webGetRepls :: m [String]
    webWithRepls :: [String] -> m a -> m a
    webRunFromRq :: FromRq a => m (Either String a)
    webLog :: String -> Priority -> String -> m ()
    -- default methods that may be overridden
    webSendError :: Int -> String -> m (WebRes m)
    webSendError status msg =
        do webSetStatus status Nothing
           webSetHeader "Content-Type" "text/plain; charset=UTF-8"
           webSendBSL (BSLU.fromString msg)
    webGetHeader :: String -> m (Maybe String)
    webGetHeader n = liftM lookup  webGetHeaders
        where lookup = fmap snd . find ((==map toLower n) . map toLower . fst)
    webGetParam :: String -> m (Maybe String)
    webGetParam n = liftM (lookup n) webGetParams

type WebWebRes m = m (WebRes m)

webRepl :: Web m => Int -> m String
webRepl i = liftM (!! i) webGetRepls

webOk :: (Web m, ToWebRes a) => a -> m (WebRes m)
webOk = toWebRes

webNotFound name = webSendError 404 ("Not found: " ++ name)
webFileNotFound fpath = webSendError 404 ("File not found: " ++ fpath)
webBadRequest msg = webSendError 401 ("Bad Request: " ++ msg)

webSendString :: Web m => String -> m (WebRes m)
webSendString str = webOk str

webGetCookie :: Web m => String -> m (Maybe String)
webGetCookie n = liftM (lookup n) webGetCookies

webRedirect :: Web m => Bool -> String -> m (WebRes m)
webRedirect temp url =
    do webSetHeader "Location" url
       webSetHeader "Content-Type" "text/plain; charset=UTF-8"
       webSetStatus (if temp then 302 else 301) Nothing
       webSendBSL (BSLU.fromString $ "Redirecting to "++url++".")

_LOGNAME_ = "Web"
webLogNotice = webLog _LOGNAME_ NOTICE
webLogDebug = webLog _LOGNAME_ INFO
webLogTrace = webLog _LOGNAME_ DEBUG

class (MonadIO m, Web m) => WebIO m

class MonadPlus m => RqAccess m where
    param :: String -> m String
    header :: String -> m String
    repl :: Int -> m String
    cookie :: String -> m String
    checkMethod :: (String -> Bool) -> m String

class FromRq a where
    fromRq :: RqAccess m => m a

notEmpty :: Monad m => m String -> m String
notEmpty m =  m >>= \x -> if x == "" then fail "empty string" else return x

optional :: MonadPlus m => m a -> m (Maybe a)
optional action = liftM Just action `mplus` return Nothing

webWithData :: (Web m, FromRq a) => (a -> m (WebRes m)) -> m (WebRes m)
webWithData cont = webCheckData cont webBadRequest

webCheckData :: (Web m, FromRq a) =>
                (a -> m (WebRes m))           -- continuation with request data
             -> (String -> m (WebRes m))      -- continuation without data
             -> m (WebRes m)
webCheckData withData withErr =
    do aOrErr <- webRunFromRq
       case aOrErr of
         Right a -> withData a
         Left err -> withErr err

class ToWebRes a where
    toWebContentType :: a -> String
    toWebBody :: a -> BSL.ByteString
    toWebRes :: Web m => a -> m (WebRes m)
    toWebRes a =
        do webSetHeader "Content-Type" (toWebContentType a)
           webSendBSL (toWebBody a)

instance ToWebRes String where
    toWebContentType _ = "text/plain"
    toWebBody str = BSLU.fromString str


webSendFile :: WebIO m => FilePath -> m (WebRes m)
webSendFile fpath =
    do docroot <- webDocumentRoot
       let abspath = docroot </> fpath
       exists <- liftIO (doesFileExist abspath)
       case exists of
         True -> do contents <- liftIO (BSL.readFile abspath)
                    webSetHeader "Content-Type" ctype
                    webSendBSL contents
         False -> webFileNotFound fpath
    where ctype | ".html" `isSuffixOf` fpath = "text/html"
                | ".css" `isSuffixOf` fpath = "text/css"
                | ".js" `isSuffixOf` fpath = "application/x-javascript"
                | ".png" `isSuffixOf` fpath = "image/png"
                | otherwise = "text/plain"