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
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)
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
webDocumentRoot :: m FilePath
webContainerUri :: m URI
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)]
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 ()
webGetRepls :: m [String]
webWithRepls :: [String] -> m a -> m a
webRunFromRq :: FromRq a => m (Either String a)
webLog :: String -> Priority -> String -> m ()
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))
-> (String -> m (WebRes m))
-> 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"