{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -XPatternSignatures #-} ----------------------------------------------------------------------------- -- | -- Module : HAppS.Server.SimpleHTTP -- Copyright : (c) HAppS Inc 2007 -- License : BSD-like -- -- Maintainer : lemmih@vo.com -- Stability : provisional -- Portability : requires mtl -- -- SimpleHTTP provides a back-end independent API for handling HTTP requests. -- -- By default, the built-in HTTP server will be used. However, other back-ends -- like CGI\/FastCGI can used if so desired. ----------------------------------------------------------------------------- module HAppS.Server.SimpleHTTP ( module HAppS.Server.HTTP.Types , module HAppS.Server.Cookie , -- * SimpleHTTP simpleHTTP -- , simpleHTTP' , parseConfig , FromReqURI(..) , RqData , FromData(..) , ToMessage(..) , ServerPart , ServerPartT(..) , Web , WebT(..) , Result(..) , noHandle , escape -- * ServerPart primitives. , webQuery , webUpdate , flatten , localContext , dir -- :: String -> [ServerPart] -> ServerPart , method -- :: MatchMethod m => m -> IO Result -> ServerPart , methodSP -- , method' -- :: MatchMethod m => m -> IO (Maybe Result) -> ServerPart , path -- :: FromReqURI a => (a -> [ServerPart]) -> ServerPart , proxyServe , rproxyServe -- , limProxyServe , uriRest , anyPath , anyPath' , withData -- :: FromData a => (a -> [ServerPart]) -> ServerPart , withDataFn -- , modXml , require -- :: IO (Maybe a) -> (a -> [ServerPart]) -> ServerPart , multi -- :: [ServerPart] -> ServerPart , withRequest -- :: (Request -> IO Result) -> ServerPart , debugFilter , anyRequest , applyRequest , modifyResponse , setResponseCode , basicAuth -- * Creating Results. , ok -- :: ToMessage a => a -> IO Result -- , mbOk , badGateway , internalServerError , badRequest , unauthorized , forbidden , notFound , seeOther , found , movedPermanently , tempRedirect , addCookie , addCookies -- * Parsing input and cookies , lookInput -- :: String -> Data Input , lookBS -- :: String -> Data B.ByteString , look -- :: String -> Data String , lookCookie -- :: String -> Data Cookie , lookCookieValue -- :: String -> Data String , readCookieValue -- :: Read a => String -> Data a , lookRead -- :: Read a => String -> Data a , lookPairs -- * XSLT , xslt ,doXslt -- * Error Handlng , errorHandlerSP , simpleErrorHandler -- * Output Validation , setValidator , setValidatorSP , validateConf , runValidator , wdgHTMLValidator , noopValidator , lazyProcValidator ) where import HAppS.Server.HTTP.Client import HAppS.Data.Xml.HaXml import qualified HAppS.Server.MinHaXML as H import HAppS.Server.HTTP.Types hiding (Version(..)) import qualified HAppS.Server.HTTP.Types as Types import HAppS.Server.HTTP.Listen import HAppS.Server.XSLT import HAppS.Server.SURI (ToSURI) import HAppS.Util.Common import HAppS.Server.Cookie import HAppS.State (QueryEvent, UpdateEvent, query, update) import HAppS.Data -- used by default implementation of fromData 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.Concurrent 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 HAppS.Crypto.Base64 as Base64 import Data.Char import Data.List import System.IO import System.Environment 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 :: Request -> WebT m a } instance (Monad m) => Monad (ServerPartT m) where f >>= g = ServerPartT $ \rq -> do a <- unServerPartT f rq unServerPartT (g a) rq return x = ServerPartT $ \_ -> return x instance (MonadIO m) => MonadIO (ServerPartT m) where liftIO m = ServerPartT $ const (liftIO m) newtype WebT m a = WebT { unWebT :: m (Result a) } data Result a = NoHandle | Ok (Response -> Response) a | Escape Response deriving Show instance Functor Result where fmap fn NoHandle = NoHandle fmap fn (Ok out a) = Ok out (fn a) fmap fn (Escape resp) = Escape resp instance Monad m => Monad (WebT m) where f >>= g = WebT $ do r <- unWebT f case r of NoHandle -> return NoHandle Escape resp -> return $ Escape resp Ok out a -> do r' <- unWebT (g a) case r' of NoHandle -> return NoHandle Escape resp -> return $ Escape resp Ok out' a' -> return $ Ok (out' . out) a' return x = WebT $ return (Ok id x) instance (Monad m) => Monoid (ServerPartT m a) where mempty = ServerPartT $ \rq -> noHandle mappend a b = ServerPartT $ \rq -> (unServerPartT a rq) `mappend` (unServerPartT b rq) instance (Monad m) => Monoid (WebT m a) where mempty = noHandle mappend a b = WebT $ do a' <- unWebT a case a' of NoHandle -> unWebT b _ -> return a' instance MonadTrans WebT where lift m = WebT (liftM (Ok id) m) instance MonadIO m => MonadIO (WebT m) where liftIO m = WebT (liftM (Ok id) $ liftIO m) instance Functor m => Functor (WebT m) where fmap fn (WebT m) = WebT $ fmap (fmap fn) m instance Functor m => Functor (ServerPartT m) where fmap fn (ServerPartT m) = ServerPartT $ fmap (fmap fn) m instance (Monad m, Functor m) => Applicative (ServerPartT m) where pure = return (<*>) = ap 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 = WebT $ local fn (unWebT 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 = WebT $ throwError err catchError action handler = WebT $ catchError (unWebT action) (unWebT . handler) noHandle :: Monad m => WebT m a noHandle = WebT $ return NoHandle escape :: (Monad m, ToMessage resp) => WebT m resp -> WebT m a escape gen = WebT $ do res <- unWebT gen case res of NoHandle -> return NoHandle Escape resp -> return $ Escape resp Ok out a -> return $ Escape $ out $ toResponse 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 -- | Use the built-in web-server to serve requests according to list of @ServerParts@. simpleHTTP :: ToMessage a => Conf -> [ServerPartT IO a] -> IO () simpleHTTP conf hs = listen conf (\req -> runValidator (fromMaybe return (validator conf)) =<< simpleHTTP' hs req) -- | Generate a result from a list of @ServerParts@ and a @Request@. This is mainly used -- by CGI (and fast-cgi) wrappers. simpleHTTP' :: (ToMessage a, Monad m) => [ServerPartT m a] -> Request -> m Response simpleHTTP' hs req = do res <- unWebT (unServerPartT (multi hs) req) case res of NoHandle -> return $ result 404 "No suitable handler found" Escape resp -> return resp Ok out a -> return $ out $ toResponse a 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" -- fromData = lookPairs >>= return . normalize . fromPairs 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 {- | Minimal definition: 'toMessage' -} class ToMessage a where toContentType :: a -> B.ByteString toContentType _ = B.pack "text/plain" toMessage :: a -> L.ByteString toMessage = error "HAppS.Server.SimpleHTTP.ToMessage.toMessage: Not defined" toResponse:: a -> Response toResponse val = let bs = toMessage val result = Response 200 M.empty nullRsFlags bs Nothing in setHeaderBS (B.pack "Content-Type") (toContentType val) result instance ToMessage [Element] where toContentType _ = B.pack "application/xml" toMessage [el] = L.pack $ H.simpleDoc H.NoStyle $ toHaXmlEl el -- !! OPTIMIZE toMessage x = error ("HAppS.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 -- toMessageM = toMessageM . toPublicXml class MatchMethod m where matchMethod :: m -> Method -> Bool instance MatchMethod Method where matchMethod method = (== method) instance MatchMethod [Method] where matchMethod methods = (`elem` methods) instance MatchMethod (Method -> Bool) where matchMethod f = f instance MatchMethod () where matchMethod () _ = True webQuery :: (MonadIO m, QueryEvent ev res) => ev -> WebT m res webQuery = liftIO . query webUpdate :: (MonadIO m, UpdateEvent ev res) => ev -> WebT m res webUpdate = liftIO . update flatten :: (ToMessage a, Monad m) => ServerPartT m a -> ServerPartT m Response flatten = liftM toResponse localContext :: Monad m => (WebT m a -> WebT m' a) -> [ServerPartT m a] -> ServerPartT m' a localContext fn hs = ServerPartT $ \rq -> fn (unServerPartT (multi hs) rq) -- | Pop a path element and run the @[ServerPart]@ if it matches the given string. dir :: Monad m => String -> [ServerPartT m a] -> ServerPartT m a dir staticPath handle = ServerPartT $ \rq -> case rqPaths rq of (path:xs) | path == staticPath -> unServerPartT (multi handle) rq{rqPaths = xs} _ -> noHandle -- | Guard against the method. Note, this function also guards against any -- remaining path segments. See 'anyRequest'. methodSP :: (MatchMethod method, Monad m) => method -> ServerPartT m a -> ServerPartT m a methodSP m handle = ServerPartT $ \rq -> if matchMethod m (rqMethod rq) && null (rqPaths rq) then unServerPartT handle rq else noHandle -- | Guard against the method. Note, this function also guards against any -- remaining path segments. See 'anyRequest'. method :: (MatchMethod method, Monad m) => method -> WebT m a -> ServerPartT m a method m handle = methodSP m (ServerPartT $ \_ -> handle) -- | Pop a path element and parse it. path :: (FromReqURI a, Monad m) => (a -> [ServerPartT m r]) -> ServerPartT m r path handle = ServerPartT $ \rq -> case rqPaths rq of (path:xs) | Just a <- fromReqURI path -> unServerPartT (multi $ handle a) rq{rqPaths = xs} _ -> noHandle uriRest :: Monad m => (String -> ServerPartT m a) -> ServerPartT m a uriRest handle = withRequest $ \rq -> unServerPartT (handle (rqURL rq)) rq anyPath x = path $ (\(_::String) -> x) anyPath' x = path $ (\(_::String) -> [x]) -- | Retrieve date from the input query or the cookies. withData :: (FromData a, Monad m) => (a -> [ServerPartT m r]) -> ServerPartT m r withData = withDataFn fromData withDataFn :: Monad m => RqData a -> (a -> [ServerPartT m r]) -> ServerPartT m r withDataFn fn handle = ServerPartT $ \rq -> case runReaderT fn (rqInputs rq,rqCookies rq) of Nothing -> noHandle Just a -> unServerPartT (multi $ handle a) rq proxyServe :: MonadIO m => [String] -> ServerPartT m Response proxyServe allowed = withRequest $ \rq -> if cond rq then proxyServe' rq else noHandle 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' rq = liftIO (getResponse (unproxify rq)) >>= either (badGateway . toResponse . show) (escape . return) 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 . return) {- modXml:: (Monad m) => (Request -> Element -> m Element) -> [ServerPartT m a] -> ServerPartT m a modXml f handle = Reader $ \rq -> do res <- runReader (multi handle) rq case res of Nothing -> return Nothing Just res'@(Left _) -> return $ Just res' Just res'@(Right (s,el)) -> (\el->return $ Just $ Right (s,el)) =<< f rq el -} -- | Run an IO action and, if it returns @Just@, pass it to the second argument. require :: MonadIO m => IO (Maybe a) -> (a -> [ServerPartT m r]) -> ServerPartT m r require fn = requireM (liftIO fn) requireM :: Monad m => m (Maybe a) -> (a -> [ServerPartT m r]) -> ServerPartT m r requireM fn handle = ServerPartT $ \rq -> do mbVal <- lift fn case mbVal of Nothing -> noHandle Just a -> unServerPartT (multi $ handle a) rq showRequest = Reader $ \rq -> print (rq::Request) -- FIXME: What to do with Escapes? -- | Use @cmd@ to transform XML against @xslPath@. -- This function only acts if the content-type is @application\/xml@. xslt :: (MonadIO m, ToMessage r) => XSLTCmd -- ^ XSLT preprocessor. Usually 'xsltproc' or 'saxon'. -> XSLPath -- ^ Path to xslt stylesheet. -> [ServerPartT m r] -- ^ Affected @ServerParts@. -> ServerPartT m Response xslt cmd xslPath parts = withRequest $ \rq -> do res <- unServerPartT (multi parts) rq if toContentType res == B.pack "application/xml" then liftM toResponse (doXslt cmd xslPath (toResponse res)) else return (toResponse res) doXslt cmd xslPath res = do new <- liftIO $ procLBSIO cmd xslPath $ rsBody res {- liftIO $ print res liftIO $ print "##########" liftIO $ print new -} return $ setHeader "Content-Type" "text/html" $ setHeader "Content-Length" (show $ L.length new) $ res { rsBody = new } --io :: IO Result -> ServerPart --io action = ReaderT $ \_ -> Just action modifyResponse :: Monad m => (Response -> Response) -> WebT m () modifyResponse modFn = WebT $ return $ Ok modFn () setResponseCode :: Monad m => Int -> WebT m () setResponseCode code = modifyResponse $ \resp -> resp{rsCode = code} addCookie :: Monad m => Seconds -> Cookie -> WebT m () addCookie sec cookie = modifyResponse $ addHeader "Set-Cookie" (mkCookieHeader sec cookie) addCookies :: Monad m => [(Seconds, Cookie)] -> WebT m () addCookies = mapM_ (uncurry addCookie) {- delCookie :: String -> WebT m () delCookie name = -} resp status val = setResponseCode status >> return val {-- do bs <- toMessageM val liftM (setHeaderBS (B.pack "Content-Type") (toContentType val)) $ sresult' status bs --} {- mbOk :: ToMessage b => (a -> b) -> Maybe a -> IO Result -> IO Result mbOk f val other = maybe other (ok . f) val -} -- | Respond with @200 OK@. ok :: Monad m => a -> WebT m a ok = resp 200 internalServerError::Monad m => a -> WebT m a internalServerError = resp 500 badGateway::Monad m=> a-> WebT m a badGateway = resp 502 -- | Respond with @400 Bad Request@. badRequest :: Monad m => a -> WebT m a badRequest = resp 400 -- | Respond with @401 Unauthorized@. unauthorized :: Monad m => a -> WebT m a unauthorized val = resp 401 val -- | Respond with @403 Forbidden@. forbidden :: Monad m => a -> WebT m a forbidden val = resp 403 val -- | Respond with @404 Not Found@. notFound :: Monad m => a -> WebT m a notFound val = resp 404 val -- | Respond with @303 See Other@. seeOther :: (Monad m, ToSURI uri) => uri -> res -> WebT m res seeOther uri res = do modifyResponse $ redirect 303 uri return res -- | Respond with @302 Found@. found :: (Monad m, ToSURI uri) => uri -> res -> WebT m res found uri res = do modifyResponse $ redirect 302 uri return res -- | Respond with @301 Moved Permanently@. movedPermanently :: (Monad m, ToSURI a) => a -> res -> WebT m res movedPermanently uri res = do modifyResponse $ redirect 301 uri return res -- | Respond with @307 Temporary Redirect@. tempRedirect :: (Monad m, ToSURI a) => a -> res -> WebT m res tempRedirect val res = do modifyResponse $ redirect 307 val return res multi :: Monad m => [ServerPartT m a] -> ServerPartT m a multi ls = ServerPartT $ \rq -> foldr servPlus noHandle [ unServerPartT l rq | l <- ls ] where servPlus a b = WebT $ do a' <- unWebT a case a' of NoHandle -> unWebT b _ -> return a' withRequest :: (Request -> WebT m a) -> ServerPartT m a withRequest fn = ServerPartT $ fn debugFilter :: (MonadIO m, Show a) => [ServerPartT m a] -> [ServerPartT m a] debugFilter handle = [ ServerPartT $ \rq -> WebT $ do resp <- unWebT (unServerPartT (multi handle) rq) -- liftIO $ print rq >> print resp return resp] anyRequest :: Monad m => WebT m a -> ServerPartT m a anyRequest x = withRequest $ \_ -> x applyRequest hs = simpleHTTP' hs >>= return . Left basicAuth :: (MonadIO m) => String -> M.Map String String -> [ServerPartT m a] -> ServerPartT m a basicAuth realmName authMap xs = multi $ basicAuthImpl:xs where basicAuthImpl = withRequest $ \rq -> case getHeader "authorization" rq of Nothing -> err Just x -> case parseHeader x of (name, ':':pass) | validLogin name pass -> noHandle _ -> err validLogin name pass = M.lookup name authMap == Just pass parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6 headerName = "WWW-Authenticate" headerValue = "Basic realm=\"" ++ realmName ++ "\"" err = escape $ do unauthorized $ addHeader headerName headerValue $ toResponse "Not authorized" -------------------------------------------------------------- -- Query/Post data validating -------------------------------------------------------------- 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 -- keys are lowercased 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)) -------------------------------------------------------------- -- Error Handling -------------------------------------------------------------- -- | This ServerPart modifier enables the use of throwError and catchError inside the -- WebT actions, by adding the ErrorT monad transformer to the stack. -- -- You can wrap the complete second argument to 'simpleHTTP' in this function. -- -- See 'simpleErrorHandler' for an example error handler. errorHandlerSP :: (Monad m, Error e) => (Request -> e -> WebT m a) -> [ServerPartT (ErrorT e m) a] -> [ServerPartT m a] errorHandlerSP handler sps = [ ServerPartT $ \req -> WebT $ do eer <- runErrorT $ unWebT $ unServerPartT (multi sps) req case eer of Left err -> unWebT (handler req err) Right res -> return res ] -- | An example error Handler to be used with 'errorHandlerSP', which returns the -- error message as a plain text message to the browser. -- -- Another possibility is to store the error message, e.g. as a FlashMsg, and -- then redirect the user somewhere. simpleErrorHandler :: (Monad m) => Request -> String -> WebT m Response simpleErrorHandler _ err = ok $ toResponse $ ("An error occured: " ++ err) -------------------------------------------------------------- -- * Output validation -------------------------------------------------------------- -- |Set the validator which should be used for this particular 'Response' -- when validation is enabled. -- -- Calling this function does not enable validation. That can only be -- done by enabling the validation in the 'Conf' that is passed to -- 'simpleHTTP'. -- -- You do not need to call this function if the validator set in -- 'Conf' does what you want already. -- -- Example: (use 'noopValidator' instead of the default supplied by 'validateConf') -- -- @ -- simpleHTTP validateConf [ anyRequest $ ok . setValidator noopValidator =<< htmlPage ] -- @ -- -- See also: 'validateConf', 'wdgHTMLValidator', 'noopValidator', 'lazyProcValidator' setValidator :: (Response -> IO Response) -> Response -> Response setValidator v r = r { rsValidator = Just v } -- |ServerPart version of 'setValidator' -- -- Example: (Set validator to 'noopValidator') -- -- @ -- simpleHTTP validateConf $ [ setValidatorSP noopValidator (dir "ajax" [ ... ])] -- @ -- -- See also: 'setValidator' setValidatorSP :: (ToMessage r) => (Response -> IO Response) -> ServerPartT IO r -> ServerPartT IO Response setValidatorSP v sp = return . setValidator v . toResponse =<< sp -- |This extends 'nullConf' by enabling validation and setting -- 'wdgHTMLValidator' as the default validator for @text\/html@. -- -- Example: -- -- @ -- simpleHTTP validateConf [ anyRequest $ ok htmlPage ] -- @ validateConf :: Conf validateConf = nullConf { validator = Just wdgHTMLValidator } -- |Actually perform the validation on a 'Response' -- -- Run the validator specified in the 'Response'. If none is provide -- use the supplied default instead. -- -- Note: This function will run validation unconditionally. You -- probably want 'setValidator' or 'validateConf'. runValidator :: (Response -> IO Response) -> Response -> IO Response runValidator defaultValidator resp = case rsValidator resp of Nothing -> defaultValidator resp (Just altValidator) -> altValidator resp -- |Validate @text\/html@ content with @WDG HTML Validator@. -- -- This function expects the executable to be named @validate@ -- and it must be in the default @PATH@. -- -- See also: 'setValidator', 'validateConf', 'lazyProcValidator' wdgHTMLValidator :: (MonadIO m, ToMessage r) => r -> m Response wdgHTMLValidator = liftIO . lazyProcValidator "validate" ["-w","--verbose"] Nothing Nothing handledContentTypes . toResponse where handledContentTypes (Just ct) = elem (B.unpack ct) [ "text/html", "application/xhtml+xml" ] handledContentTypes Nothing = False -- |A validator which always succeeds. -- -- Useful for selectively disabling validation. For example, if you -- are sending down HTML fragments to an AJAX application and the -- default validator only understands complete documents. noopValidator :: Response -> IO Response noopValidator = return -- |Validate the 'Response' using an external application. -- -- If the external application returns 0, the original response is -- returned unmodified. If the external application returns non-zero, a 'Response' -- containing the error messages and original response body is -- returned instead. -- -- This function also takes a predicate filter which is applied to the -- content-type of the response. The filter will only be applied if -- the predicate returns true. -- -- NOTE: This function requirse the use of -threaded to avoid blocking. -- However, you probably need that for HAppS anyway. -- -- See also: 'wdgHTMLValidator' lazyProcValidator :: FilePath -- ^ name of executable -> [String] -- ^ arguements to pass to the executable -> Maybe FilePath -- ^ optional path to working directory -> Maybe [(String, String)] -- ^ optional environment (otherwise inherit) -> (Maybe B.ByteString -> Bool) -- ^ content-type filter -> Response -- ^ Response to validate -> 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])) showLines :: L.ByteString -> [String] showLines string = column : zipWith (\n -> \l -> show n ++ " " ++ (L.unpack l)) [1..] (L.lines string)