diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,29 @@ +Copyright (c) 2006, HAppS.org +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +Neither the name of the HAppS.org; nor the names of its contributors +may be used to endorse or promote products derived from this software +without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/HAppS-Server.cabal b/HAppS-Server.cabal --- a/HAppS-Server.cabal +++ b/HAppS-Server.cabal @@ -1,50 +1,71 @@ Name: HAppS-Server -Version: 0.9.2.1 +Version: 0.9.3 Synopsis: Web related tools and services. Description: Web framework License: BSD3 +License-file: COPYING Author: HAppS LLC Maintainer: AlexJacobson@HAppS.org Category: Web, Distributed Computing -Build-Depends: base, HaXml >= 1.13 && < 1.14, parsec, mtl, network, - regex-compat, hslogger >= 1.0.2, HAppS-Data>=0.9.2, HAppS-Util>=0.9.2, - HAppS-State>=0.9.2, HAppS-IxSet>=0.9.2, HTTP, template-haskell, xhtml, html, - bytestring, random, containers, old-time, old-locale, directory, unix Build-Type: Simple -hs-source-dirs: src -Exposed-modules: - HAppS.Server, - HAppS.Server.Cookie, - HAppS.Server.HTTP.Client, - HAppS.Server.HTTP.Types, - HAppS.Server.HTTP.LowLevel, - HAppS.Server.HTTP.FileServe, - HAppS.Server.SimpleHTTP, - HAppS.Server.JSON, - HAppS.Server.MessageWrap, - HAppS.Server.MinHaXML, - HAppS.Server.SURI, - HAppS.Server.XSLT, - HAppS.Server.Facebook - HAppS.Server.Cron - HAppS.Server.StdConfig - HAppS.Store.Util - HAppS.Store.FlashMsgs - HAppS.Store.HelpReqs -Other-modules: - HAppS.Server.S3, - HAppS.Server.HTTPClient.HTTP, - HAppS.Server.HTTPClient.Stream, - HAppS.Server.HTTPClient.TCP, - HAppS.Server.HTTP.Clock, - HAppS.Server.HTTP.Handler, - HAppS.Server.HTTP.LazyLiner, - HAppS.Server.HTTP.Listen, - HAppS.Server.HTTP.Multipart, - HAppS.Server.HTTP.RFC822Headers, - HAppS.Server.SURI.ParseURI --- Should have ", DeriveDataTypeable, PatternSignatures" but Cabal complains -Extensions: CPP, UndecidableInstances -cpp-options: -DUNIX -ghc-options: -W -fno-warn-incomplete-patterns -GHC-Prof-Options: -auto-all +Cabal-Version: >= 1.2 + +Flag base4 + Description: Choose the even newer, even smaller, split-up base package. + +Library + + Exposed-modules: + HAppS.Server, + HAppS.Server.Cookie, + HAppS.Server.HTTP.Client, + HAppS.Server.HTTP.Types, + HAppS.Server.HTTP.LowLevel, + HAppS.Server.HTTP.FileServe, + HAppS.Server.SimpleHTTP, + HAppS.Server.JSON, + HAppS.Server.MessageWrap, + HAppS.Server.MinHaXML, + HAppS.Server.SURI, + HAppS.Server.XSLT, + HAppS.Server.Facebook + HAppS.Server.Cron + HAppS.Server.StdConfig + HAppS.Store.Util + HAppS.Store.FlashMsgs + HAppS.Store.HelpReqs + Other-modules: + HAppS.Server.S3, + HAppS.Server.HTTPClient.HTTP, + HAppS.Server.HTTPClient.Stream, + HAppS.Server.HTTPClient.TCP, + HAppS.Server.HTTP.Clock, + HAppS.Server.HTTP.Handler, + HAppS.Server.HTTP.LazyLiner, + HAppS.Server.HTTP.Listen, + HAppS.Server.HTTP.Multipart, + HAppS.Server.HTTP.RFC822Headers, + HAppS.Server.SURI.ParseURI + if impl(ghc >= 6.10) + Build-Depends: parsec < 3, syb + else + Build-Depends: parsec >= 3 && < 4 + Build-Depends: base, HaXml >= 1.13 && < 1.14, parsec, mtl, network, + hslogger >= 1.0.2, HAppS-Data>=0.9.2, HAppS-Util>=0.9.2, + HAppS-State>=0.9.2, HAppS-IxSet>=0.9.2, HTTP, template-haskell, xhtml, html, + bytestring, random, containers, old-time, old-locale, directory, process + hs-source-dirs: src + + if !os(windows) + Build-Depends: unix + cpp-options: -DUNIX + if flag(base4) + Build-Depends: base >=4 + cpp-options: -DEXCEPTION_TYPE=SomeException -DEXTENSIBLE_EXCEPTIONS + else + cpp-options: -DEXCEPTION_TYPE=Exception + + -- Should have ", DeriveDataTypeable, PatternSignatures" but Cabal complains + Extensions: CPP, UndecidableInstances + ghc-options: -W -fno-warn-incomplete-patterns + GHC-Prof-Options: -auto-all diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks +main = defaultMain diff --git a/src/HAppS/Server/HTTP/FileServe.hs b/src/HAppS/Server/HTTP/FileServe.hs --- a/src/HAppS/Server/HTTP/FileServe.hs +++ b/src/HAppS/Server/HTTP/FileServe.hs @@ -5,6 +5,9 @@ ) where import Control.Exception +#ifdef EXTENSIBLE_EXCEPTIONS +import Control.OldException (ioErrors) +#endif import Control.Monad.Reader import Control.Monad.Trans import Data.List @@ -135,7 +138,7 @@ -- when (isJust $ getHeader "if-modified-since" rq) $ error $ show $ getHeader "if-modified-since" rq if notmodified then do setResponseCode 304 ; return $ toResponse "" else do let mod = getHeader "if-modified-since" rq - modifyResponse (setHeader "HUH" $ show $ (fmap P.unpack mod == Just repr,mod,Just repr)) +-- modifyResponse (setHeader "HUH" $ show $ (fmap P.unpack mod == Just repr,mod,Just repr)) modifyResponse (setHeader "Last-modified" repr) -- if %Z or UTC are in place of GMT below, wget complains that the last-modified header is invalid modifyResponse (setHeader "Content-Length" (show size)) diff --git a/src/HAppS/Server/HTTP/Handler.hs b/src/HAppS/Server/HTTP/Handler.hs --- a/src/HAppS/Server/HTTP/Handler.hs +++ b/src/HAppS/Server/HTTP/Handler.hs @@ -66,7 +66,7 @@ return $ consumeChunks restStr | otherwise -> return (L.splitAt (fromIntegral contentLength) restStr) let cookies = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" headers)), c <- cl ] -- Ugle - rqTmp = Request m (pathEls (path u)) (query u) + rqTmp = Request m (pathEls (path u)) (path u) (query u) [] cookies v headers (Body body) host rq = rqTmp{rqInputs = queryInput u ++ bodyInput rqTmp} return (rq, nextRequest) @@ -75,7 +75,7 @@ Right (req, rest) -> return $ -- logMH (show req) >> do let ioseq act = act >>= \x -> x `seq` return x - res <- ioseq (handler req) `E.catch` \e -> return $ result 500 $ "Server error: " ++ show e + res <- ioseq (handler req) `E.catch` \(e::E.EXCEPTION_TYPE) -> return $ result 500 $ "Server error: " ++ show e putAugmentedResult h req res when (continueHTTP req res) $ rloop conf h host handler rest @@ -95,7 +95,7 @@ else return $ consumeChunks restStr) (\cl->return (L.splitAt (fromIntegral cl) restStr)) mbCL - return $ Response {rsCode=code,rsHeaders=headers,rsBody=body,rsFlags=RsFlags True} + return $ Response {rsCode=code,rsHeaders=headers,rsBody=body,rsFlags=RsFlags True,rsValidator=Nothing} val = "71 \r\n\n i2x.com \n\n\n

