module Factis.Haskoon.WebSalvia (WebSalvia, salviaMain) where
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)
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) = ()
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 []
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))