module Happstack.Server.SimpleHTTP
( module Happstack.Server.HTTP.Types
, module Happstack.Server.Cookie
, simpleHTTP
, simpleHTTP'
, parseConfig
, ServerPartT(..)
, ServerPart
, runServerPartT
, mapServerPartT
, mapServerPartT'
, withRequest
, anyRequest
, WebT(..)
, UnWebT
, 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 Happstack.Server.HTTP.Types hiding (Version(..))
import Happstack.Server.Cookie
import qualified Paths_happstack_server as Cabal
import qualified Data.Version as DV
import Happstack.Server.HTTP.Client (getResponse, unproxify, unrproxify)
import Happstack.Data.Xml.HaXml (toHaXmlEl)
import qualified Happstack.Server.MinHaXML as H
import qualified Happstack.Server.HTTP.Listen as Listen (listen)
import Happstack.Server.XSLT (XSLTCmd, XSLPath, procLBSIO)
import Happstack.Server.SURI (ToSURI)
import Happstack.Util.Common (Seconds, readM)
import Happstack.Data (Xml, normalize, fromPairs, Element, toXml, toPublicXml)
import Control.Applicative (Applicative, pure, (<*>))
import Control.Concurrent (forkIO)
import Control.Exception (evaluate)
import Control.Monad ( MonadPlus, mzero, mplus
, msum, ap, unless
, liftM, liftM2, liftM3, liftM4
)
import Control.Monad.Trans ( MonadTrans, lift
, MonadIO, liftIO
)
import Control.Monad.Reader ( ReaderT(ReaderT), runReaderT
, MonadReader, ask, local
, asks
)
import Control.Monad.Writer ( WriterT(WriterT), runWriterT
, MonadWriter, tell, pass
, listens
)
import qualified Control.Monad.Writer as Writer (listen)
import Control.Monad.State (MonadState, get, put)
import Control.Monad.Error ( ErrorT(ErrorT), runErrorT
, Error, strMsg
, MonadError, throwError, catchError
)
import Control.Monad.Maybe (MaybeT(MaybeT), runMaybeT)
import Data.Char (ord)
import Data.Maybe (fromMaybe)
import Data.Monoid ( Monoid, mempty, mappend
, Dual(Dual), getDual
, Endo(Endo), appEndo
)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.UTF8 as LU (toString, fromString)
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 (toLower)
import Data.List (isPrefixOf)
import System.IO (hGetContents, hClose)
import System.Console.GetOpt ( OptDescr(Option)
, ArgDescr(ReqArg)
, ArgOrder(Permute)
, getOpt
)
import System.Process (runInteractiveProcess, waitForProcess)
import System.Exit (ExitCode(ExitSuccess, ExitFailure))
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 :: ( UnWebT m a -> UnWebT n b)
-> (ServerPartT m a -> ServerPartT n b)
mapServerPartT f ma = withRequest $ \rq -> mapWebT f (runServerPartT ma rq)
mapServerPartT' :: (Request -> UnWebT m a -> UnWebT n b)
-> ( 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
extract :: SetAppend t -> t
extract (Set x) = x
extract (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))
unFilterFun :: FilterFun a -> (a -> a)
unFilterFun = appEndo . getDual . extract
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 = FilterT . tell . Set . Dual . Endo
composeFilter = FilterT . tell . Append . Dual . Endo
getFilter = FilterT . listens unFilterFun . unFilterT
newtype WebT m a = WebT { unWebT :: ErrorT Response (FilterT (Response) (MaybeT m)) a }
deriving (MonadIO, Functor)
type UnWebT m a = m (Maybe (Either Response a, FilterFun Response))
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 $ fmap lft $ getFilter (runErrorT $ unWebT m)
where
lft (Left r, _) = Left r
lft (Right a, f) = Right (a, f)
instance (Monad m) => Monoid (WebT m a) where
mempty = mzero
mappend = mplus
runWebT :: forall m b. (Functor m, ToMessage b) => WebT m b -> m (Maybe Response)
runWebT = (fmap . fmap) appFilterToResp . ununWebT
where
appFilterToResp :: (Either Response b, FilterFun Response) -> Response
appFilterToResp (e, ff) = unFilterFun ff $ either id toResponse e
ununWebT :: WebT m a -> UnWebT m a
ununWebT = runMaybeT . runWriterT . unFilterT . runErrorT . unWebT
mkWebT :: UnWebT m a -> WebT m a
mkWebT = WebT . ErrorT . FilterT . WriterT . MaybeT
mapWebT :: (UnWebT m a -> UnWebT n b)
-> ( 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 . 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' :: (ToMessage b, Monad m, Functor m) => (UnWebT m a -> UnWebT IO b)
-> Conf -> ServerPartT m a -> IO ()
simpleHTTP' toIO conf hs =
Listen.listen conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req))
simpleHTTP'' :: (ToMessage b, Monad m, Functor 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; charset=UTF-8"
toMessage [el] = LU.fromString $ 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; charset=UTF-8"
toMessage = LU.fromString
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; charset=UTF-8"
toMessage = LU.fromString . renderHtml
instance ToMessage XHtml.Html where
toContentType _ = B.pack "text/html; charset=UTF-8"
toMessage = LU.fromString . 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
unless (f rq) 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
_ -> 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)
_ -> 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 = getDataFn fn >>= maybe mzero handle
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, Functor 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 LU.toString . 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,LU.toString $ 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
-> UnWebT (ErrorT e m) a
-> UnWebT m a
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 =
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">"
++ "<html><head><title>Happstack "
++ ver ++ " Internal Server Error</title></head>"
++ "<body><h1>Happstack " ++ ver ++ "</h1>"
++ "<p>Something went wrong here<br>"
++ "Internal server error<br>"
++ "Everything has stopped</p>"
++ "<p>The error was \"" ++ (escapeString errString) ++ "\"</p></body></html>"
where ver = DV.showVersion Cabal.version
escapeString :: String -> String
escapeString str = concatMap encodeEntity str
where
encodeEntity :: Char -> String
encodeEntity '<' = "<"
encodeEntity '>' = ">"
encodeEntity '&' = "&"
encodeEntity '"' = """
encodeEntity c
| ord c > 127 = "&#" ++ show (ord c) ++ ";"
| otherwise = [c]
notFoundHtml :: String
notFoundHtml =
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">"
++ "<html><head><title>Happstack "
++ ver ++ " File not found</title></head>"
++ "<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