diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,3 @@ #!/usr/bin/env runhaskell import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks +main = defaultMainWithHooks simpleUserHooks diff --git a/happstack-server.cabal b/happstack-server.cabal --- a/happstack-server.cabal +++ b/happstack-server.cabal @@ -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 diff --git a/src/Happstack/Server/Cookie.hs b/src/Happstack/Server/Cookie.hs --- a/src/Happstack/Server/Cookie.hs +++ b/src/Happstack/Server/Cookie.hs @@ -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] diff --git a/src/Happstack/Server/HTTP/FileServe.hs b/src/Happstack/Server/HTTP/FileServe.hs --- a/src/Happstack/Server/HTTP/FileServe.hs +++ b/src/Happstack/Server/HTTP/FileServe.hs @@ -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] diff --git a/src/Happstack/Server/HTTP/Handler.hs b/src/Happstack/Server/HTTP/Handler.hs --- a/src/Happstack/Server/HTTP/Handler.hs +++ b/src/Happstack/Server/HTTP/Handler.hs @@ -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 " "] diff --git a/src/Happstack/Server/HTTP/Listen.hs b/src/Happstack/Server/HTTP/Listen.hs --- a/src/Happstack/Server/HTTP/Listen.hs +++ b/src/Happstack/Server/HTTP/Listen.hs @@ -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 () diff --git a/src/Happstack/Server/HTTP/Types.hs b/src/Happstack/Server/HTTP/Types.hs --- a/src/Happstack/Server/HTTP/Types.hs +++ b/src/Happstack/Server/HTTP/Types.hs @@ -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 diff --git a/src/Happstack/Server/HTTPClient/HTTP.hs b/src/Happstack/Server/HTTPClient/HTTP.hs --- a/src/Happstack/Server/HTTPClient/HTTP.hs +++ b/src/Happstack/Server/HTTPClient/HTTP.hs @@ -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 diff --git a/src/Happstack/Server/HTTPClient/TCP.hs b/src/Happstack/Server/HTTPClient/TCP.hs --- a/src/Happstack/Server/HTTPClient/TCP.hs +++ b/src/Happstack/Server/HTTPClient/TCP.hs @@ -35,7 +35,6 @@ import Data.List (elemIndex) import Data.Char import Data.IORef -import System.IO ----------------------------------------------------------------- ------------------ TCP Connections ------------------------------ diff --git a/src/Happstack/Server/MessageWrap.hs b/src/Happstack/Server/MessageWrap.hs --- a/src/Happstack/Server/MessageWrap.hs +++ b/src/Happstack/Server/MessageWrap.hs @@ -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 diff --git a/src/Happstack/Server/MinHaXML.hs b/src/Happstack/Server/MinHaXML.hs --- a/src/Happstack/Server/MinHaXML.hs +++ b/src/Happstack/Server/MinHaXML.hs @@ -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 diff --git a/src/Happstack/Server/Parts.hs b/src/Happstack/Server/Parts.hs --- a/src/Happstack/Server/Parts.hs +++ b/src/Happstack/Server/Parts.hs @@ -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 diff --git a/src/Happstack/Server/SimpleHTTP.hs b/src/Happstack/Server/SimpleHTTP.hs --- a/src/Happstack/Server/SimpleHTTP.hs +++ b/src/Happstack/Server/SimpleHTTP.hs @@ -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: -- -- 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