This is i2x.com

\n\nContact us.\n\r\n0\r\n\r\n" testChunk x = x == (L.unpack $ fst $ consumeChunks $ L.pack x) @@ -286,7 +286,7 @@ dateC = P.pack "Date" dateCLower = P.map toLower dateC serverC = P.pack "Server" -happsC = P.pack "HAppS/0.8.4" +happsC = P.pack "HAppS/0.9.2" textHtmlC = P.pack "text/html; charset=utf-8" -- Response code names diff --git a/src/HAppS/Server/HTTP/Listen.hs b/src/HAppS/Server/HTTP/Listen.hs --- a/src/HAppS/Server/HTTP/Listen.hs +++ b/src/HAppS/Server/HTTP/Listen.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -cpp #-} +{-# OPTIONS -cpp -XPatternSignatures #-} module HAppS.Server.HTTP.Listen(listen) where import System.Log.Logger @@ -11,8 +11,6 @@ import Network import System.IO -import HAppS.Util.Exception - {- #ifndef mingw32_HOST_OS -} @@ -32,7 +30,7 @@ -} s <- listenOn $ PortNumber $ toEnum $ port conf let work (h,hn,p) = do -- hSetBuffering h NoBuffering - let eh x = logM "HAppS.Server.HTTP.Listen" ERROR ("HTTP request failed with: "++show x) + let eh (x::EXCEPTION_TYPE) = logM "HAppS.Server.HTTP.Listen" ERROR ("HTTP request failed with: "++show x) request conf h (hn,fromIntegral p) hand `E.catch` eh hClose h let msg = "\nIPV6 is not supported yet. \nLikely you made a localhost request \n"++ @@ -41,8 +39,28 @@ loop = do accept s >>= forkIO . work loop -- let loop = accept s >>= forkIO . work >> loop - let pe e = do logM "HAppS.Server.HTTP.Listen" ERROR ("ERROR in accept thread: "++show e) - hPutStr stderr msg - let infi = (loop `catchSome` pe) >> infi + let pe e = logM "HAppS.Server.HTTP.Listen" ERROR ("ERROR in accept thread: "++ + show e) + let infi = loop `catchSome` pe >> infi -- loop `E.catch` pe >> infi infi `finally` sClose s - +{-- +#ifndef mingw32_HOST_OS +-} + installHandler openEndedPipe Ignore Nothing + return () +{- +#endif +-} + where -- why are these handlers needed? +#ifdef EXTENSIBLE_EXCEPTIONS + -- catchSome op h :: IO () -> (E.SomeExcpetion -> IO () ) -> IO () + catchSome op h = op `E.catches` [ + Handler $ \(e :: ArithException) -> h (toException e), + Handler $ \(e :: ArrayException) -> h (toException e) + ] +#else + catchSome = E.catchJust interestingExceptions + interestingExceptions x@(ArithException _) = Just x + interestingExceptions x@(ArrayException _) = Just x + interestingExceptions _ = Nothing +#endif diff --git a/src/HAppS/Server/HTTP/Types.hs b/src/HAppS/Server/HTTP/Types.hs --- a/src/HAppS/Server/HTTP/Types.hs +++ b/src/HAppS/Server/HTTP/Types.hs @@ -29,6 +29,7 @@ import HAppS.Server.Cookie import HAppS.Util.Common (Seconds) import Data.List +import Text.Show.Functions () -- lowercase pack --lpack = (P.map toLower) . P.pack @@ -49,8 +50,10 @@ -- | HTTP configuration data Conf = Conf { port :: Int -- ^ Port for the server to listen on. - } deriving(Show) + , validator :: Maybe (Response -> IO Response) + } -- deriving(Show) nullConf = Conf { port = 8000 + , validator = Nothing } @@ -87,10 +90,12 @@ data Response = Response { rsCode :: Int, rsHeaders :: Headers, rsFlags :: RsFlags, - rsBody :: L.ByteString - } deriving(Show,Read,Typeable) + rsBody :: L.ByteString, + rsValidator:: Maybe (Response -> IO Response) + } deriving (Show,Typeable) -- deriving(Show,Read,Typeable) data Request = Request { rqMethod :: Method, rqPaths :: [String], + rqUri :: String, rqQuery :: String, rqInputs :: [(String,Input)], rqCookies :: [(String,Cookie)], @@ -224,7 +229,7 @@ result code s = resultBS code (L.pack s) resultBS :: Int -> L.ByteString -> Response -resultBS code s = Response code M.empty nullRsFlags s +resultBS code s = Response code M.empty nullRsFlags s Nothing setLocationHeader :: ToSURI uri => uri -> Response -> Response diff --git a/src/HAppS/Server/HTTPClient/HTTP.hs b/src/HAppS/Server/HTTPClient/HTTP.hs --- a/src/HAppS/Server/HTTPClient/HTTP.hs +++ b/src/HAppS/Server/HTTPClient/HTTP.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternSignatures #-} ----------------------------------------------------------------------------- -- | -- Module : HAppS.Server.HTTPClient.HTTP @@ -728,7 +729,7 @@ sendHTTPPipelined :: Stream s => s -> [Request] -> IO ([Response],Maybe ConnError) sendHTTPPipelined conn rqs = do { (ok,rsp) <- Exception.catch (main (map fixHostHeader rqs)) - (\e -> do { close conn; throw e }) + (\(e::EXCEPTION_TYPE) -> do { close conn; throw e }) ; let fn list = when (or $ map findConnClose list) (close conn) ; fn (map rqHeaders rqs ++ map rspHeaders ok) diff --git a/src/HAppS/Server/HTTPClient/Stream.hs b/src/HAppS/Server/HTTPClient/Stream.hs --- a/src/HAppS/Server/HTTPClient/Stream.hs +++ b/src/HAppS/Server/HTTPClient/Stream.hs @@ -80,7 +80,7 @@ -- Exception handler for socket operations -handleSocketError :: Socket -> Exception -> IO (Result a) +handleSocketError :: Socket -> Exception.EXCEPTION_TYPE -> IO (Result a) handleSocketError sk e = do { se <- getSocketOption sk SoError ; if se == 0 diff --git a/src/HAppS/Server/HTTPClient/TCP.hs b/src/HAppS/Server/HTTPClient/TCP.hs --- a/src/HAppS/Server/HTTPClient/TCP.hs +++ b/src/HAppS/Server/HTTPClient/TCP.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternSignatures #-} ----------------------------------------------------------------------------- -- | -- Module : HAppS.Server.HTTPClient.TCP @@ -75,12 +76,12 @@ do { s <- socket AF_INET Stream 6 ; setSocketOption s KeepAlive 1 ; host <- Exception.catch (inet_addr uri) -- handles ascii IP numbers - (\_ -> getHostByName uri >>= \host -> + (\(_::EXCEPTION_TYPE) -> getHostByName uri >>= \host -> -- *shrug* this will catch *any* exception FIXME case hostAddresses host of [] -> return (error "no addresses in host entry") (h:_) -> return h) ; let a = SockAddrInet (toEnum port) host - ; Exception.catch (connect s a) (\e -> sClose s >> throw e) + ; Exception.catch (connect s a) (\(e::EXCEPTION_TYPE) -> sClose s >> throw e) ; v <- newIORef (MkConn s a [] uri) ; return (ConnRef v) } @@ -157,7 +158,7 @@ -- (I think the behaviour here is TCP specific) close ref = do { c <- readIORef (getRef ref) - ; closeConn c `Exception.catch` (\_ -> return ()) + ; closeConn c `Exception.catch` (\(_::EXCEPTION_TYPE) -> return ()) -- FIXME see above ; writeIORef (getRef ref) ConnClosed } where diff --git a/src/HAppS/Server/SimpleHTTP.hs b/src/HAppS/Server/SimpleHTTP.hs --- a/src/HAppS/Server/SimpleHTTP.hs +++ b/src/HAppS/Server/SimpleHTTP.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances #-} +{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -XPatternSignatures #-} ----------------------------------------------------------------------------- -- | -- Module : HAppS.Server.SimpleHTTP @@ -87,6 +87,17 @@ , 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 @@ -101,10 +112,15 @@ 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 @@ -117,7 +133,9 @@ 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 @@ -130,15 +148,21 @@ 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 Show (a -> b) where - 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 @@ -151,12 +175,38 @@ 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) @@ -165,7 +215,11 @@ 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 @@ -188,7 +242,7 @@ -- | 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 (simpleHTTP' 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 @@ -246,7 +300,7 @@ toResponse:: a -> Response toResponse val = let bs = toMessage val - result = Response 200 M.empty nullRsFlags bs + result = Response 200 M.empty nullRsFlags bs Nothing in setHeaderBS (B.pack "Content-Type") (toContentType val) result @@ -430,9 +484,11 @@ 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 } @@ -529,10 +585,11 @@ 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 + -- liftIO $ print rq >> print resp return resp] anyRequest :: Monad m => WebT m a -> ServerPartT m a @@ -553,7 +610,7 @@ headerName = "WWW-Authenticate" headerValue = "Basic realm=\"" ++ realmName ++ "\"" err = escape $ - do unauthorized "Not authorized" + do unauthorized $ addHeader headerName headerValue $ toResponse "Not authorized" -------------------------------------------------------------- @@ -593,3 +650,158 @@ 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) diff --git a/src/HAppS/Server/XSLT.hs b/src/HAppS/Server/XSLT.hs --- a/src/HAppS/Server/XSLT.hs +++ b/src/HAppS/Server/XSLT.hs @@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell, FlexibleInstances , UndecidableInstances, - DeriveDataTypeable, MultiParamTypeClasses, CPP #-} + DeriveDataTypeable, MultiParamTypeClasses, CPP, PatternSignatures #-} -- | Implement XSLT transformations using xsltproc module HAppS.Server.XSLT (xsltFile, xsltString, xsltElem, xsltFPS, xsltFPSIO, XSLPath, @@ -11,7 +11,7 @@ import HAppS.Server.MinHaXML import HAppS.Util.Common(runCommand) -import Control.Exception(bracket,try) +import Control.Exception(bracket,try,EXCEPTION_TYPE) import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.Lazy.Char8 as L import System.Directory(removeFile) @@ -138,4 +138,4 @@ tryAny :: [IO a] -> IO a -> IO a tryAny [] c = c -tryAny (x:xs) c = either (\_ -> tryAny xs c) return =<< try x +tryAny (x:xs) c = either (\(_::EXCEPTION_TYPE) -> tryAny xs c) return =<< try x