Web.hs

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

module Factis.Haskoon.Web
    (Web(..),WebIO,FromRq(..),ToWebRes(..), WebWebRes, WebRec(..)
    ,webRepl,webOk,webNotFound,webFileNotFound,webBadRequest
    ,webSendString,webGetCookie,webRedirect,webWithData,webCheckData
    ,webSendFile, 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.List (find, isSuffixOf)

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

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

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)

----------------------------------------
-- LOCAL
----------------------------------------
import Factis.Haskoon.RqAccess (FromRq(..))
import Factis.Haskoon.RqAccessM (RqData(..), runRqAccessM)

type WebParams = [(String,String)]
type WebHeaders = [(String,String)]
type WebCookies = [(String,String)]

data WebRec m
    = WebRec
    { web_documentRoot :: m FilePath
    , web_containerUri :: m URI
    , web_requestUri :: m URI
    , web_pathInfo :: m String
    , web_method :: m String
    , web_getBody :: m BSL.ByteString
    , web_getParams :: m WebParams
    , web_getHeaders :: m WebHeaders
    , web_getCookies :: m WebCookies
    , web_setStatus :: Int -> Maybe String -> m ()
    , web_sendBSL :: BSL.ByteString -> m (WebRes m)
    , web_setHeader :: String -> String -> m ()
    , web_setCookie :: Cookie -> m ()
    , web_unsetCookie :: Cookie -> m ()
    , web_log :: String -> Priority -> String -> m ()
    , web_getRepls :: m [String]
    , web_fail :: forall a. String -> m a
    , web_withRepls :: forall a. [String] -> m a -> m a
    }

-- | You may either define @webRec@ or all of @webDocumentRoot@,
-- @webContainerUri@, @webPathInfo@, @webMethod@, @webGetBody@,
-- @webGetParams@, @webGetHeaders@, @webGetCookies@, @webSetStatus@,
-- @webSendBSL@, @webSetHeader@, @webSetCookie@, @webUnsetCookie@,
-- @webLog@ and @webGetRepls@, @webWithRepls@ and @webFail@.
class Monad m => Web m where
    type WebRes m
    -- record-based implementation of most instance methods
    webRec :: WebRec m
    webRec = WebRec webDocumentRoot webContainerUri webRequestUri webPathInfo webMethod
                       webGetBody webGetParams webGetHeaders webGetCookies webSetStatus
                       webSendBSL webSetHeader webSetCookie webUnsetCookie webLog
                       webGetRepls webFail webWithRepls
    -- general
    webDocumentRoot :: m FilePath
    webDocumentRoot = web_documentRoot webRec
    webContainerUri :: m URI
    webContainerUri = web_containerUri webRec
    -- request
    webRequestUri :: m URI
    webRequestUri = web_requestUri webRec
    webPathInfo :: m String
    webPathInfo = web_pathInfo webRec
    webMethod :: m String
    webMethod = web_method webRec
    webGetBody :: m BSL.ByteString
    webGetBody = web_getBody webRec
    webGetParams :: m WebParams
    webGetParams = web_getParams webRec
    webGetHeaders :: m WebHeaders
    webGetHeaders = web_getHeaders webRec
    webGetCookies :: m WebCookies
    webGetCookies = web_getCookies webRec
    -- response
    webSetStatus :: Int -> Maybe String -> m ()
    webSetStatus = web_setStatus webRec
    webSendBSL :: BSL.ByteString -> m (WebRes m)
    webSendBSL = web_sendBSL webRec
    webSetHeader :: String -> String -> m ()
    webSetHeader = web_setHeader webRec
    webSetCookie :: Cookie -> m ()
    webSetCookie = web_setCookie webRec
    webUnsetCookie :: Cookie -> m ()
    webUnsetCookie = web_unsetCookie webRec
    -- special control methods
    webLog :: String -> Priority -> String -> m ()
    webLog = web_log webRec
    webGetRepls :: m [String]
    webGetRepls = web_getRepls webRec
    webWithRepls :: [String] -> m a -> m a
    webWithRepls = web_withRepls webRec
    -- default methods that may be overridden
    webFail :: String -> m a
    webFail = web_fail webRec
    webRunFromRq :: FromRq a => m (Either String a)
    webRunFromRq =
        do meth <- webMethod
           headers <- webGetHeaders
           repls <- webGetRepls
           params <- webGetParams
           cookies <- webGetCookies
           let rqdata = RqData meth params headers repls cookies
           return (runRqAccessM fromRq rqdata)
    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 :: Web m => [Char] -> m (WebRes m)
webNotFound name = webSendError 404 ("Not found: " ++ name)

webFileNotFound :: Web m => [Char] -> m (WebRes m)
webFileNotFound fpath = webSendError 404 ("File not found: " ++ fpath)

webBadRequest :: Web m => [Char] -> m (WebRes m)
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_ :: [Char]
_LOGNAME_ = "Web"

webLogNotice, webLogDebug, webLogTrace :: Web m => String -> m ()
webLogNotice = webLog _LOGNAME_ NOTICE
webLogDebug = webLog _LOGNAME_ INFO
webLogTrace = webLog _LOGNAME_ DEBUG

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


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"