HAppS-Server 0.9.2.1 → 0.9.3
raw patch · 12 files changed
+365/−75 lines, 12 filesdep +processdep +sybdep −regex-compatdep ~basedep ~parsecsetup-changed
Dependencies added: process, syb
Dependencies removed: regex-compat
Dependency ranges changed: base, parsec
Files
- COPYING +29/−0
- HAppS-Server.cabal +63/−42
- Setup.hs +1/−1
- src/HAppS/Server/HTTP/FileServe.hs +4/−1
- src/HAppS/Server/HTTP/Handler.hs +4/−4
- src/HAppS/Server/HTTP/Listen.hs +26/−8
- src/HAppS/Server/HTTP/Types.hs +9/−4
- src/HAppS/Server/HTTPClient/HTTP.hs +2/−1
- src/HAppS/Server/HTTPClient/Stream.hs +1/−1
- src/HAppS/Server/HTTPClient/TCP.hs +4/−3
- src/HAppS/Server/SimpleHTTP.hs +219/−7
- src/HAppS/Server/XSLT.hs +3/−3
+ COPYING view
@@ -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.
HAppS-Server.cabal view
@@ -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
Setup.hs view
@@ -1,2 +1,2 @@ import Distribution.Simple-main = defaultMainWithHooks defaultUserHooks+main = defaultMain
src/HAppS/Server/HTTP/FileServe.hs view
@@ -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))
src/HAppS/Server/HTTP/Handler.hs view
@@ -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<title> i2x.com </title>\n\n\n<H1> This is i2x.com </H1>\n\nContact <a href=\"mailto:contact20020212@i2x.com\">us.</a>\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
src/HAppS/Server/HTTP/Listen.hs view
@@ -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
src/HAppS/Server/HTTP/Types.hs view
@@ -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
src/HAppS/Server/HTTPClient/HTTP.hs view
@@ -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)
src/HAppS/Server/HTTPClient/Stream.hs view
@@ -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
src/HAppS/Server/HTTPClient/TCP.hs view
@@ -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
src/HAppS/Server/SimpleHTTP.hs view
@@ -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 _ = "<func>" +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)
src/HAppS/Server/XSLT.hs view
@@ -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