happstack-server 0.4.1 → 0.5.0
raw patch · 13 files changed
+419/−361 lines, 13 filesdep ~happstack-datadep ~happstack-utildep ~parsecsetup-changed
Dependency ranges changed: happstack-data, happstack-util, parsec
Files
- Setup.hs +1/−1
- happstack-server.cabal +5/−5
- src/Happstack/Server/Cookie.hs +3/−6
- src/Happstack/Server/HTTP/FileServe.hs +21/−20
- src/Happstack/Server/HTTP/Handler.hs +38/−13
- src/Happstack/Server/HTTP/Listen.hs +33/−4
- src/Happstack/Server/HTTP/Types.hs +0/−1
- src/Happstack/Server/HTTPClient/HTTP.hs +0/−2
- src/Happstack/Server/HTTPClient/TCP.hs +0/−1
- src/Happstack/Server/MessageWrap.hs +0/−2
- src/Happstack/Server/MinHaXML.hs +0/−1
- src/Happstack/Server/Parts.hs +0/−1
- src/Happstack/Server/SimpleHTTP.hs +318/−304
Setup.hs view
@@ -1,3 +1,3 @@ #!/usr/bin/env runhaskell import Distribution.Simple-main = defaultMainWithHooks defaultUserHooks+main = defaultMainWithHooks simpleUserHooks
happstack-server.cabal view
@@ -1,5 +1,5 @@ Name: happstack-server-Version: 0.4.1+Version: 0.5.0 Synopsis: Web related tools and services. Description: Web framework License: BSD3@@ -65,15 +65,15 @@ filepath, HaXml >= 1.13 && < 1.14, hslogger >= 1.0.2,- happstack-data >= 0.4.1 && < 0.5,- happstack-util >= 0.4.1 && < 0.5,+ happstack-data >= 0.5 && < 0.6,+ happstack-util >= 0.5 && < 0.6, html, MaybeT, mtl, network, old-locale, old-time,- parsec < 3,+ parsec < 4, process, sendfile >= 0.6.1 && < 0.7, template-haskell,@@ -106,7 +106,7 @@ Executable happstack-server-tests Main-Is: Test.hs GHC-Options: -threaded- Build-depends: HUnit+ Build-depends: HUnit, parsec < 4 hs-source-dirs: tests, src if flag(tests) Buildable: True
src/Happstack/Server/Cookie.hs view
@@ -15,7 +15,6 @@ where import qualified Data.ByteString.Char8 as C-import Data.Either import Data.Char import Data.List import Data.Generics@@ -70,7 +69,7 @@ eof return cookieList cookie_value ver = do- name<-attr+ name<-name_parser cookieEq val<-value path<-option "" $ try (cookieSep >> cookie_path)@@ -86,23 +85,21 @@ cookieSep = ws >> oneOf ",;" >> ws cookieEq = ws >> char '=' >> ws ws = spaces- attr = token value = word word = try (quoted_string) <|> incomp_token -- Parsers based on RFC 2068- token = many1 $ oneOf ((chars \\ ctl) \\ tspecials) quoted_string = do char '"' r <-many (oneOf qdtext) char '"' return r - -- Custom parser, incompatible with RFC 2068, but very forgiving ;)+ -- Custom parsers, incompatible with RFC 2068, but more forgiving ;) incomp_token = many1 $ oneOf ((chars \\ ctl) \\ " \t\";")+ name_parser = many1 $ oneOf ((chars \\ ctl) \\ "= ;,") -- Primitives from RFC 2068- tspecials = "()<>@,;:\\\"/[]?={} \t" ctl = map chr (127:[0..31]) chars = map chr [0..127] octet = map chr [0..255]
src/Happstack/Server/HTTP/FileServe.hs view
@@ -36,7 +36,7 @@ ) where import Control.Exception.Extensible (IOException, SomeException, Exception(fromException), bracket, handleJust)-import Control.Monad (MonadPlus)+import Control.Monad (MonadPlus(mzero)) import Control.Monad.Trans (MonadIO(liftIO)) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S@@ -232,7 +232,7 @@ -- > serveFileUsing filePathLazy (guessContentTypeM mimeTypes) "/srv/data/image.jpg" -- -- WARNING: No security checks are performed.-serveFileUsing :: (ServerMonad m, FilterMonad Response m, MonadIO m) +serveFileUsing :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => (String -> FilePath -> m Response) -- ^ typically 'filePathSendFile', 'filePathLazy', or 'filePathStrict' -> (FilePath -> m String) -- ^ function for determining content-type of file. Typically 'asContentType' or 'guessContentTypeM' -> FilePath -- ^ path to the file to serve@@ -242,15 +242,15 @@ if fe then do mt <- mimeFn fp serveFn mt fp- else fileNotFound fp+ else mzero -- | Alias for 'serveFileUsing' 'filePathSendFile'-serveFile :: (ServerMonad m, FilterMonad Response m, MonadIO m) => (FilePath -> m String) -> FilePath -> m Response+serveFile :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => (FilePath -> m String) -> FilePath -> m Response serveFile = serveFileUsing filePathSendFile -- ** Serve files from a directory --- | Serve files from a directory and it's subdirectories (parameterizable version)+-- | Serve files from a directory and its subdirectories (parameterizable version) -- -- Parameterize this function to create functions like, 'fileServe', 'fileServeLazy', and 'fileServeStrict' --@@ -265,10 +265,11 @@ , ServerMonad m , FilterMonad Response m , MonadIO m+ , MonadPlus m ) => (String -> FilePath -> m Response) -- ^ function which takes a content-type and filepath and generates a response (typically 'filePathSendFile', 'filePathLazy', or 'filePathStrict') -> (FilePath -> m String) -- ^ function which returns the mime-type for FilePath- -> [FilePath] -- ^ index files if the path is a directory+ -> [FilePath] -- ^ index file names, in case the requested path is a directory -> FilePath -- ^ file/directory to serve -> m Response fileServe' serveFn mimeFn ixFiles localpath = do@@ -288,55 +289,55 @@ seeOther path' (toResponse path') else if fe then serveFileUsing serveFn mimeFn fp- else fileNotFound fp+ else mzero --- | Serve files from a directory and it's subdirectories (sendFile version). Should perform much better than its predecessors.-fileServe :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m) =>- [FilePath] -- ^ index files if the path is a directory+-- | Serve files from a directory and its subdirectories (sendFile version). Should perform much better than its predecessors.+fileServe :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) =>+ [FilePath] -- ^ index file names, in case the requested path is a directory -> FilePath -- ^ file/directory to serve -> m Response fileServe ixFiles localPath = fileServe' filePathSendFile (guessContentTypeM mimeTypes) (ixFiles ++ defaultIxFiles) localPath --- | Serve files from a directory and it's subdirectories (lazy ByteString version).+-- | Serve files from a directory and its subdirectories (lazy ByteString version). -- -- May leak file handles.-fileServeLazy :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m) =>- [FilePath] -- ^ index files if the path is a directory+fileServeLazy :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) =>+ [FilePath] -- ^ index file names, in case the requested path is a directory -> FilePath -- ^ file/directory to serve -> m Response fileServeLazy ixFiles localPath = fileServe' filePathLazy (guessContentTypeM mimeTypes) (ixFiles ++ defaultIxFiles) localPath --- | Serve files from a directory and it's subdirectories (strict ByteString version). -fileServeStrict :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m) =>- [FilePath] -- ^ index files if the path is a directory+-- | Serve files from a directory and its subdirectories (strict ByteString version). +fileServeStrict :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) =>+ [FilePath] -- ^ index file names, in case the next argument is a directory -> FilePath -- ^ file/directory to serve -> m Response fileServeStrict ixFiles localPath = fileServe' filePathStrict (guessContentTypeM mimeTypes) (ixFiles ++ defaultIxFiles) localPath -- * Index -doIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m)+doIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => [String] -> MimeMap -> String -> m Response doIndex ixFiles mimeMap localPath = doIndex' filePathSendFile (guessContentTypeM mimeMap) ixFiles localPath -doIndexLazy :: (ServerMonad m, FilterMonad Response m, MonadIO m)+doIndexLazy :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => [String] -> MimeMap -> String -> m Response doIndexLazy ixFiles mimeMap localPath = doIndex' filePathLazy (guessContentTypeM mimeMap) ixFiles localPath -doIndexStrict :: (ServerMonad m, FilterMonad Response m, MonadIO m)+doIndexStrict :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => [String] -> MimeMap -> String -> m Response doIndexStrict ixFiles mimeMap localPath = doIndex' filePathStrict (guessContentTypeM mimeMap) ixFiles localPath -doIndex' :: (ServerMonad m, FilterMonad Response m, MonadIO m)+doIndex' :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => (String -> FilePath -> m Response) -> (FilePath -> m String) -> [String]
src/Happstack/Server/HTTP/Handler.hs view
@@ -17,13 +17,17 @@ import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy.Internal as L+import qualified Data.ByteString.Internal as S+import qualified Data.ByteString.Unsafe as S+import qualified Data.ByteString as S+import System.IO.Unsafe import qualified Data.Map as M import System.IO import Numeric import Data.Int (Int64) import Happstack.Server.Cookie import Happstack.Server.HTTP.Clock-import Happstack.Server.HTTP.LazyLiner import Happstack.Server.HTTP.Types import Happstack.Server.HTTP.Multipart import Happstack.Server.HTTP.RFC822Headers@@ -33,12 +37,32 @@ import Happstack.Util.TimeOut import Happstack.Util.LogFormat (formatRequestCombined) import Data.Time.Clock (getCurrentTime)-import Network.Socket (Socket, fdSocket) import Network.Socket.SendFile (unsafeSendFile') import System.Log.Logger (Priority(..), logM) ++hGetContentsN :: Int -> Handle -> IO L.ByteString+hGetContentsN k h = lazyRead -- TODO close on exceptions+ where+ lazyRead = unsafeInterleaveIO loop++ loop = do+ c <- S.hGetNonBlocking h k+ if S.null c+ then do eof <- hIsEOF h+ if eof then hClose h >> return L.Empty+ else hWaitForInput h (-1)+ >> loop++ --then hClose h >> return Empty+ else do cs <- lazyRead+ return (L.Chunk c cs)++hGetContents' :: Handle -> IO L.ByteString+hGetContents' = hGetContentsN L.defaultChunkSize+ request :: Conf -> Handle -> Host -> (Request -> IO Response) -> IO ()-request conf h host handler = rloop conf h host handler =<< L.hGetContents h+request conf h host handler = rloop conf h host handler =<< hGetContents' h required :: String -> Maybe a -> Either String a required err Nothing = Left err@@ -57,7 +81,8 @@ | otherwise = join $ withTimeOut (30 * second) $ do let parseRequest- = do (topStr, restStr) <- required "failed to separate request" $ splitAtEmptyLine inputStr+ = do+ (topStr, restStr) <- required "failed to separate request" $ splitAtEmptyLine inputStr (rql, headerStr) <- required "failed to separate headers/body" $ splitAtCRLF topStr let (m,u,v) = requestLine rql headers' <- parseHeaders "host" (L.unpack headerStr)@@ -69,7 +94,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)) (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)@@ -79,7 +104,7 @@ -> return $ do let ioseq act = act >>= \x -> x `seq` return x res <- ioseq (handler req) `E.catch` \(e::E.SomeException) -> return $ result 500 $ "Server error: " ++ show e- + -- combined log format time <- getCurrentTime let host' = fst host@@ -98,7 +123,7 @@ -- error it will return @Left msg@. parseResponse :: L.ByteString -> Either String Response parseResponse inputStr =- do (topStr,restStr) <- required "failed to separate response" $ + do (topStr,restStr) <- required "failed to separate response" $ splitAtEmptyLine inputStr (rsl,headerStr) <- required "failed to separate headers/body" $ splitAtCRLF topStr@@ -107,8 +132,8 @@ let headers = mkHeaders headers' let mbCL = fmap fst (B.readInt =<< getHeader "content-length" headers) (body,_) <-- maybe (if (isNothing $ getHeader "transfer-encoding" headers) - then return (restStr,L.pack "") + maybe (if (isNothing $ getHeader "transfer-encoding" headers)+ then return (restStr,L.pack "") else return $ consumeChunks restStr) (\cl->return (L.splitAt (fromIntegral cl) restStr)) mbCL@@ -123,11 +148,11 @@ consumeChunksImpl str | L.null str = ([],L.empty,str) | chunkLen == 0 = let (last,rest') = L.splitAt lenLine1 str- (tr',rest'') = getTrailer rest' + (tr',rest'') = getTrailer rest' in ([(0,last)],tr',rest'') | otherwise = ((chunkLen,part):crest,tr,rest2) where- line1 = head $ lazylines str + line1 = head $ lazylines str lenLine1 = (L.length line1) + 1 -- endchar chunkLen = (fst $ head $ readHex $ L.unpack line1) len = chunkLen + lenLine1 + 2@@ -158,7 +183,7 @@ x -> error $ "requestLine cannot handle input: " ++ (show x) responseLine :: L.ByteString -> (B.ByteString, Int)-responseLine l = case B.words ((B.concat . L.toChunks) l) of +responseLine l = case B.words ((B.concat . L.toChunks) l) of (v:c:_) -> version v `seq` (v,fst (fromJust (B.readInt c))) x -> error $ "responseLine cannot handle input: " ++ (show x) @@ -225,7 +250,7 @@ -- | Serializes the request to the given handle putRequest :: Handle -> Request -> IO ()-putRequest h rq = do +putRequest h rq = do let put = B.hPut h ph (HeaderPair k vs) = map (\v -> B.concat [k, fsepC, v, crlfC]) vs sp = [B.pack " "]
src/Happstack/Server/HTTP/Listen.hs view
@@ -1,12 +1,19 @@ {-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-}-module Happstack.Server.HTTP.Listen(listen, listen') where+module Happstack.Server.HTTP.Listen(listen, listen',listenOn) where import Happstack.Server.HTTP.Types import Happstack.Server.HTTP.Handler import Happstack.Server.HTTP.Socket (acceptLite) import Control.Exception.Extensible as E import Control.Concurrent-import Network(PortID(..), listenOn, sClose, Socket)+import Network.BSD (getProtocolNumber)+import Network(sClose, Socket)+import Network.Socket as Socket (SocketOption(KeepAlive), setSocketOption, + socket, Family(..), SockAddr, + SocketOption(..), SockAddr(..), + iNADDR_ANY, maxListenQueue, SocketType(..), + bindSocket)+import qualified Network.Socket as Socket (listen) import System.IO {- #ifndef mingw32_HOST_OS@@ -19,12 +26,34 @@ log':: Priority -> String -> IO () log' = logM "Happstack.Server.HTTP.Listen" ++{-+ Network.listenOn binds randomly to IPv4 or IPv6 or both,+ depending on system and local settings.+ Lets make it use IPv4 only for now.+-}++listenOn :: Int -> IO Socket+listenOn portm = do+ proto <- getProtocolNumber "tcp"+ E.bracketOnError+ (socket AF_INET Stream proto)+ (sClose)+ (\sock -> do+ setSocketOption sock ReuseAddr 1+ bindSocket sock (SockAddrInet (fromIntegral portm) iNADDR_ANY)+ Socket.listen sock maxListenQueue+ return sock+ )++ -- | Bind and listen port listen :: Conf -> (Request -> IO Response) -> IO () listen conf hand = do let port' = port conf- socket <- listenOn (PortNumber $ toEnum port')- listen' socket conf hand+ socketm <- listenOn port'+ setSocketOption socketm KeepAlive 1+ listen' socketm conf hand -- | Use a previously bind port and listen listen' :: Socket -> Conf -> (Request -> IO Response) -> IO ()
src/Happstack/Server/HTTP/Types.hs view
@@ -29,7 +29,6 @@ import Happstack.Server.Cookie import Data.List import Text.Show.Functions ()-import System.IO (Handle) -- | HTTP version data Version = Version Int Int
src/Happstack/Server/HTTPClient/HTTP.hs view
@@ -141,11 +141,9 @@ import Data.Bits ((.&.)) import Data.Char import Data.List (partition,elemIndex,intersperse)-import Data.Maybe import Control.Monad (when,forM) import Numeric (readHex) import Text.ParserCombinators.ReadP-import System.IO
src/Happstack/Server/HTTPClient/TCP.hs view
@@ -35,7 +35,6 @@ import Data.List (elemIndex) import Data.Char import Data.IORef-import System.IO ----------------------------------------------------------------- ------------------ TCP Connections ------------------------------
src/Happstack/Server/MessageWrap.hs view
@@ -2,10 +2,8 @@ module Happstack.Server.MessageWrap where -import Control.Monad.Identity import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.List as List import Data.Maybe import Happstack.Server.HTTP.Types as H import Happstack.Server.HTTP.Multipart
src/Happstack/Server/MinHaXML.hs view
@@ -13,7 +13,6 @@ import Text.XML.HaXml.Pretty as Pretty import Text.XML.HaXml.Verbatim as Verbatim import Happstack.Util.Common-import Data.Maybe import System.Time import Happstack.Data.Xml as Xml
src/Happstack/Server/Parts.hs view
@@ -8,7 +8,6 @@ import Happstack.Server.SimpleHTTP import Text.ParserCombinators.Parsec import Control.Monad-import Data.Char import Data.Maybe import Data.List import qualified Data.ByteString.Char8 as BS
src/Happstack/Server/SimpleHTTP.hs view
@@ -25,78 +25,71 @@ -- 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.+-- like CGI\/FastCGI can be used if so desired. ----- So the general nature of 'simpleHTTP' is no different than what you'd expect+-- So the general nature of 'simpleHTTP' is just what you'd expect -- from a web application container. First you figure out which function is -- going to process your request, process the request to generate a response, -- then return that response to the client. The web application container is -- started with 'simpleHTTP', which takes a configuration and a--- response-building structure ('ServerPartT' which I'll return too in a--- moment), and picks the first handler that is willing to accept the request,--- passes the request into the handler. A simple "hello world" style HAppS+-- response-building structure ('ServerPartT' which I'll return to in a+-- moment), picks the first handler that is willing to accept the request, and+-- passes the request in to the handler. A simple "hello world" style Happstack -- simpleHTTP server looks like: ----- @--- main = simpleHTTP nullConf $ return \"Hello World!\"--- @+-- > main = simpleHTTP nullConf $ return "Hello World!" -- -- @simpleHTTP nullConf@ creates a HTTP server on port 8000.--- return \"Hello World!\" creates a serverPartT that just returns that text.+-- return \"Hello World!\" creates a 'ServerPartT' that just returns that text. -- -- 'ServerPartT' is the basic response builder. As you might expect, it's a--- container for a function that takes a Request and converts it a response+-- container for a function that takes a Request and converts it to a response -- suitable for sending back to the server. Most of the time though you don't--- even need to worry about that as ServerPartT hides almost all the machinery+-- even need to worry about that as 'ServerPartT' hides almost all the machinery -- for building your response by exposing a few type classes. -- -- 'ServerPartT' is a pretty rich monad. You can interact with your request, -- your response, do IO, etc. Here is a do block that validates basic--- authentication It takes a realm name as a string, a Map of username to+-- authentication. It takes a realm name as a string, a Map of username to -- password and a server part to run if authentication fails. ----- @basicAuth'@ acts like a guard, and only produces a response when--- authentication fails. So put it before any ServerPartT you want to demand--- authentication for in any collection of ServerPartTs.------ @+-- 'basicAuth' acts like a guard, and only produces a response when+-- authentication fails. So put it before any 'ServerPartT' for which you want to demand+-- authentication, in any collection of 'ServerPartT's. ----- main = simpleHTTP nullConf $ myAuth, return \"Hello World!\"--- where--- myAuth = basicAuth\' \"Test\"--- (M.fromList [(\"hello\", \"world\")]) (return \"Login Failed\")+-- > main = simpleHTTP nullConf $ myAuth, return "Hello World!"+-- > where+-- > myAuth = basicAuth' "Test"+-- > (M.fromList [("hello", "world")]) (return "Login Failed") ----- basicAuth\' realmName authMap unauthorizedPart =--- do--- let validLogin name pass = M.lookup name authMap == Just pass--- let parseHeader = break (\':\'==) . Base64.decode . B.unpack . B.drop 6--- authHeader <- getHeaderM \"authorization\"--- case authHeader of--- Nothing -> err--- Just x -> case parseHeader x of--- (name, \':\':pass) | validLogin name pass -> mzero--- | otherwise -> err--- _ -> err--- where--- err = do--- unauthorized ()--- setHeaderM headerName headerValue--- unauthorizedPart--- headerValue = \"Basic realm=\\\"\" ++ realmName ++ \"\\\"\"--- headerName = \"WWW-Authenticate\"--- @+-- > basicAuth' realmName authMap unauthorizedPart =+-- > do+-- > let validLogin name pass = M.lookup name authMap == Just pass+-- > let parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6+-- > authHeader <- getHeaderM "authorization"+-- > case authHeader of+-- > Nothing -> err+-- > Just x -> case parseHeader x of+-- > (name, ':':pass) | validLogin name pass -> mzero+-- > | otherwise -> err+-- > _ -> err+-- > where+-- > err = do+-- > unauthorized ()+-- > setHeaderM headerName headerValue+-- > unauthorizedPart+-- > headerValue = "Basic realm=\"" ++ realmName ++ "\""+-- > headerName = "WWW-Authenticate" ----- Here is another example that uses liftIO to embed IO in a request process+-- Here is another example that uses 'liftIO' to embed IO in a request process: ----- @--- main = simpleHTTP nullConf $ myPart--- myPart = do--- line <- liftIO $ do -- IO--- putStr \"return? \"--- getLine--- when (take 2 line \/= \"ok\") $ (notfound () >> return \"refused\")--- return \"Hello World!\"--- @+-- > main = simpleHTTP nullConf $ myPart+-- > myPart = do+-- > line <- liftIO $ do -- IO+-- > putStr "return? "+-- > getLine+-- > when (take 2 line /= "ok") $ (notfound () >> return "refused")+-- > return "Hello World!" -- -- This example will ask in the console \"return? \" if you type \"ok\" it will -- show \"Hello World!\" and if you type anything else it will return a 404.@@ -151,6 +144,7 @@ , WebMonad(..) , ok , modifyResponse+ , toResponseBS , setResponseCode , badGateway , internalServerError@@ -164,6 +158,7 @@ , tempRedirect , addCookie , addCookies+ , expireCookie , addHeaderM , setHeaderM , ifModifiedSince@@ -171,6 +166,7 @@ -- * guards and building blocks , guardRq , dir+ , dirs , host , withHost , method@@ -232,12 +228,12 @@ 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') -- So that we can disambiguate 'Writer.listen'+import qualified Happstack.Server.HTTP.Listen as Listen (listen, listen',listenOn) -- So that we can disambiguate 'Writer.listen' import Happstack.Server.XSLT (XSLTCmd, XSLPath, procLBSIO) import Happstack.Server.SURI (ToSURI) import Happstack.Util.Common (Seconds, readM) import Happstack.Data (Xml, normalize, fromPairs, Element, toXml, toPublicXml) -- used by default implementation of fromData-import Network (listenOn, PortID(..), Socket)+import Network (PortID(..), Socket) import Control.Applicative (Applicative, pure, (<*>)) import Control.Concurrent (forkIO) import Control.Exception (evaluate)@@ -283,7 +279,7 @@ import qualified Happstack.Crypto.Base64 as Base64 import Data.Char (toLower)-import Data.List (isPrefixOf)+import Data.List (isPrefixOf,stripPrefix,tails,inits) import System.IO (hGetContents, hClose) import System.Console.GetOpt ( OptDescr(Option) , ArgDescr(ReqArg)@@ -294,16 +290,18 @@ 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) --- | An alias for WebT when using IO+-- | An alias for WebT when using IO. type Web a = WebT IO a--- | An alias for using ServerPartT when using the IO+-- | An alias for using ServerPartT when using the IO. type ServerPart a = ServerPartT IO a -------------------------------------- -- HERE BEGINS ServerPartT definitions --- | ServerPartT is a container for processing requests and returning results+-- | ServerPartT is a container for processing requests and returning results. newtype ServerPartT m a = ServerPartT { unServerPartT :: ReaderT Request (WebT m) a } deriving (Monad, MonadIO, MonadPlus, Functor) @@ -316,50 +314,43 @@ withRequest = ServerPartT . ReaderT -- | Used to manipulate the containing monad. Very useful when embedding a--- monad into a ServerPartT, since simpleHTTP requires a @ServerPartT IO a@.+-- monad into a 'ServerPartT', since 'simpleHTTP' requires a @ServerPartT IO a@. -- Refer to 'WebT' for an explanation of the structure of the monad. ----- Here is an example. Suppose you want to embed an ErrorT into your--- ServerPartT to enable throwError and catchError in your Monad.+-- Here is an example. Suppose you want to embed an 'ErrorT' into your+-- 'ServerPartT' to enable 'throwError' and 'catchError' in your 'Monad'. ----- @--- type MyServerPartT e m a = ServerPartT (ErrorT e m) a--- @+-- > type MyServerPartT e m a = ServerPartT (ErrorT e m) a ----- Now suppose you want to pass MyServerPartT into a function--- that demands a @ServerPartT IO a@ (e.g. simpleHTTP). You+-- Now suppose you want to pass @MyServerPartT@ into a function+-- that demands a @ServerPartT IO a@ (e.g. 'simpleHTTP'). You -- can provide the function: ----- @--- unpackErrorT:: (Monad m, Show e) => UnWebT (ErrorT e m) a -> UnWebT m a--- unpackErrorT handler et = do--- eitherV <- runErrorT et--- case eitherV of--- Left err -> return $ Just (Left "Catastrophic failure " ++ show e, Set $ Endo \r -> r{rsCode = 500})--- Right x -> return x--- @+-- > unpackErrorT:: (Monad m, Show e) => UnWebT (ErrorT e m) a -> UnWebT m a+-- > unpackErrorT handler et = do+-- > eitherV <- runErrorT et+-- > return $ case eitherV of+-- > Left err -> Just (Left "Catastrophic failure " ++ show e+-- > , Set $ Endo $ \r -> r{rsCode = 500})+-- > Right x -> x ----- With @unpackErrorT@ you can now call simpleHTTP. Just wrap your @ServerPartT@ list.+-- With @unpackErrorT@ you can now call 'simpleHTTP'. Just wrap your @ServerPartT@ list. ----- @--- simpleHTTP nullConf $ mapServerPartT unpackErrorT (myPart \`catchError\` myHandler)--- @+-- > simpleHTTP nullConf $ mapServerPartT unpackErrorT (myPart `catchError` myHandler) -- -- Or alternatively: ----- @--- simpleHTTP' unpackErrorT nullConf (myPart \`catchError\` myHandler)--- @+-- > simpleHTTP' unpackErrorT nullConf (myPart `catchError` myHandler) ----- Also see 'spUnwrapErrorT' for a more sophisticated version of this function+-- Also see 'spUnwrapErrorT' for a more sophisticated version of this function. -- mapServerPartT :: ( UnWebT m a -> UnWebT n b) -> (ServerPartT m a -> ServerPartT n b) mapServerPartT f ma = withRequest $ \rq -> mapWebT f (runServerPartT ma rq) --- | A varient of mapServerPartT where the first argument, also takes a request.--- useful if you want to runServerPartT on a different ServerPartT inside your--- monad (see spUnwrapErrorT)+-- | A variant of 'mapServerPartT' where the first argument also takes a request.+-- Useful if you want to 'runServerPartT' on a different 'ServerPartT' inside your+-- monad (see 'spUnwrapErrorT'). 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)@@ -396,12 +387,12 @@ instance Monad m => WebMonad Response (ServerPartT m) where finishWith r = anyRequest $ finishWith r --- | yes, this is exactly like 'ReaderT' with new names.--- Why you ask? Because ServerT can lift up a ReaderT.+-- | Yes, this is exactly like 'ReaderT' with new names.+-- Why you ask? Because 'ServerT' can lift up a 'ReaderT'. -- If you did that, it would shadow ServerT's behavior -- as a ReaderT, thus meaning if you lifted the ReaderT--- you could no longer modify the Request. This way--- you can add a ReaderT to your monad stack without+-- you could no longer modify the 'Request'. This way+-- you can add a 'ReaderT' to your monad stack without -- any trouble. class Monad m => ServerMonad m where askRq :: m Request@@ -419,16 +410,14 @@ -- HERE BEGINS WebT definitions -- | A monoid operation container.--- If a is a monoid, then SetAppend is a monoid with the following behaviors:+-- If a is a monoid, then 'SetAppend' is a monoid with the following behaviors: ----- @--- Set x `mappend` Append y = Set (x `mappend` y)--- Append x `mappend` Append y = Append (x `mappend` y)--- \_ `mappend` Set y = Set y--- @+-- > Set x `mappend` Append y = Set (x `mappend` y)+-- > Append x `mappend` Append y = Append (x `mappend` y)+-- > _ `mappend` Set y = Set y ----- A simple way of sumerizing this is, if the right side is Append, then the--- right is appended to the left. If the right side is Set, then the left side+-- A simple way of summarizing this is, if the right side is @Append@, then the+-- right is appended to the left. If the right side is @Set@, then the left side -- is ignored. data SetAppend a = Set a | Append a@@ -441,7 +430,7 @@ Append x `mappend` Append y = Append (x `mappend` y) _ `mappend` Set y = Set y --- | Extract the value from a SetAppend+-- | Extract the value from a SetAppend. -- Note that a SetAppend is actually a CoPointed from: -- <http://hackage.haskell.org/packages/archive/category-extras/latest/doc/html/Control-Functor-Pointed.html> -- But lets not drag in that dependency. yet...@@ -453,7 +442,7 @@ fmap f (Set x) = Set $ f x fmap f (Append x) = Append $ f x --- | @FilterFun@ is a lot more fun to type than @SetAppend (Dual (Endo a))@+-- | @FilterFun@ is a lot more fun to type than @SetAppend (Dual (Endo a))@. type FilterFun a = SetAppend (Dual (Endo a)) unFilterFun :: FilterFun a -> (a -> a)@@ -462,31 +451,26 @@ newtype FilterT a m b = FilterT { unFilterT :: WriterT (FilterFun a) m b } deriving (Monad, MonadTrans, Functor, MonadIO) --- | A set of functions for manipulating filters. A ServerPartT implements--- FilterMonad Response so these methods are the fundamental ways of+-- | A set of functions for manipulating filters. A 'ServerPartT' implements+-- 'FilterMonad' 'Response' so these methods are the fundamental ways of -- manipulating the response object, especially before you've converted your--- monadic value to a 'Response'+-- monadic value to a 'Response'. class Monad m => FilterMonad a m | m->a where- -- | Ignores all previous- -- alterations to your filter+ -- | Ignores all previous alterations to your filter -- -- As an example: --- -- @- -- do- -- composeFilter f- -- setFilter g- -- return \"Hello World\"- -- @+ -- > do+ -- > composeFilter f+ -- > setFilter g+ -- > return "Hello World" --- -- setFilter g will cause the first composeFilter to be- -- ignored.+ -- setFilter g will cause the first composeFilter to be ignored. setFilter :: (a->a) -> m ()- -- |- -- composes your filter function with the- -- existing filter function.+ -- | Composes your filter function with the existing filter+ -- function. composeFilter :: (a->a) -> m ()- -- | retrives the filter from the environment+ -- | Retrives the filter from the environment. getFilter :: m b -> m (b, a->a) instance (Monad m) => FilterMonad a (FilterT a m) where@@ -499,74 +483,68 @@ deriving (MonadIO, Functor) -- |--- It is worth discussing the unpacked structure of WebT a bit as it's exposed+-- It is worth discussing the unpacked structure of 'WebT' a bit as it's exposed -- in 'mapServerPartT' and 'mapWebT'. ----- A fully unpacked WebT has a structure that looks like:+-- A fully unpacked 'WebT' has a structure that looks like: ----- @--- ununWebT $ WebT m a :: m (Maybe (Either Response a, FilterFun Response))--- @+-- > ununWebT $ WebT m a :: m (Maybe (Either Response a, FilterFun Response)) ----- So, ignoring m, as it is just the containing Monad, the outermost layer is--- a Maybe. This is 'Nothing' if 'mzero' was called or @Just (Either Response--- a, SetAppend (Endo Response))@ if 'mzero' wasn't called. Inside the Maybe,+-- So, ignoring @m@, as it is just the containing 'Monad', the outermost layer is+-- a 'Maybe'. This is 'Nothing' if 'mzero' was called or @'Just' ('Either' 'Response'+-- a, 'SetAppend' ('Endo' 'Response'))@ if 'mzero' wasn't called. Inside the 'Maybe', -- there is a pair. The second element of the pair is our filter function--- @FilterFun Response@. @FilterFun Response@ is a type alias for @SetAppend--- (Dual (Endo Response))@. This is just a wrapper for a @Response->Response@--- function with a particular Monoid behavior. The value+-- @'FilterFun' 'Response'@. @'FilterFun' 'Response'@ is a type alias for @'SetAppend'+-- ('Dual' ('Endo' 'Response'))@. This is just a wrapper for a @'Response' -> 'Response'@+-- function with a particular 'Monoid' behavior. The value ----- @--- Append (Dual (Endo f))--- @+-- > Append (Dual (Endo f)) -- -- Causes f to be composed with the previous filter. ----- @--- Set (Dual (Endo f))--- @+-- > Set (Dual (Endo f)) -- -- Causes f to not be composed with the previous filter. -- -- Finally, the first element of the pair is either @Left Response@ or @Right a@. ----- Another way of looking at all these pieces is from the behaviors they control. The Maybe--- controls the mzero behavior. @Set (Endo f)@ comes from the setFilter behavior.--- Likewise, @Append (Endo f)@ is from composeFilter. @Left Response@ is what you--- get when you call "finishWith" and @Right a@ is the normal exit.+-- Another way of looking at all these pieces is from the behaviors+-- they control. The 'Maybe' controls the 'mzero' behavior. @Set+-- (Endo f)@ comes from the 'setFilter' behavior. Likewise, @Append+-- (Endo f)@ is from 'composeFilter'. @Left Response@ is what you+-- get when you call 'finishWith' and @Right a@ is the normal exit. -- -- An example case statement looks like:--- @--- ex1 webt = do--- val <- ununWebT webt--- case val of--- Nothing -> Nothing -- this is the interior value when mzero was used--- Just (Left r, f) -> Just (Left r, f) -- r is the value that was passed into "finishWith"--- -- f is our filter function--- Just (Right a, f) -> Just (Right a, f) -- a is our normal monadic value--- -- f is still our filter function--- @ --+-- > ex1 webt = do+-- > val <- ununWebT webt+-- > case val of+-- > Nothing -> Nothing -- this is the interior value when mzero was used+-- > Just (Left r, f) -> Just (Left r, f) -- r is the value that was passed into "finishWith"+-- > -- f is our filter function+-- > Just (Right a, f) -> Just (Right a, f) -- a is our normal monadic value+-- > -- f is still our filter function+-- type UnWebT m a = m (Maybe (Either Response a, FilterFun Response)) instance Monad m => Monad (WebT m) where m >>= f = WebT $ unWebT m >>= unWebT . f return a = WebT $ return a- fail s = mkFailMessage s+ fail s = outputTraceMessage s (mkFailMessage s) instance Error Response where strMsg = toResponse class Monad m => WebMonad a m | m->a where- -- | A control structure- -- It ends the computation and returns the Response you passed into it+ -- | A control structure. + -- It ends the computation and returns the 'Response' you passed into it -- immediately. This provides an alternate escape route. In particular -- it has a monadic value of any type. And unless you call @'setFilter' id@ -- first your response filters will be applied normally. -- -- Extremely useful when you're deep inside a monad and decide that you -- want to return a completely different content type, since it doesn't- -- force you to convert all your return types to Response early just to+ -- force you to convert all your return types to 'Response' early just to -- accomodate this. finishWith :: a -> m b @@ -579,15 +557,15 @@ instance (Monad m) => MonadPlus (WebT m) where -- | Aborts a computation. --- -- This is primarily useful because msum will take an array- -- of MonadPlus and return the first one that isn't mzero,+ -- This is primarily useful because 'msum' will take an array+ -- of 'MonadPlus' and return the first one that isn't mzero, -- which is exactly the semantics expected from objects- -- that take lists of ServerPartT+ -- that take lists of 'ServerPartT'. mzero = WebT $ lift $ lift $ mzero mplus x y = WebT $ ErrorT $ FilterT $ (lower x) `mplus` (lower y) where lower = (unFilterT . runErrorT . unWebT) --- | deprecated. use mzero+-- | Deprecated: use 'mzero'. noHandle :: (MonadPlus m) => m a noHandle = mzero {-# DEPRECATED noHandle "Use mzero" #-}@@ -604,24 +582,24 @@ mempty = mzero mappend = mplus --- | takes your WebT, if it is 'mempty' it returns Nothing else it--- converts the value to a Response and applies your filter to it.+-- | Takes your 'WebT', if it is 'mempty' it returns 'Nothing' else it+-- converts the value to a 'Response' and applies your filter to it. 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 --- | for when you really need to unpack a WebT entirely (and not--- just unwrap the first layer with unWebT)+-- | For when you really need to unpack a 'WebT' entirely (and not+-- just unwrap the first layer with 'unWebT'). ununWebT :: WebT m a -> UnWebT m a ununWebT = runMaybeT . runWriterT . unFilterT . runErrorT . unWebT --- | for wrapping a WebT back up. @mkWebT . ununWebT = id@+-- | For wrapping a 'WebT' back up. @mkWebT . ununWebT = id@ mkWebT :: UnWebT m a -> WebT m a mkWebT = WebT . ErrorT . FilterT . WriterT . MaybeT --- | see 'mapServerPartT' for a discussion of this function+-- | See 'mapServerPartT' for a discussion of this function. mapWebT :: (UnWebT m a -> UnWebT n b) -> ( WebT m a -> WebT n b) mapWebT f ma = mkWebT $ f (ununWebT ma)@@ -653,19 +631,17 @@ liftWebT (Just (Left x,f)) = return $ Just (Left x, f) liftWebT (Just (Right x,f)) = pass (return x)>>= (\a -> return $ Just (Right a,f)) --- | An alias for setFilter id--- It resets all your filters+-- | An alias for @setFilter id@ It resets all your filters. ignoreFilters :: (FilterMonad a m) => m () ignoreFilters = setFilter id --- | Used to ignore all your filters--- and immediately end the computation. A combination of--- 'ignoreFilters' and 'finishWith'+-- | Used to ignore all your filters and immediately end the+-- computation. A combination of 'ignoreFilters' and 'finishWith'. escape :: (WebMonad a m, FilterMonad a m) => m a -> m b escape gen = ignoreFilters >> gen >>= finishWith --- | An alternate form of 'escape' that can--- be easily used within a do block.+-- | An alternate form of 'escape' that can be easily used within a do+-- block. escape' :: (WebMonad a m, FilterMonad a m) => a -> m b escape' a = ignoreFilters >> finishWith a @@ -674,40 +650,46 @@ -- | An array of 'OptDescr', useful for processing--- command line options into an 'Conf' for 'simpleHTTP'+-- command line options into an 'Conf' for 'simpleHTTP'. ho :: [OptDescr (Conf -> Conf)] ho = [Option [] ["http-port"] (ReqArg (\h c -> c { port = read h }) "port") "port to bind http server"] --- | parseConfig tries to parse your command line options--- into a Conf.+-- | Parse command line options into a 'Conf'. 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 a 'ServerPartT'.--- Use msum to pick the first handler from a list of handlers that doesn't call--- noHandle.+-- | Use the built-in web-server to serve requests according to a+-- 'ServerPartT'. Use 'msum' to pick the first handler from a list of+-- handlers that doesn't call 'mzero'. This function always binds o+-- IPv4 ports until Network module is fixed to support IPv6 in a+-- portable way. Use 'simpleHTTPWithSocket' with custom socket if you+-- want different behaviour. simpleHTTP :: (ToMessage a) => Conf -> ServerPartT IO a -> IO () simpleHTTP = simpleHTTP' id --- | a combination of simpleHTTP'' and 'mapServerPartT'. See 'mapServerPartT' for a discussion--- of the first argument of this function.+-- | A combination of 'simpleHTTP''' and 'mapServerPartT'. See+-- 'mapServerPartT' for a discussion of the first argument of this+-- function. This function always binds to IPv4 ports until Network+-- module is fixed to support IPv6 in a portable way. Use+-- 'simpleHTTPWithSocket' with custom socket if you want different+-- behaviour. 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)) --- | Generate a result from a 'ServerPart' and a 'Request'. This is mainly used+-- | Generate a result from a 'ServerPartT' and a 'Request'. This is mainly used -- by CGI (and fast-cgi) wrappers. 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} --- | Run simpleHTTP with a previously bound socket. Useful if you want to run+-- | Run 'simpleHTTP' with a previously bound socket. Useful if you want to run -- happstack as user on port 80. Use something like this: -- -- > import System.Posix.User (setUserID, UserEntry(..), getUserEntryForName)@@ -718,34 +700,36 @@ -- > -- do other stuff as root here -- > getUserEntryForName "www" >>= setUserID . userID -- > -- finally start handling incoming requests--- > tid <- forkIO $ socketSimpleHTTP socket conf impl+-- > tid <- forkIO $ simpleHTTPWithSocket socket conf impl -- -- Note: It's important to use the same conf (or at least the same port) for -- 'bindPort' and 'simpleHTTPWithSocket'. simpleHTTPWithSocket :: (ToMessage a) => Socket -> Conf -> ServerPartT IO a -> IO () simpleHTTPWithSocket = simpleHTTPWithSocket' id --- | 'simpleHTTP'' with a socket+-- | Like 'simpleHTTP'' with a socket. 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)) --- | Bind port and return the socket for 'simpleHTTPWithSocket'+-- | Bind port and return the socket for 'simpleHTTPWithSocket'. This+-- function always binds to IPv4 ports until Network module is fixed to+-- support IPv6 in a portable way. bindPort :: Conf -> IO Socket-bindPort conf = listenOn (PortNumber . toEnum . port $ conf)+bindPort conf = Listen.listenOn (port conf) -- | This class is used by 'path' to parse a path component into a value. -- At present, the instances for number types (Int, Float, etc) just -- call 'readM'. The instance for 'String' however, just passes the -- path component straight through. This is so that you can read a--- path component which looks like this as a String:+-- path component which looks like this as a 'String': -- -- \/somestring\/ -- -- instead of requiring the path component to look like: ----- \/"somestring"\/+-- \/\"somestring\"\/ class FromReqURI a where fromReqURI :: String -> Maybe a @@ -757,8 +741,8 @@ type RqData a = ReaderT ([(String,Input)], [(String,Cookie)]) Maybe a --- | Useful for withData and getData' implement this on your preferred type--- to use those functions+-- | Useful for 'withData' and 'getData'' implement this on your preferred type+-- to use those functions. class FromData a where fromData :: RqData a @@ -778,11 +762,24 @@ instance FromData a => FromData (Maybe a) where fromData = fmap Just fromData `mplus` return Nothing --- |--- Minimal definition: 'toMessage'+-- |low-level function to build a 'Response' from a content-type and a+-- 'ByteString' --+-- Creates a 'Response' in a manner similar to the 'ToMessage' class,+-- but with out requiring an instance declaration.+toResponseBS :: B.ByteString -- ^ content-type+ -> L.ByteString -- ^ response body+ -> Response+toResponseBS contentType message =+ let res = Response 200 M.empty nullRsFlags message Nothing+ in setHeaderBS (B.pack "Content-Type") contentType res+++-- | -- Used to convert arbitrary types into an HTTP response. You need to implement--- this if you want to pass @ServerPartT m@ containing your type into simpleHTTP+-- this if you want to pass @ServerPartT m@ containing your type into 'simpleHTTP'.+--+-- Minimal definition: 'toMessage'. class ToMessage a where toContentType :: a -> B.ByteString toContentType _ = B.pack "text/plain"@@ -841,50 +838,50 @@ instance MatchMethod (Method -> Bool) where matchMethod f = f instance MatchMethod () where matchMethod () _ = True --- | flatten turns your arbitrary @m a@ and converts it too--- a @m 'Response'@ with @'toResponse'@+-- | 'flatten' turns your arbitrary @m a@ and converts it too+-- a @m 'Response'@ with 'toResponse'. flatten :: (ToMessage a, Functor f) => f a -> f Response flatten = fmap toResponse --- | This is kinda like a very oddly shaped mapServerPartT or mapWebT+-- | This is kinda like a very oddly shaped 'mapServerPartT' or 'mapWebT' -- You probably want one or the other of those. localContext :: Monad m => (WebT m a -> WebT m' a) -> ServerPartT m a -> ServerPartT m' a localContext fn hs = withRequest $ \rq -> fn (runServerPartT hs rq) --- | Get a header out of the request+-- | Get a header out of the request. getHeaderM :: (ServerMonad m) => String -> m (Maybe B.ByteString) getHeaderM a = askRq >>= return . (getHeader a) --- | adds headers into the response.+-- | Add headers into the response. -- This method does not overwrite any existing header of--- the same name, hence the name addHeaderM. If you--- want to replace a header use setHeaderM.+-- the same name, hence the name 'addHeaderM'. If you+-- want to replace a header use 'setHeaderM'. addHeaderM :: (FilterMonad Response m) => String -> String -> m () addHeaderM a v = composeFilter $ \res-> addHeader a v res --- | sets a header into the response. This will replace--- an existing header of the same name. Use addHeaderM, if you+-- | Set a header into the response. This will replace+-- an existing header of the same name. Use 'addHeaderM' if you -- want to add more than one header of the same name. setHeaderM :: (FilterMonad Response m) => String -> String -> m () setHeaderM a v = composeFilter $ \res -> setHeader a v res ------------------------------------- -- guards --- | guard using an arbitrary function on the request+-- | Guard using an arbitrary function on the request. guardRq :: (ServerMonad m, MonadPlus m) => (Request -> Bool) -> m () guardRq f = do rq <- askRq unless (f rq) mzero --- | Guard against the method. This function also guards against--- any remaining path segments. See methodOnly for the version+-- | Guard against the method. This function also guards against+-- any remaining path segments. See 'methodOnly' for the version -- that guards only by method methodM :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m () methodM meth = methodOnly meth >> nullDir --- | guard against the method only. (as opposed to 'methodM')+-- | Guard against the method only. (as opposed to 'methodM') methodOnly :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m () methodOnly meth = guardRq $ \rq -> matchMethod meth (rqMethod rq) @@ -894,17 +891,19 @@ methodSP m handle = methodM m >> handle -- | Guard against the method. Note, this function also guards against any--- remaining path segments. This function id deprecated. You can probably+-- remaining path segments. This function is deprecated. You can probably -- just use methodSP (or methodM) now. method :: (MatchMethod method, Monad m) => method -> WebT m a -> ServerPartT m a method m handle = methodSP m (anyRequest handle) {-# DEPRECATED method "you should be able to use methodSP" #-} --- | Guard against non-empty remaining path segments+-- | Guard against non-empty remaining path segments. nullDir :: (ServerMonad m, MonadPlus m) => m () nullDir = guardRq $ \rq -> null (rqPaths rq) --- | Pop a path element and run the @ServerPartT@ if it matches the given string.+-- | Pop a path element and run the 'ServerPartT' if it matches the given string.+-- +-- The path element can not contain \'/\'. See also 'dirs'. dir :: (ServerMonad m, MonadPlus m) => String -> m a -> m a dir staticPath handle = do@@ -912,8 +911,20 @@ case rqPaths rq of (p:xs) | p == staticPath -> localRq (\newRq -> newRq{rqPaths = xs}) handle _ -> mzero+ +-- | Guard against a 'FilePath'. Unlike 'dir' the 'FilePath' may+-- contain \'/\'. If the guard succeeds, the matched elements will be+-- popped from the directory stack.+--+-- > dirs "foo/bar" $ ...+-- +-- See also: 'dir'.+dirs :: (ServerMonad m, MonadPlus m) => FilePath -> m a -> m a +dirs fp m = + do let parts = splitDirectories (makeRelative "/" fp) + foldr dir m parts --- | Guard against the host+-- | Guard against the host. host :: (ServerMonad m, MonadPlus m) => String -> m a -> m a host desiredHost handle = do rq <- askRq@@ -921,7 +932,7 @@ (Just hostBS) | desiredHost == B.unpack hostBS -> handle _ -> mzero --- | Lookup the host header and pass it to the handler+-- | Lookup the host header and pass it to the handler. withHost :: (ServerMonad m, MonadPlus m) => (String -> m a) -> m a withHost handle = do rq <- askRq@@ -939,64 +950,60 @@ -> localRq (\newRq -> newRq{rqPaths = xs}) (handle a) _ -> mzero --- | grabs the rest of the URL (dirs + query) and passes it to your handler+-- | Grab the rest of the URL (dirs + query) and passes it to your handler. uriRest :: (ServerMonad m) => (String -> m a) -> m a uriRest handle = askRq >>= handle . rqURL --- | pops any path element and ignores when chosing a ServerPartT to handle the------ request.+-- | Pop any path element and ignore when chosing a 'ServerPartT' to+-- handle the request. anyPath :: (ServerMonad m, MonadPlus m) => m r -> m r anyPath x = path $ (\(_::String) -> x) --- | Deprecated. Use 'anyPath'.+-- | Deprecated: use 'anyPath'. anyPath' :: (ServerMonad m, MonadPlus m) => m r -> m r anyPath' = anyPath {-# DEPRECATED anyPath' "Use anyPath" #-} --- | guard which checks that the Request URI ends in '\/'. +-- | Guard which checks that the Request URI ends in \'\/\'. -- Useful for distinguishing between @foo@ and @foo/@ trailingSlash :: (ServerMonad m, MonadPlus m) => m () trailingSlash = guardRq $ \rq -> (last (rqUri rq)) == '/' --- | used to read parse your request with a RqData (a ReaderT, basically)--- For example here is a simple GET or POST variable based authentication--- guard. It handles the request with errorHandler if authentication fails.+-- | Parse your request with a 'RqData' (a ReaderT, basically)+-- For example here is a simple @GET@ or @POST@ variable based authentication+-- guard. It handles the request with 'errorHandler' if authentication fails. ----- @--- myRqData = do--- username <- lookInput \"username\"--- password <- lookInput \"password\"--- return (username, password)--- checkAuth errorHandler = do--- d <- getData myRqDataA--- case d of--- Nothing -> errorHandler--- Just a | isValid a -> mzero--- Just a | otherwise -> errorHandler--- @+-- > myRqData = do+-- > username <- lookInput "username"+-- > password <- lookInput "password"+-- > return (username, password)+-- > checkAuth errorHandler = do+-- > d <- getData myRqDataA+-- > case d of+-- > Nothing -> errorHandler+-- > Just a | isValid a -> mzero+-- > Just a | otherwise -> errorHandler getDataFn :: (ServerMonad m) => RqData a -> m (Maybe a) getDataFn rqData = do rq <- askRq return $ runReaderT rqData (rqInputs rq, rqCookies rq) --- | An varient of getData that uses FromData to chose your--- RqData for you. The example from 'getData' becomes:+-- | An variant of 'getData' that uses 'FromData' to chose your+-- 'RqData' for you. The example from 'getData' becomes: ----- @--- myRqData = do--- username <- lookInput \"username\"--- password <- lookInput \"password\"--- return (username, password)--- instance FromData (String,String) where--- fromData = myRqData--- checkAuth errorHandler = do--- d <- getData\'--- case d of--- Nothing -> errorHandler--- Just a | isValid a -> mzero--- Just a | otherwise -> errorHandler--- @+-- > myRqData = do+-- > username <- lookInput "username"+-- > password <- lookInput "password"+-- > return (username, password)+-- > instance FromData (String,String) where+-- > fromData = myRqData+-- > checkAuth errorHandler = do+-- > d <- getData'+-- > case d of+-- > Nothing -> errorHandler+-- > Just a | isValid a -> mzero+-- > Just a | otherwise -> errorHandler+-- getData :: (ServerMonad m, FromData a) => m (Maybe a) getData = getDataFn fromData @@ -1004,13 +1011,13 @@ withData :: (FromData a, MonadPlus m, ServerMonad m) => (a -> m r) -> m r withData = withDataFn fromData --- | withDataFn is like with data, but you pass in a RqData monad+-- | 'withDataFn' is like 'withData', but you pass in a 'RqData' monad -- for reading. withDataFn :: (MonadPlus m, ServerMonad m) => RqData a -> (a -> m r) -> m r withDataFn fn handle = getDataFn fn >>= maybe mzero handle --- | proxyServe is for creating ServerPartT's that proxy.--- The sole argument [String] is a list of allowed domains for+-- | 'proxyServe' is for creating 'ServerPartT's that proxy.+-- The sole argument @[String]@ is a list of allowed domains for -- proxying. This matches the domain part of the request -- and the wildcard * can be used. E.g. --@@ -1038,20 +1045,20 @@ superdomain = tail $ snd $ break (=='.') domain wildcards = (map (drop 2) $ filter ("*." `isPrefixOf`) allowed) --- | Takes a proxy Request and creates a Response. Your basic proxy--- building block. See 'unproxify'+-- | Takes a proxy 'Request' and creates a 'Response'. Your basic proxy+-- building block. See 'unproxify'. ----- TODO: this would be more useful if it didn\'t call "escape" (e.g. it let you+-- TODO: this would be more useful if it didn\'t call 'escape' (e.g. it let you -- modify the response afterwards, or set additional headers) proxyServe' :: (MonadIO m, FilterMonad Response m, WebMonad Response m) => Request-> m Response proxyServe' rq = liftIO (getResponse (unproxify rq)) >>= either (badGateway . toResponse . show) escape' -- | This is a reverse proxy implementation.--- see 'unrproxify'+-- See 'unrproxify'. ----- TODO: this would be more useful if it didn\'t call "escape", just like--- proxyServe'+-- TODO: this would be more useful if it didn\'t call 'escape', just like+-- proxyServe'. rproxyServe :: (MonadIO m) => String -- ^ defaultHost -> [(String, String)] -- ^ map to look up hostname mappings. For the reverse proxy@@ -1068,7 +1075,7 @@ Nothing -> mzero Just a -> handle a --- | A varient of require that can run in any monad, not just IO+-- | A variant of require that can run in any monad, not just IO. 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@@ -1097,27 +1104,31 @@ setHeader "Content-Length" (show $ L.length new) $ res { rsBody = new } --- | deprecated. Same as 'composeFilter'+-- | Deprecated: use 'composeFilter'. modifyResponse :: (FilterMonad a m) => (a -> a) -> m() modifyResponse = composeFilter {-# DEPRECATED modifyResponse "Use composeFilter" #-} --- | sets the return code in your response+-- | Set the return code in your response. setResponseCode :: FilterMonad Response m => Int -> m () setResponseCode code = composeFilter $ \r -> r{rsCode = code} --- | adds the cookie with a timeout to the response+-- | Add the cookie with a timeout to the response. addCookie :: (FilterMonad Response m) => Seconds -> Cookie -> m () addCookie sec = (addHeaderM "Set-Cookie") . mkCookieHeader sec --- | adds the list of cookie timeout pairs to the response+-- | Add the list of cookie timeout pairs to the response. addCookies :: (FilterMonad Response m) => [(Seconds, Cookie)] -> m () addCookies = mapM_ (uncurry addCookie) --- |honor if-modified-since header in Request--- If the 'Request' includes the if-modified-since header and the--- Response has not been modified, then return 304 (Not Modified),+-- | Expire the cookie immediately.+expireCookie :: (FilterMonad Response m) => String -> m () +expireCookie cookieName = addCookie 0 (mkCookie cookieName "")++-- |Honor an @if-modified-since@ header in a 'Request'.+-- If the 'Request' includes the @if-modified-since@ header and the+-- 'Response' has not been modified, then return 304 (Not Modified), -- otherwise return the 'Response'. ifModifiedSince :: CalendarTime -- ^ mod-time for the Response (MUST NOT be later than server's time of message origination) -> Request -- ^ incoming request (used to check for if-modified-since)@@ -1130,7 +1141,7 @@ then result 304 "" -- Not Modified else setHeader "Last-modified" repr response --- | same as setResponseCode status >> return val+-- | Same as @'setResponseCode' status >> return val@. resp :: (FilterMonad Response m) => Int -> b -> m b resp status val = setResponseCode status >> return val @@ -1138,11 +1149,11 @@ ok :: (FilterMonad Response m) => a -> m a ok = resp 200 --- | Respond with @500 Interal Server Error@+-- | Respond with @500 Interal Server Error@. internalServerError :: (FilterMonad Response m) => a -> m a internalServerError = resp 500 --- | Responds with @502 Bad Gateway@+-- | Responds with @502 Bad Gateway@. badGateway :: (FilterMonad Response m) => a -> m a badGateway = resp 502 @@ -1182,12 +1193,12 @@ tempRedirect val res = do modifyResponse $ redirect 307 val return res --- | deprecated. Just use msum+-- | Deprecated: use 'msum'. multi :: Monad m => [ServerPartT m a] -> ServerPartT m a multi = msum {-# DEPRECATED multi "Use msum instead" #-} --- | what is this for, exactly? I don't understand why @Show a@ is even in the context+-- | What is this for, exactly? I don't understand why @Show a@ is even in the context -- This appears to do nothing at all. debugFilter :: (MonadIO m, Show a) => ServerPartT m a -> ServerPartT m a debugFilter handle =@@ -1195,16 +1206,16 @@ r <- runServerPartT handle rq return r --- | a constructor for a ServerPartT when you don't care about the request+-- | A constructor for a 'ServerPartT' when you don't care about the request. anyRequest :: Monad m => WebT m a -> ServerPartT m a anyRequest x = withRequest $ \_ -> x --- | again, why is this useful?+-- | Again, why is this useful? applyRequest :: (ToMessage a, Monad m, Functor m) => ServerPartT m a -> Request -> Either (m Response) b applyRequest hs = simpleHTTP'' hs >>= return . Left --- | a simple HTTP basic authentication guard+-- | A simple HTTP basic authentication guard. basicAuth :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadPlus m) => String -- ^ the realm name -> M.Map String String -- ^ the username password map@@ -1232,8 +1243,8 @@ -- Query/Post data validating -------------------------------------------------------------- --- | Useful inside the RqData monad. Gets the named input parameter (either--- from a POST or a GET)+-- | Useful inside the 'RqData' monad. Gets the named input parameter+-- (either from a @POST@ or a @GET@ request). lookInput :: String -> RqData Input lookInput name = do inputs <- asks fst@@ -1241,16 +1252,16 @@ Nothing -> fail "input not found" Just i -> return i --- | Gets the named input parameter as a lazy byte string+-- | Get the named input parameter as a 'L.ByteString'. lookBS :: String -> RqData L.ByteString lookBS = fmap inputValue . lookInput --- | Gets the named input as a String+-- | Get the named input as a 'String'. look :: String -> RqData String look = fmap LU.toString . lookBS --- | Gets the named cookie--- the cookie name is case insensitive+-- | Get the named cookie.+-- The cookie name is case insensitive. lookCookie :: String -> RqData Cookie lookCookie name = do cookies <- asks snd@@ -1258,19 +1269,19 @@ Nothing -> fail "cookie not found" Just c -> return c --- | gets the named cookie as a string+-- | Get the named cookie as a 'String'. lookCookieValue :: String -> RqData String lookCookieValue = fmap cookieValue . lookCookie --- | gets the named cookie as the requested Read type+-- | Get the named cookie as the requested 'Read' type. readCookieValue :: Read a => String -> RqData a readCookieValue name = readM =<< fmap cookieValue (lookCookie name) --- | like look, but Reads for you.+-- | Like 'look', but 'Read's for you. lookRead :: Read a => String -> RqData a lookRead name = readM =<< look name --- | gets all the input parameters, and converts them to a string+-- | Get all the input parameters and convert them to a 'String'. lookPairs :: RqData [(String,String)] lookPairs = asks fst >>= return . map (\(n,vbs)->(n,LU.toString $ inputValue vbs)) @@ -1279,8 +1290,8 @@ -- 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.+-- | 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. --@@ -1300,18 +1311,15 @@ simpleErrorHandler :: (Monad m) => String -> ServerPartT m Response simpleErrorHandler err = ok $ toResponse $ ("An error occured: " ++ err) --- | This is a for use with mapServerPartT\' It it unwraps--- the interior monad for use with simpleHTTP. If you--- have a ServerPartT (ErrorT e m) a, this will convert--- that monad into a ServerPartT m a. Used with--- mapServerPartT\' to allow throwError and catchError inside your--- monad. Eg.+-- | This is a for use with 'mapServerPartT\'' It it unwraps the+-- interior monad for use with 'simpleHTTP'. If you have a+-- @ServerPartT (ErrorT e m) a@, this will convert that monad into a+-- @ServerPartT m a@. Used with 'mapServerPartT\'' to allow+-- 'throwError' and 'catchError' inside your monad. Eg. ----- @--- simpleHTTP conf $ mapServerPartT\' (spUnWrapErrorT failurePart) $ myPart \`catchError\` errorPart--- @+-- > simpleHTTP conf $ mapServerPartT' (spUnWrapErrorT failurePart) $ myPart `catchError` errorPart ----- Note that @failurePart@ will only be run if errorPart threw an error+-- Note that @failurePart@ will only be run if @errorPart@ threw an error -- so it doesn\'t have to be very complex. spUnwrapErrorT:: Monad m => (e -> ServerPartT m a) -> Request@@ -1339,38 +1347,32 @@ -- -- Example: (use 'noopValidator' instead of the default supplied by 'validateConf') ----- @--- simpleHTTP validateConf . anyRequest $ ok . setValidator noopValidator =<< htmlPage--- @+-- > 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'+-- |ServerPart version of 'setValidator'. -- -- Example: (Set validator to 'noopValidator') ----- @--- simpleHTTP validateConf $ setValidatorSP noopValidator (dir "ajax" ... )--- @+-- > simpleHTTP validateConf $ setValidatorSP noopValidator (dir "ajax" ... ) ----- See also: 'setValidator' setValidatorSP :: (Monad m, ToMessage r) => (Response -> IO Response) -> m r -> m Response setValidatorSP v sp = return . setValidator v . toResponse =<< sp --- |This extends 'nullConf' by enabling validation and setting+-- |Extend 'nullConf' by enabling validation and setting -- 'wdgHTMLValidator' as the default validator for @text\/html@. -- -- Example: ----- @--- simpleHTTP validateConf . anyRequest $ ok htmlPage--- @+-- > simpleHTTP validateConf . anyRequest $ ok htmlPage+-- validateConf :: Conf validateConf = nullConf { validator = Just wdgHTMLValidator } --- |Actually perform the validation on a 'Response'+-- |Actually perform the validation on a 'Response'. -- -- Run the validator specified in the 'Response'. If none is provide -- use the supplied default instead.@@ -1388,7 +1390,7 @@ -- This function expects the executable to be named @validate@ -- and it must be in the default @PATH@. ----- See also: 'setValidator', 'validateConf', 'lazyProcValidator'+-- See also: 'setValidator', 'validateConf', 'lazyProcValidator'. wdgHTMLValidator :: (MonadIO m, ToMessage r) => r -> m Response wdgHTMLValidator = liftIO . lazyProcValidator "validate" ["-w","--verbose","--charset=utf-8"] Nothing Nothing handledContentTypes . toResponse where@@ -1417,7 +1419,7 @@ -- NOTE: This function requirse the use of -threaded to avoid blocking. -- However, you probably need that for Happstack anyway. ----- See also: 'wdgHTMLValidator'+-- See also: 'wdgHTMLValidator'. lazyProcValidator :: FilePath -- ^ name of executable -> [String] -- ^ arguements to pass to the executable -> Maybe FilePath -- ^ optional path to working directory@@ -1451,6 +1453,18 @@ 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)++-- "Pattern match failure in do expression at src\AppControl.hs:43:24"+-- is converted to:+-- "src\AppControl.hs:43:24: Pattern match failure in do expression"+-- Then we output this to stderr. Help debugging under Emacs console when using GHCi.+-- This is GHC specific, but you may add your favourite compiler here also.+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