module Happstack.Server.SimpleHTTP
( module Happstack.Server.HTTP.Types
, module Happstack.Server.Cookie
, simpleHTTP
, simpleHTTP'
, simpleHTTP''
, simpleHTTPWithSocket
, simpleHTTPWithSocket'
, bindPort
, parseConfig
, ServerPartT(..)
, ServerPart
, runServerPartT
, mapServerPartT
, mapServerPartT'
, withRequest
, anyRequest
, WebT(..)
, UnWebT
, FilterFun
, Web
, mkWebT
, ununWebT
, runWebT
, mapWebT
, FromReqURI(..)
, ToMessage(..)
, toResponseBS
, FromData(..)
, ServerMonad(..)
, RqData
, noHandle
, getHeaderM
, escape
, escape'
, multi
, FilterMonad(..)
, ignoreFilters
, SetAppend(..)
, FilterT(..)
, WebMonad(..)
, addCookie
, addCookies
, expireCookie
, addHeaderM
, setHeaderM
, ifModifiedSince
, modifyResponse
, setResponseCode
, resp
, ok
, badGateway
, internalServerError
, badRequest
, unauthorized
, forbidden
, notFound
, seeOther
, found
, movedPermanently
, tempRedirect
, guardRq
, dir
, dirs
, host
, withHost
, method
, methodSP
, methodM
, methodOnly
, nullDir
, path
, anyPath
, anyPath'
, trailingSlash
, 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, listen',listenOn)
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 Network (PortID(..), Socket)
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
, mapErrorT
)
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,stripPrefix,tails,inits)
import System.IO (hGetContents, hClose)
import System.Console.GetOpt ( OptDescr(Option)
, ArgDescr(ReqArg)
, ArgOrder(Permute)
, getOpt
)
import System.Locale (defaultTimeLocale)
import System.Process (runInteractiveProcess, waitForProcess)
import System.Time (CalendarTime, formatCalendarTime)
import System.Exit (ExitCode(ExitSuccess, ExitFailure))
import System.FilePath (makeRelative, splitDirectories)
import Debug.Trace (trace)
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)
instance (Error e, ServerMonad m) => ServerMonad (ErrorT e m) where
askRq = lift askRq
localRq f = mapErrorT $ localRq f
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 = outputTraceMessage 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 $ liftM 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){rsCode=404}
simpleHTTPWithSocket :: (ToMessage a) => Socket -> Conf -> ServerPartT IO a -> IO ()
simpleHTTPWithSocket = simpleHTTPWithSocket' id
simpleHTTPWithSocket' :: (ToMessage b, Monad m, Functor m) => (UnWebT m a -> UnWebT IO b)
-> Socket -> Conf -> ServerPartT m a -> IO ()
simpleHTTPWithSocket' toIO socket conf hs =
Listen.listen' socket conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req))
bindPort :: Conf -> IO Socket
bindPort conf = Listen.listenOn (port conf)
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
toResponseBS :: B.ByteString
-> L.ByteString
-> Response
toResponseBS contentType message =
let res = Response 200 M.empty nullRsFlags message Nothing
in setHeaderBS (B.pack "Content-Type") contentType res
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
dirs :: (ServerMonad m, MonadPlus m) => FilePath -> m a -> m a
dirs fp m =
do let parts = splitDirectories (makeRelative "/" fp)
foldr dir m parts
host :: (ServerMonad m, MonadPlus m) => String -> m a -> m a
host desiredHost handle =
do rq <- askRq
case getHeader "host" rq of
(Just hostBS) | desiredHost == B.unpack hostBS -> handle
_ -> mzero
withHost :: (ServerMonad m, MonadPlus m) => (String -> m a) -> m a
withHost handle =
do rq <- askRq
case getHeader "host" rq of
(Just hostBS) -> handle (B.unpack hostBS)
_ -> 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
trailingSlash :: (ServerMonad m, MonadPlus m) => m ()
trailingSlash = guardRq $ \rq -> (last (rqUri rq)) == '/'
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) =>
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 }
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)
expireCookie :: (FilterMonad Response m) => String -> m ()
expireCookie cookieName = addCookie 0 (mkCookie cookieName "")
ifModifiedSince :: CalendarTime
-> Request
-> Response
-> Response
ifModifiedSince modTime request response =
let repr = formatCalendarTime defaultTimeLocale "%a, %d %b %Y %X GMT" modTime
notmodified = getHeader "if-modified-since" request == Just (B.pack $ repr)
in if notmodified
then result 304 ""
else setHeader "Last-modified" repr response
modifyResponse :: (FilterMonad a m) => (a -> a) -> m()
modifyResponse = composeFilter
setResponseCode :: FilterMonad Response m => Int -> m ()
setResponseCode code
= composeFilter $ \r -> r{rsCode = code}
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 = escape $ do
setHeaderM headerName headerValue
unauthorized $ 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)
outputTraceMessage s c | "Pattern match failure " `isPrefixOf` s =
let w = [(k,p) | (i,p) <- zip (tails s) (inits s), Just k <- [stripPrefix " at " i]]
v = concatMap (\(k,p) -> k ++ ": " ++ p) w
in trace v c
outputTraceMessage _ c = trace "some error" c
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