module Happstack.Server.SimpleHTTP
( module Happstack.Server.HTTP.Types
, module Happstack.Server.Cookie
, simpleHTTP
, simpleHTTP'
, parseConfig
, ServerPartT(..)
, ServerPart
, runServerPartT
, mapServerPartT
, mapServerPartT'
, withRequest
, anyRequest
, WebT(..)
, FilterFun
, Web
, mkWebT
, ununWebT
, runWebT
, mapWebT
, FromReqURI(..)
, ToMessage(..)
, FromData(..)
, ServerMonad(..)
, RqData
, noHandle
, getHeaderM
, escape
, escape'
, multi
, FilterMonad(..)
, ignoreFilters
, SetAppend(..)
, FilterT(..)
, WebMonad(..)
, ok
, modifyResponse
, setResponseCode
, badGateway
, internalServerError
, badRequest
, unauthorized
, forbidden
, notFound
, seeOther
, found
, movedPermanently
, tempRedirect
, addCookie
, addCookies
, addHeaderM
, setHeaderM
, guardRq
, dir
, method
, methodSP
, methodM
, methodOnly
, nullDir
, path
, anyPath
, anyPath'
, withData
, withDataFn
, getDataFn
, getData
, require
, requireM
, basicAuth
, uriRest
, flatten
, localContext
, proxyServe
, rproxyServe
, debugFilter
, applyRequest
, lookInput
, lookBS
, look
, lookCookie
, lookCookieValue
, readCookieValue
, lookRead
, lookPairs
, xslt ,doXslt
, errorHandlerSP
, simpleErrorHandler
, spUnwrapErrorT
, setValidator
, setValidatorSP
, validateConf
, runValidator
, wdgHTMLValidator
, noopValidator
, lazyProcValidator
) where
import qualified Paths_happstack_server as Cabal
import qualified Data.Version as DV
import Happstack.Server.HTTP.Client
import Happstack.Data.Xml.HaXml
import qualified Happstack.Server.MinHaXML as H
import Happstack.Server.HTTP.Types hiding (Version(..))
import qualified Happstack.Server.HTTP.Types as Types
import Happstack.Server.HTTP.Listen as Listen
import Happstack.Server.XSLT
import Happstack.Server.SURI (ToSURI)
import Happstack.Util.Common
import Happstack.Server.Cookie
import Happstack.Data
import Control.Applicative
import Control.Concurrent (forkIO)
import Control.Exception (evaluate)
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Error
import Control.Monad.Trans()
import Control.Monad.Maybe
import Control.Monad.Writer as Writer
import Data.Maybe
import Data.Monoid
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Generics as G
import qualified Data.Map as M
import Text.Html (Html,renderHtml)
import qualified Text.XHtml as XHtml (Html,renderHtml)
import qualified Happstack.Crypto.Base64 as Base64
import Data.Char
import Data.List
import System.IO
import System.Console.GetOpt
import System.Process (runInteractiveProcess, waitForProcess)
import System.Exit
import Text.Show.Functions ()
type Web a = WebT IO a
type ServerPart a = ServerPartT IO a
newtype ServerPartT m a = ServerPartT { unServerPartT :: ReaderT Request (WebT m) a }
deriving (Monad, MonadIO, MonadPlus, Functor)
runServerPartT :: ServerPartT m a -> Request -> WebT m a
runServerPartT = runReaderT . unServerPartT
withRequest :: (Request -> WebT m a) -> ServerPartT m a
withRequest = ServerPartT . ReaderT
mapServerPartT :: (m (Maybe (Either Response a, FilterFun Response)) -> n (Maybe (Either Response b, FilterFun Response))) -> ServerPartT m a -> ServerPartT n b
mapServerPartT f ma = withRequest $ \rq -> mapWebT f (runServerPartT ma rq)
mapServerPartT' :: (Request -> m (Maybe (Either Response a, FilterFun Response)) -> n (Maybe (Either Response b, FilterFun Response))) -> ServerPartT m a -> ServerPartT n b
mapServerPartT' f ma = withRequest $ \rq -> mapWebT (f rq) (runServerPartT ma rq)
instance MonadTrans (ServerPartT) where
lift m = withRequest (\_ -> lift m)
instance (Monad m) => Monoid (ServerPartT m a)
where mempty = mzero
mappend = mplus
instance (Monad m, Functor m) => Applicative (ServerPartT m) where
pure = return
(<*>) = ap
instance (Monad m, MonadWriter w m) => MonadWriter w (ServerPartT m) where
tell = lift . tell
listen m = withRequest $ \rq -> Writer.listen (runServerPartT m rq) >>= return
pass m = withRequest $ \rq -> pass (runServerPartT m rq) >>= return
instance (Monad m, MonadError e m) => MonadError e (ServerPartT m) where
throwError e = lift $ throwError e
catchError action handler = withRequest $ \rq -> (runServerPartT action rq) `catchError` ((flip runServerPartT $ rq) . handler)
instance (Monad m, MonadReader r m) => MonadReader r (ServerPartT m) where
ask = lift ask
local fn m = withRequest $ \rq-> local fn (runServerPartT m rq)
instance Monad m => FilterMonad Response (ServerPartT m) where
setFilter = anyRequest . setFilter
composeFilter = anyRequest . composeFilter
getFilter m = withRequest $ \rq -> getFilter (runServerPartT m rq)
instance Monad m => WebMonad Response (ServerPartT m) where
finishWith r = anyRequest $ finishWith r
class Monad m => ServerMonad m where
askRq :: m Request
localRq :: (Request->Request)->m a->m a
instance (Monad m) => ServerMonad (ServerPartT m) where
askRq = ServerPartT $ ask
localRq f m = ServerPartT $ local f (unServerPartT m)
data SetAppend a = Set a | Append a
deriving (Eq, Show)
instance Monoid a => Monoid (SetAppend a) where
mempty = Append mempty
Set x `mappend` Append y = Set (x `mappend` y)
Append x `mappend` Append y = Append (x `mappend` y)
_ `mappend` Set y = Set y
value :: SetAppend t -> t
value (Set x) = x
value (Append x) = x
instance Functor (SetAppend) where
fmap f (Set x) = Set $ f x
fmap f (Append x) = Append $ f x
type FilterFun a = SetAppend (Dual (Endo a))
newtype FilterT a m b =
FilterT { unFilterT :: WriterT (FilterFun a) m b }
deriving (Monad, MonadTrans, Functor, MonadIO)
class Monad m => FilterMonad a m | m->a where
setFilter :: (a->a) -> m ()
composeFilter :: (a->a) -> m ()
getFilter :: m b -> m (b,a->a)
instance (Monad m) => FilterMonad a (FilterT a m) where
setFilter f = FilterT $ Writer.tell $ Set $ Dual $ Endo f
composeFilter f = FilterT $ Writer.tell $ Append $ Dual $ Endo f
getFilter m = FilterT $ Writer.listens (appEndo . getDual . value) (unFilterT m)
newtype WebT m a = WebT { unWebT :: ErrorT Response (FilterT (Response) (MaybeT m)) a }
deriving (MonadIO, Functor)
instance Monad m => Monad (WebT m) where
m >>= f = WebT $ unWebT m >>= unWebT . f
return a = WebT $ return a
fail s = mkFailMessage s
instance Error Response where
strMsg = toResponse
class Monad m => WebMonad a m | m->a where
finishWith :: a -> m b
instance (Monad m) => WebMonad Response (WebT m) where
finishWith r = WebT $ throwError r
instance MonadTrans WebT where
lift = WebT . lift . lift . lift
instance (Monad m) => MonadPlus (WebT m) where
mzero = WebT $ lift $ lift $ mzero
mplus x y = WebT $ ErrorT $ FilterT $ (lower x) `mplus` (lower y)
where lower = (unFilterT . runErrorT . unWebT)
noHandle :: (MonadPlus m) => m a
noHandle = mzero
instance (Monad m) => FilterMonad Response (WebT m) where
setFilter f = WebT $ lift $ setFilter $ f
composeFilter f = WebT . lift . composeFilter $ f
getFilter m = WebT $ ErrorT $ getFilter (runErrorT $ unWebT m) >>= liftWebT
where liftWebT (Left r, _) = return $ Left r
liftWebT (Right a, f) = return $ Right (a, f)
instance (Monad m) => Monoid (WebT m a) where
mempty = mzero
mappend = mplus
runWebT :: (ToMessage b, Monad m) => WebT m b -> m (Maybe Response)
runWebT m = runMaybeT $ do
(r,ed) <- runWriterT $ unFilterT $ runErrorT $ unWebT $ m
let f = appEndo $ getDual $ value ed
return $ either (f) (f . toResponse) r
ununWebT :: WebT m a
-> m (Maybe
(Either Response a,
FilterFun Response))
ununWebT = runMaybeT . runWriterT . unFilterT . runErrorT . unWebT
mkWebT :: m (Maybe
(Either Response a,
FilterFun Response)) -> WebT m a
mkWebT = WebT . ErrorT . FilterT . WriterT . MaybeT
mapWebT :: (m (Maybe (Either Response a, FilterFun Response)) -> n (Maybe (Either Response b, FilterFun Response))) -> WebT m a -> WebT n b
mapWebT f ma = mkWebT $ f (ununWebT ma)
instance (Monad m, Functor m) => Applicative (WebT m) where
pure = return
(<*>) = ap
instance MonadReader r m => MonadReader r (WebT m) where
ask = lift ask
local fn m = mkWebT $ local fn (ununWebT m)
instance MonadState st m => MonadState st (WebT m) where
get = lift get
put = lift . put
instance MonadError e m => MonadError e (WebT m) where
throwError err = lift $ throwError err
catchError action handler = mkWebT $ catchError (ununWebT action) (ununWebT . handler)
instance MonadWriter w m => MonadWriter w (WebT m) where
tell = lift . Writer.tell
listen m = mkWebT $ Writer.listen (ununWebT m) >>= (return . liftWebT)
where liftWebT (Nothing, _) = Nothing
liftWebT (Just (Left x,f), _) = Just (Left x,f)
liftWebT (Just (Right x,f),w) = Just (Right (x,w),f)
pass m = mkWebT $ ununWebT m >>= liftWebT
where liftWebT Nothing = return Nothing
liftWebT (Just (Left x,f)) = return $ Just (Left x, f)
liftWebT (Just (Right x,f)) = pass (return x)>>= (\a -> return $ Just (Right a,f))
ignoreFilters :: (FilterMonad a m) => m ()
ignoreFilters = setFilter id
escape :: (WebMonad a m, FilterMonad a m) => m a -> m b
escape gen = ignoreFilters >> gen >>= finishWith
escape' :: (WebMonad a m, FilterMonad a m) => a -> m b
escape' a = ignoreFilters >> finishWith a
ho :: [OptDescr (Conf -> Conf)]
ho = [Option [] ["http-port"] (ReqArg (\h c -> c { port = read h }) "port") "port to bind http server"]
parseConfig :: [String] -> Either [String] Conf
parseConfig args
= case getOpt Permute ho args of
(flags,_,[]) -> Right $ foldr ($) nullConf flags
(_,_,errs) -> Left errs
simpleHTTP :: (ToMessage a) => Conf -> ServerPartT IO a -> IO ()
simpleHTTP = simpleHTTP' id
simpleHTTP' :: (Monad m, ToMessage b) =>
(m (Maybe (Either Response a, FilterFun Response))
-> IO (Maybe (Either Response b, FilterFun Response)))
-> Conf
-> ServerPartT m a
-> IO ()
simpleHTTP' toIO conf hs = do
Listen.listen conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req))
simpleHTTP'' :: (ToMessage b, Monad m) => ServerPartT m b -> Request -> m Response
simpleHTTP'' hs req = (runWebT $ runServerPartT hs req) >>= (return . (maybe standardNotFound id))
where
standardNotFound = setHeader "Content-Type" "text/html" $ toResponse notFoundHtml
class FromReqURI a where
fromReqURI :: String -> Maybe a
instance FromReqURI String where fromReqURI = Just
instance FromReqURI Int where fromReqURI = readM
instance FromReqURI Integer where fromReqURI = readM
instance FromReqURI Float where fromReqURI = readM
instance FromReqURI Double where fromReqURI = readM
type RqData a = ReaderT ([(String,Input)], [(String,Cookie)]) Maybe a
class FromData a where
fromData :: RqData a
instance (Eq a,Show a,Xml a,G.Data a) => FromData a where
fromData = do mbA <- lookPairs >>= return . normalize . fromPairs
case mbA of
Just a -> return a
Nothing -> fail "FromData G.Data failure"
instance (FromData a, FromData b) => FromData (a,b) where
fromData = liftM2 (,) fromData fromData
instance (FromData a, FromData b, FromData c) => FromData (a,b,c) where
fromData = liftM3 (,,) fromData fromData fromData
instance (FromData a, FromData b, FromData c, FromData d) => FromData (a,b,c,d) where
fromData = liftM4 (,,,) fromData fromData fromData fromData
instance FromData a => FromData (Maybe a) where
fromData = fmap Just fromData `mplus` return Nothing
class ToMessage a where
toContentType :: a -> B.ByteString
toContentType _ = B.pack "text/plain"
toMessage :: a -> L.ByteString
toMessage = error "Happstack.Server.SimpleHTTP.ToMessage.toMessage: Not defined"
toResponse:: a -> Response
toResponse val =
let bs = toMessage val
res = Response 200 M.empty nullRsFlags bs Nothing
in setHeaderBS (B.pack "Content-Type") (toContentType val)
res
instance ToMessage [Element] where
toContentType _ = B.pack "application/xml"
toMessage [el] = L.pack $ H.simpleDoc H.NoStyle $ toHaXmlEl el
toMessage x = error ("Happstack.Server.SimpleHTTP 'instance ToMessage [Element]' Can't handle " ++ show x)
instance ToMessage () where
toContentType _ = B.pack "text/plain"
toMessage () = L.empty
instance ToMessage String where
toContentType _ = B.pack "text/plain"
toMessage = L.pack
instance ToMessage Integer where
toMessage = toMessage . show
instance ToMessage a => ToMessage (Maybe a) where
toContentType _ = toContentType (undefined :: a)
toMessage Nothing = toMessage "nothing"
toMessage (Just x) = toMessage x
instance ToMessage Html where
toContentType _ = B.pack "text/html"
toMessage = L.pack . renderHtml
instance ToMessage XHtml.Html where
toContentType _ = B.pack "text/html"
toMessage = L.pack . XHtml.renderHtml
instance ToMessage Response where
toResponse = id
instance (Xml a)=>ToMessage a where
toContentType = toContentType . toXml
toMessage = toMessage . toPublicXml
class MatchMethod m where matchMethod :: m -> Method -> Bool
instance MatchMethod Method where matchMethod m = (== m)
instance MatchMethod [Method] where matchMethod methods = (`elem` methods)
instance MatchMethod (Method -> Bool) where matchMethod f = f
instance MatchMethod () where matchMethod () _ = True
flatten :: (ToMessage a, Functor f) => f a -> f Response
flatten = fmap toResponse
localContext :: Monad m => (WebT m a -> WebT m' a) -> ServerPartT m a -> ServerPartT m' a
localContext fn hs
= withRequest $ \rq -> fn (runServerPartT hs rq)
getHeaderM :: (ServerMonad m) => String -> m (Maybe B.ByteString)
getHeaderM a = askRq >>= return . (getHeader a)
addHeaderM :: (FilterMonad Response m) => String -> String -> m ()
addHeaderM a v = composeFilter $ \res-> addHeader a v res
setHeaderM :: (FilterMonad Response m) => String -> String -> m ()
setHeaderM a v = composeFilter $ \res -> setHeader a v res
guardRq :: (ServerMonad m, MonadPlus m) => (Request -> Bool) -> m ()
guardRq f = do
rq <- askRq
when ( f rq /= True ) mzero
methodM :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()
methodM meth = methodOnly meth >> nullDir
methodOnly :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()
methodOnly meth = guardRq $ \rq -> matchMethod meth (rqMethod rq)
methodSP :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m b-> m b
methodSP m handle = methodM m >> handle
method :: (MatchMethod method, Monad m) => method -> WebT m a -> ServerPartT m a
method m handle = methodSP m (anyRequest handle)
nullDir :: (ServerMonad m, MonadPlus m) => m ()
nullDir = guardRq $ \rq -> null (rqPaths rq)
dir :: (ServerMonad m, MonadPlus m) => String -> m a -> m a
dir staticPath handle =
do
rq <- askRq
case rqPaths rq of
(p:xs) | p == staticPath -> localRq (\newRq -> newRq{rqPaths = xs}) handle
| otherwise -> mzero
_ -> mzero
path :: (FromReqURI a, MonadPlus m, ServerMonad m) => (a -> m b) -> m b
path handle = do
rq <- askRq
case rqPaths rq of
(p:xs) | Just a <- fromReqURI p
-> localRq (\newRq -> newRq{rqPaths = xs}) (handle a)
| otherwise -> mzero
_ -> mzero
uriRest :: (ServerMonad m) => (String -> m a) -> m a
uriRest handle = askRq >>= handle . rqURL
anyPath :: (ServerMonad m, MonadPlus m) => m r -> m r
anyPath x = path $ (\(_::String) -> x)
anyPath' :: (ServerMonad m, MonadPlus m) => m r -> m r
anyPath' = anyPath
getDataFn :: (ServerMonad m) => RqData a -> m (Maybe a)
getDataFn rqData = do
rq <- askRq
return $ runReaderT rqData (rqInputs rq, rqCookies rq)
getData :: (ServerMonad m, FromData a) => m (Maybe a)
getData = getDataFn fromData
withData :: (FromData a, MonadPlus m, ServerMonad m) => (a -> m r) -> m r
withData = withDataFn fromData
withDataFn :: (MonadPlus m, ServerMonad m) => RqData a -> (a -> m r) -> m r
withDataFn fn handle = do
d <- getDataFn fn
case d of
Nothing -> mzero
Just a -> handle a
proxyServe :: (MonadIO m, WebMonad Response m, ServerMonad m, MonadPlus m, FilterMonad Response m) => [String] -> m Response
proxyServe allowed = do
rq <- askRq
if cond rq then proxyServe' rq else mzero
where
cond rq
| "*" `elem` allowed = True
| domain `elem` allowed = True
| superdomain `elem` wildcards =True
| otherwise = False
where
domain = head (rqPaths rq)
superdomain = tail $ snd $ break (=='.') domain
wildcards = (map (drop 2) $ filter ("*." `isPrefixOf`) allowed)
proxyServe' :: (MonadIO m, FilterMonad Response m, WebMonad Response m) => Request-> m Response
proxyServe' rq = liftIO (getResponse (unproxify rq)) >>=
either (badGateway . toResponse . show) escape'
rproxyServe :: (MonadIO m, WebMonad Response m) =>
String
-> [(String, String)]
-> ServerPartT m Response
rproxyServe defaultHost list = withRequest $ \rq ->
liftIO (getResponse (unrproxify defaultHost list rq)) >>=
either (badGateway . toResponse . show) (escape')
require :: (MonadIO m, MonadPlus m) => IO (Maybe a) -> (a -> m r) -> m r
require fn handle = do
mbVal <- liftIO fn
case mbVal of
Nothing -> mzero
Just a -> handle a
requireM :: (MonadTrans t, Monad m, MonadPlus (t m)) => m (Maybe a) -> (a -> t m r) -> t m r
requireM fn handle = do
mbVal <- lift fn
case mbVal of
Nothing -> mzero
Just a -> handle a
xslt :: (MonadIO m, MonadPlus m, ToMessage r) =>
XSLTCmd
-> XSLPath
-> m r
-> m Response
xslt cmd xslPath parts = do
res <- parts
if toContentType res == B.pack "application/xml"
then liftM toResponse (doXslt cmd xslPath (toResponse res))
else return (toResponse res)
doXslt :: (MonadIO m) =>
XSLTCmd -> XSLPath -> Response -> m Response
doXslt cmd xslPath res =
do new <- liftIO $ procLBSIO cmd xslPath $ rsBody res
return $ setHeader "Content-Type" "text/html" $
setHeader "Content-Length" (show $ L.length new) $
res { rsBody = new }
modifyResponse :: (FilterMonad a m) => (a -> a) -> m()
modifyResponse = composeFilter
setResponseCode :: FilterMonad Response m => Int -> m ()
setResponseCode code
= composeFilter $ \r -> r{rsCode = code}
addCookie :: (FilterMonad Response m) => Seconds -> Cookie -> m ()
addCookie sec = (addHeaderM "Set-Cookie") . mkCookieHeader sec
addCookies :: (FilterMonad Response m) => [(Seconds, Cookie)] -> m ()
addCookies = mapM_ (uncurry addCookie)
resp :: (FilterMonad Response m) => Int -> b -> m b
resp status val = setResponseCode status >> return val
ok :: (FilterMonad Response m) => a -> m a
ok = resp 200
internalServerError :: (FilterMonad Response m) => a -> m a
internalServerError = resp 500
badGateway :: (FilterMonad Response m) => a -> m a
badGateway = resp 502
badRequest :: (FilterMonad Response m) => a -> m a
badRequest = resp 400
unauthorized :: (FilterMonad Response m) => a -> m a
unauthorized = resp 401
forbidden :: (FilterMonad Response m) => a -> m a
forbidden = resp 403
notFound :: (FilterMonad Response m) => a -> m a
notFound = resp 404
seeOther :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res
seeOther uri res = do modifyResponse $ redirect 303 uri
return res
found :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res
found uri res = do modifyResponse $ redirect 302 uri
return res
movedPermanently :: (FilterMonad Response m, ToSURI a) => a -> res -> m res
movedPermanently uri res = do modifyResponse $ redirect 301 uri
return res
tempRedirect :: (FilterMonad Response m, ToSURI a) => a -> res -> m res
tempRedirect val res = do modifyResponse $ redirect 307 val
return res
multi :: Monad m => [ServerPartT m a] -> ServerPartT m a
multi = msum
debugFilter :: (MonadIO m, Show a) => ServerPartT m a -> ServerPartT m a
debugFilter handle =
withRequest $ \rq -> do
r <- runServerPartT handle rq
return r
anyRequest :: Monad m => WebT m a -> ServerPartT m a
anyRequest x = withRequest $ \_ -> x
applyRequest :: (ToMessage a, Monad m) =>
ServerPartT m a -> Request -> Either (m Response) b
applyRequest hs = simpleHTTP'' hs >>= return . Left
basicAuth :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadPlus m) =>
String
-> M.Map String String
-> m a
-> m a
basicAuth realmName authMap xs = basicAuthImpl `mplus` xs
where
basicAuthImpl = do
aHeader <- getHeaderM "authorization"
case aHeader of
Nothing -> err
Just x -> case parseHeader x of
(name, ':':password) | validLogin name password -> mzero
| otherwise -> err
_ -> err
validLogin name password = M.lookup name authMap == Just password
parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6
headerName = "WWW-Authenticate"
headerValue = "Basic realm=\"" ++ realmName ++ "\""
err = do
unauthorized ()
setHeaderM headerName headerValue
escape' $ toResponse "Not authorized"
lookInput :: String -> RqData Input
lookInput name
= do inputs <- asks fst
case lookup name inputs of
Nothing -> fail "input not found"
Just i -> return i
lookBS :: String -> RqData L.ByteString
lookBS = fmap inputValue . lookInput
look :: String -> RqData String
look = fmap L.unpack . lookBS
lookCookie :: String -> RqData Cookie
lookCookie name
= do cookies <- asks snd
case lookup (map toLower name) cookies of
Nothing -> fail "cookie not found"
Just c -> return c
lookCookieValue :: String -> RqData String
lookCookieValue = fmap cookieValue . lookCookie
readCookieValue :: Read a => String -> RqData a
readCookieValue name = readM =<< fmap cookieValue (lookCookie name)
lookRead :: Read a => String -> RqData a
lookRead name = readM =<< look name
lookPairs :: RqData [(String,String)]
lookPairs = asks fst >>= return . map (\(n,vbs)->(n,L.unpack $ inputValue vbs))
errorHandlerSP :: (Monad m, Error e) => (Request -> e -> WebT m a) -> ServerPartT (ErrorT e m) a -> ServerPartT m a
errorHandlerSP handler sps = withRequest $ \req -> mkWebT $ do
eer <- runErrorT $ ununWebT $ runServerPartT sps req
case eer of
Left err -> ununWebT (handler req err)
Right res -> return res
simpleErrorHandler :: (Monad m) => String -> ServerPartT m Response
simpleErrorHandler err = ok $ toResponse $ ("An error occured: " ++ err)
spUnwrapErrorT:: Monad m =>
(e -> ServerPartT m a)
-> Request
-> ErrorT e m (Maybe (Either Response a, FilterFun Response))
-> m (Maybe (Either Response a, FilterFun Response))
spUnwrapErrorT handler rq = \x -> do
err <- runErrorT x
case err of
Left e -> ununWebT $ runServerPartT (handler e) rq
Right a -> return a
setValidator :: (Response -> IO Response) -> Response -> Response
setValidator v r = r { rsValidator = Just v }
setValidatorSP :: (Monad m, ToMessage r) => (Response -> IO Response) -> m r -> m Response
setValidatorSP v sp = return . setValidator v . toResponse =<< sp
validateConf :: Conf
validateConf = nullConf { validator = Just wdgHTMLValidator }
runValidator :: (Response -> IO Response) -> Response -> IO Response
runValidator defaultValidator r =
case rsValidator r of
Nothing -> defaultValidator r
(Just altValidator) -> altValidator r
wdgHTMLValidator :: (MonadIO m, ToMessage r) => r -> m Response
wdgHTMLValidator = liftIO . lazyProcValidator "validate" ["-w","--verbose","--charset=utf-8"] Nothing Nothing handledContentTypes . toResponse
where
handledContentTypes (Just ct) = elem (takeWhile (\c -> c /= ';' && c /= ' ') (B.unpack ct)) [ "text/html", "application/xhtml+xml" ]
handledContentTypes Nothing = False
noopValidator :: Response -> IO Response
noopValidator = return
lazyProcValidator :: FilePath
-> [String]
-> Maybe FilePath
-> Maybe [(String, String)]
-> (Maybe B.ByteString -> Bool)
-> Response
-> IO Response
lazyProcValidator exec args wd env mimeTypePred response
| mimeTypePred (getHeader "content-type" response) =
do (inh, outh, errh, ph) <- runInteractiveProcess exec args wd env
out <- hGetContents outh
err <- hGetContents errh
forkIO $ do L.hPut inh (rsBody response)
hClose inh
forkIO $ evaluate (length out) >> return ()
forkIO $ evaluate (length err) >> return ()
ec <- waitForProcess ph
case ec of
ExitSuccess -> return response
(ExitFailure _) ->
return $ toResponse (unlines ([ "ExitCode: " ++ show ec
, "stdout:"
, out
, "stderr:"
, err
, "input:"
] ++
showLines (rsBody response)))
| otherwise = return response
where
column = " " ++ (take 120 $ concatMap (\n -> " " ++ show n) (drop 1 $ cycle [0..9::Int]))
showLines :: L.ByteString -> [String]
showLines string = column : zipWith (\n -> \l -> show n ++ " " ++ (L.unpack l)) [1::Integer ..] (L.lines string)
mkFailMessage :: (FilterMonad Response m, WebMonad Response m) => String -> m b
mkFailMessage s = do
ignoreFilters
internalServerError ()
setHeaderM "Content-Type" "text/html"
res <- return $ toResponse $ failHtml s
finishWith $ res
failHtml:: String->String
failHtml errString = "<html><head><title>Happstack "
++ ver ++ " Internal Server Error</title>"
++ "<body><h1>Happstack " ++ ver ++ "</h1>"
++ "<p>Something went wrong here<br />"
++ "Internal server error<br />"
++ "Everything has stopped</p>"
++ "<p>The error was \"" ++ errString ++ "\"</p></body></html>"
where ver = DV.showVersion Cabal.version
notFoundHtml :: String
notFoundHtml = "<html><head><title>Happstack "
++ ver ++ " File not found</title>"
++ "<body><h1>Happstack " ++ ver ++ "</h1>"
++ "<p>Your file is not found<br />"
++ "To try again is useless<br />"
++ "It is just not here</p>"
++ "</body></html>"
where ver = DV.showVersion Cabal.version