{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeFamilies, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
{-# LANGUAGE PackageImports #-}
module Factis.Haskoon.WebSalvia (WebSalvia, salviaMain) where

----------------------------------------
-- STDLIB
----------------------------------------
import Prelude hiding ((.), id, catch)

import Control.Exception (catch, SomeException)
import Control.Category
import Control.Monad (liftM, mplus)
import "transformers" Control.Monad.Trans.State (StateT, evalStateT, gets, put)
import "transformers" Control.Monad.Trans (MonadIO, liftIO, lift)
import "transformers" Control.Monad.Trans.Error (Error, noMsg, ErrorT, runErrorT, throwError)
import qualified "mtl" Control.Monad.Trans as MtlTrans
import qualified "monads-fd" Control.Monad.State as TfState

import Data.Maybe (fromMaybe)

----------------------------------------
-- SITE-PACKAGES
----------------------------------------
import System.Log.Logger (Priority(..), logM)

import Factis.Haskoon.Web
import Factis.Haskoon.WebHelper (statusCodeMessageMap)

import Data.Record.Label

import Network.Protocol.Http as Http hiding (server)
import Network.Protocol.Uri as Uri hiding (host)

import Network.Salvia ( start, defaultConfig, listenOn, Handler(..)
                      , hDefaultEnv, hDumpRequest, hDumpResponse)
import Network.Salvia.Interface
import Network.Salvia.Handler.Error
import Network.Salvia.Handler.Cookie

import Network.Socket (SockAddr(..), PortNumber, inet_addr, NameInfoFlag(..), getNameInfo, getSocketName)

import qualified Network.Protocol.Cookie as Cookie
import qualified Network.URI as Uri
import qualified Network.CGI.Cookie as CGI

instance Error () where
    noMsg = ()

newtype WebSalvia m a = WebSalvia (StateT [String] (ErrorT () m) a)
    deriving (Monad, MonadIO)

instance MtlTrans.MonadIO m => MtlTrans.MonadIO (WebSalvia m) where
    liftIO io = WebSalvia (lift (lift (MtlTrans.liftIO io)))

liftWebSalvia :: MonadIO m => m a -> WebSalvia m a
liftWebSalvia ma = WebSalvia (lift (lift ma))

getHostAndPort :: (MonadIO m, SocketM m) => Maybe String -> m (String, String)
getHostAndPort mHostHeader =
     do case mHostHeader of
          Just s ->
              let (h, p) = span (/= ':') s
              in if null p
                    then return (h, "80")
                    else return (h, drop 1 p)
          Nothing ->
             do sock <- socket
                addr <- liftIO $ getSocketName sock
                (mhost, mport) <- liftIO $ getNameInfo [NI_NAMEREQD] True False addr
                host <- case mhost of
                          Just h -> return h
                          Nothing -> do (mhost', _) <-
                                          liftIO $ getNameInfo [NI_NUMERICHOST] False False addr
                                        case mhost' of
                                          Just h -> return h
                                          Nothing -> return "INVALID_HOST"
                let port = case mport of
                             Just p -> p
                             Nothing -> "80"
                return (host, port)

instance (MonadIO m,HttpM' m,BodyM Request m,SendM m,HandleQueueM m,ServerM m,AddressM' m,SocketM m)
    => Web (WebSalvia m) where
    type WebRes (WebSalvia m) = ()
    -- general
    webDocumentRoot = return "/"
    webContainerUri =
        do mHostHeader <- webGetHeader "Host"
           liftWebSalvia $
             do (_host, _port) <- getHostAndPort mHostHeader
                return (Uri.URI "http:" (Just $ Uri.URIAuth "" _host (':' : _port)) "" "" "")
    webRequestUri =
        do mHostHeader <- webGetHeader "Host"
           liftWebSalvia $
             do _path  <- request (getM (path . asUri))
                _query <- request (getM (query . asUri))
                _frag <- request (getM (fragment . asUri))
                (_host, _port) <- getHostAndPort mHostHeader
                return (Uri.URI "http:" (Just $ Uri.URIAuth "" _host (':' : _port)) _path
                                ('?' : _query) ('#':_frag))
    webPathInfo =
        liftWebSalvia $
        do _path   <- request (getM (path . asUri))
           return _path
    webMethod =
        liftWebSalvia $
        do _method <- request (getM method)
           return (show _method)
    webGetBody =
        liftWebSalvia $
        do b <- body forRequest
           return b
    webGetParams =
        liftWebSalvia $
        do params <- request (getM (queryParams . asUri))
           return [(k,v) | (k, Just v) <- params]
    webGetHeaders =
        liftWebSalvia $
        do _headers <- request (getM headers)
           return (unHeaders _headers)
    webGetCookies =
        liftWebSalvia $
        do res <- hCookie
           case res of
             Just cs -> return [(get Cookie.name c, get Cookie.value c) | c <- Cookie.toList cs]
             Nothing -> return []
    -- response
    webSetStatus i mmsg =
        liftWebSalvia $
        do response $ status =: CustomStatus i (fromMaybe "n/a" reason)
           return ()
        where reason = mmsg `mplus` lookup i statusCodeMessageMap
    webSendBSL bsl =
        liftWebSalvia $
        do sendBs bsl
           return ()
    webSetHeader name value =
        liftWebSalvia $
        do response $ Http.header name =: (Just value)
           return ()
    webFail msg =
        do webLog "haskoon-salvia:webFail" ERROR msg
           liftWebSalvia (hCustomError InternalServerError ("ERROR: " ++ msg))
           WebSalvia (lift $ throwError ())
    webSetCookie cgiCookie =
        liftWebSalvia $
        do port <- liftM portNum serverAddress
           let salviaCookie = mapCgiToSalviaCookie port cgiCookie
           hSetCookie (Cookie.fromList [salviaCookie])
        where portNum (SockAddrInet  p _)     = fromIntegral p
              portNum (SockAddrInet6 p _ _ _) = fromIntegral p
              portNum _                       = -1
    webUnsetCookie cgiCookie =
        liftWebSalvia $
        do hDelCookie name
        where name = CGI.cookieName cgiCookie
    webGetRepls = WebSalvia (gets id)
    webWithRepls repls (WebSalvia cont) =
        WebSalvia $ do put repls
                       cont
    webRunFromRq = undefined
    webLog name prio msg = liftIO (logM name prio msg)

instance ( MtlTrans.MonadIO m, MonadIO m, HttpM' m, BodyM Request m, SendM m, HandleQueueM m
         , ServerM m,AddressM' m,SocketM m)
    => WebIO (WebSalvia m)

hHaskoon :: (MonadIO m, HttpM' m, BodyM Request m, SendM m, HandleQueueM m, ServerM m, AddressM' m)
         => WebSalvia m (WebRes (WebSalvia m)) -> m ()
hHaskoon (WebSalvia ma) =
    do _ <- runErrorT (evalStateT ma [])
       return ()

mapCgiToSalviaCookie :: Int -> CGI.Cookie -> Cookie.Cookie
mapCgiToSalviaCookie port (CGI.Cookie name value mexpires mdomain mpath secure) =
    (Cookie.Cookie name value Nothing Nothing False mdomain
                   Nothing (fmap show mexpires) mpath [port] secure 0)


instance MtlTrans.MonadIO (Handler p) where
    liftIO io = Handler (TfState.StateT stfun)
        where stfun s = do x <- io
                           return (x, s)

salviaMain :: String
           -> PortNumber
           -> WebSalvia (Handler ()) (WebRes (WebSalvia (Handler ())))
           -> IO ()
salviaMain addrString port fun =
    do addr <- inet_addr addrString
       let myHandler =
               hDefaultEnv $ do hDumpRequest
                                hHaskoon $ fun
                                hDumpResponse
       let myPayload = ()
       let myConfig = defaultConfig { listenOn = [ SockAddrInet port addr ] }
       start myConfig (catchAllExceptions myHandler) myPayload
    where
      catchAllExceptions handler =
          let fun = TfState.runStateT (unHandler handler)
          in Handler $ TfState.StateT $ \state ->
              do (_, state') <- fun state
                 return ((), state')
              `catch` (\(e::SomeException) ->
                           do logM "haskoon-salvia:salviaMain" ERROR
                                       ("Uncaught exception in salvia handler: " ++ show e)
                              return ((), state))