happstack-server 7.0.1 → 7.0.2
raw patch · 15 files changed
+78/−73 lines, 15 filesdep ~blaze-htmlPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: blaze-html
API changes (from Hackage documentation)
+ Happstack.Server.Routing: noTrailingSlash :: (ServerMonad m, MonadPlus m) => m ()
Files
- happstack-server.cabal +2/−2
- src/Happstack/Server/FileServe/BuildingBlocks.hs +1/−1
- src/Happstack/Server/Internal/Clock.hs +3/−3
- src/Happstack/Server/Internal/Compression.hs +7/−7
- src/Happstack/Server/Internal/Listen.hs +5/−5
- src/Happstack/Server/Internal/LogFormat.hs +4/−4
- src/Happstack/Server/Internal/Monads.hs +13/−13
- src/Happstack/Server/Internal/Multipart.hs +10/−10
- src/Happstack/Server/Internal/RFC822Headers.hs +17/−17
- src/Happstack/Server/Internal/TimeoutIO.hs +1/−1
- src/Happstack/Server/Internal/TimeoutManager.hs +1/−1
- src/Happstack/Server/Internal/TimeoutSocket.hs +5/−5
- src/Happstack/Server/Internal/Types.hs +2/−2
- src/Happstack/Server/Response.hs +2/−2
- src/Happstack/Server/Routing.hs +5/−0
happstack-server.cabal view
@@ -1,5 +1,5 @@ Name: happstack-server-Version: 7.0.1+Version: 7.0.2 Synopsis: Web related tools and services. Description: Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course <http://happstack.com/docs/crashcourse/index.html> License: BSD3@@ -82,7 +82,7 @@ Build-Depends: base, base64-bytestring == 0.1.*,- blaze-html >= 0.3 && < 0.5,+ blaze-html == 0.5.*, bytestring, containers, directory,
src/Happstack/Server/FileServe/BuildingBlocks.hs view
@@ -75,7 +75,7 @@ import System.Locale (defaultTimeLocale) import System.Log.Logger (Priority(DEBUG), logM) import System.Time (CalendarTime, formatCalendarTime, toCalendarTime, toUTCTime)-import Text.Blaze ((!))+import Text.Blaze.Html ((!)) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A
src/Happstack/Server/Internal/Clock.hs view
@@ -17,7 +17,7 @@ import qualified Data.ByteString.Char8 as B -data DateCache = DateCache { +data DateCache = DateCache { cachedPOSIXTime :: !(IORef POSIXTime) , cachedHttpDate :: !(IORef B.ByteString) }@@ -27,7 +27,7 @@ {-# INLINE formatHttpDate #-} mkTime :: IO (POSIXTime, B.ByteString)-mkTime = +mkTime = do now <- getPOSIXTime return (now, B.pack $ formatHttpDate (posixSecondsToUTCTime now)) @@ -42,7 +42,7 @@ return dateCache updater :: DateCache -> IO ()-updater dateCache = +updater dateCache = do threadDelay (10^(6 :: Int)) -- Every second (now, httpDate) <- mkTime writeIORef (cachedPOSIXTime dateCache) now
src/Happstack/Server/Internal/Compression.hs view
@@ -20,8 +20,8 @@ -- | reads the @Accept-Encoding@ header. Then, if possible -- will compress the response body with methods @gzip@ or @deflate@. ----- > main = --- > simpleHTTP nullConf $ +-- > main =+-- > simpleHTTP nullConf $ -- > do str <- compressedResponseFilter -- > return $ toResponse ("This response compressed using: " ++ str) compressedResponseFilter::@@ -41,7 +41,7 @@ setResponseCode 406 finishWith $ toResponse "" - Right encs@(a:_) -> return (a + Right encs@(a:_) -> return (a , "identity" `elem` encs , fromMaybe (fail badEncoding) (lookup a allEncodingHandlers)@@ -55,7 +55,7 @@ -- calls 'compressWithFilter' using 'GZ.compress'. -- -- see also: 'compressedResponseFilter'-gzipFilter::(FilterMonad Response m) => +gzipFilter::(FilterMonad Response m) => String -- ^ encoding to use for Content-Encoding header -> Bool -- ^ fallback to identity for SendFile -> m ()@@ -67,7 +67,7 @@ -- calls 'compressWithFilter' using 'Z.compress'. -- -- see also: 'compressedResponseFilter'-deflateFilter::(FilterMonad Response m) => +deflateFilter::(FilterMonad Response m) => String -- ^ encoding to use for Content-Encoding header -> Bool -- ^ fallback to identity for SendFile -> m ()@@ -86,7 +86,7 @@ -> Bool -- ^ fallback to identity for SendFile -> m () compressWithFilter compressor encoding identityAllowed =- composeFilter $ \r -> + composeFilter $ \r -> case r of Response{} -> setHeader "Content-Encoding" encoding $ r {rsBody = compressor $ rsBody r} _ | identityAllowed -> r@@ -172,7 +172,7 @@ ws _ <- char ',' ws- + encoding1 :: GenParser Char st ([Char], Maybe Double) encoding1 = do encoding <- many1 (alphaNum <|> char '-') <|> string "*"
src/Happstack/Server/Internal/Listen.hs view
@@ -11,10 +11,10 @@ import Control.Monad (forever, when) 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(..), +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, inet_addr) import System.IO.Error (isFullError)@@ -88,7 +88,7 @@ -- http:// loop log' NOTICE ("Listening for http:// on port " ++ show port') let eh (x::SomeException) = when ((fromException x) /= Just ThreadKilled) $ log' ERROR ("HTTP request failed with: " ++ show x)- work (sock, hn, p) = + work (sock, hn, p) = do tid <- myThreadId thandle <- register tm (killThread tid) let timeoutIO = TS.timeoutSocketIO thandle sock
src/Happstack/Server/Internal/LogFormat.hs view
@@ -17,13 +17,13 @@ -- hour = 2*digit -- minute = 2*digit -- second = 2*digit--- zone = (`+' | `-') 4*digit +-- zone = (`+' | `-') 4*digit formatTimeCombined :: FormatTime t => t -> String formatTimeCombined = formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z" -- | Format the request as describe in the Apache combined log format. -- http://httpd.apache.org/docs/2.2/logs.html#combined--- +-- -- The format is: "%h - %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-agent}i\"" -- %h: This is the IP address of the client (remote host) which made the request to the server. -- %u: This is the userid of the person requesting the document as determined by HTTP authentication.@@ -32,7 +32,7 @@ -- %>s: This is the status code that the server sends back to the client. -- %b: The last part indicates the size of the object returned to the client, not including the response headers. -- %{Referer}: The "Referer" (sic) HTTP request header.--- %{User-agent}: The User-Agent HTTP request header. +-- %{User-agent}: The User-Agent HTTP request header. formatRequestCombined :: FormatTime t => String -> String@@ -44,7 +44,7 @@ -> String -> String formatRequestCombined host user time requestLine responseCode size referer userAgent =- unwords + unwords [ host , user , "[" ++ formattedTime ++ "]"
src/Happstack/Server/Internal/Monads.hs view
@@ -51,7 +51,7 @@ -------------------------------------- -- HERE BEGINS ServerPartT definitions --- | 'ServerPartT' is a rich, featureful monad for web development. +-- | 'ServerPartT' is a rich, featureful monad for web development. -- -- see also: 'simpleHTTP', 'ServerMonad', 'FilterMonad', 'WebMonad', and 'HasRqData' newtype ServerPartT m a = ServerPartT { unServerPartT :: ReaderT Request (WebT m) a }@@ -100,8 +100,8 @@ anyRequest x = withRequest $ \_ -> x -- | Apply a function to transform the inner monad of--- @'ServerPartT' m@. --- +-- @'ServerPartT' m@.+-- -- Often used when transforming a monad with 'ServerPartT', since -- 'simpleHTTP' requires a @'ServerPartT' 'IO' a@. Refer to 'UnWebT' -- for an explanation of the structure of the monad.@@ -119,7 +119,7 @@ -- > unpackErrorT et = do -- > eitherV <- runErrorT et -- > return $ case eitherV of--- > Left err -> Just (Left $ toResponse $ +-- > Left err -> Just (Left $ toResponse $ -- > "Catastrophic failure " ++ show err -- > , filterFun $ \r -> r{rsCode = 500}) -- > Right x -> x@@ -271,7 +271,7 @@ liftBaseWith = defaultLiftBaseWith StMFilter restoreM = defaultRestoreM unStMFilter --- | A set of functions for manipulating filters. +-- | A set of functions for manipulating filters. -- -- 'ServerPartT' implements 'FilterMonad' 'Response' so these methods -- are the fundamental ways of manipulating 'Response' values.@@ -335,7 +335,7 @@ -- are not using 'mapServerPartT' then you do not need to wrap your -- head around this type. If you are -- the type is not as complex as -- it first appears.--- +-- -- It is worth discussing the unpacked structure of 'WebT' a bit as -- it's exposed in 'mapServerPartT' and 'mapWebT'. --@@ -406,7 +406,7 @@ class Monad m => WebMonad a m | m->a where -- abort the current computation and return a value finishWith :: a -- ^ value to return (For 'ServerPart', 'a' will always be the type 'Response')- -> m b + -> m b -- | Used to ignore all your filters and immediately end the -- computation. A combination of 'ignoreFilters' and 'finishWith'.@@ -521,7 +521,7 @@ -- 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 :: String -> a -> a-outputTraceMessage s c | "Pattern match failure " `isPrefixOf` s = +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@@ -536,7 +536,7 @@ finishWith $ res failHtml:: String->String-failHtml errString = +failHtml errString = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">" ++ "<html><head><title>Happstack " ++ ver ++ " Internal Server Error</title></head>"@@ -560,7 +560,7 @@ | otherwise = [c] --------------------------------------------------------------------------------- ServerMonad, FilterMonad, and WebMonad instances for ReaderT, StateT, +-- ServerMonad, FilterMonad, and WebMonad instances for ReaderT, StateT, -- WriterT, and RWST ------------------------------------------------------------------------------ @@ -587,7 +587,7 @@ instance (FilterMonad res m) => FilterMonad res (StateT s m) where setFilter f = lift $ setFilter f composeFilter = lift . composeFilter- getFilter m = mapStateT (\m' -> + getFilter m = mapStateT (\m' -> do ((b,s), f) <- getFilter m' return ((b, f), s)) m @@ -604,7 +604,7 @@ instance (FilterMonad res m, Monoid w) => FilterMonad res (WriterT w m) where setFilter f = lift $ setFilter f composeFilter = lift . composeFilter- getFilter m = mapWriterT (\m' -> + getFilter m = mapWriterT (\m' -> do ((b,w), f) <- getFilter m' return ((b, f), w)) m @@ -620,7 +620,7 @@ instance (FilterMonad res m, Monoid w) => FilterMonad res (RWST r w s m) where setFilter f = lift $ setFilter f composeFilter = lift . composeFilter- getFilter m = mapRWST (\m' -> + getFilter m = mapRWST (\m' -> do ((b,s,w), f) <- getFilter m' return ((b, f), s, w)) m
src/Happstack/Server/Internal/Multipart.hs view
@@ -9,7 +9,7 @@ import Data.Int (Int64) import Text.ParserCombinators.Parsec (parse) import Happstack.Server.Internal.Types (Input(..))-import Happstack.Server.Internal.RFC822Headers +import Happstack.Server.Internal.RFC822Headers ( ContentType(..), ContentDisposition(..), Header , getContentDisposition, getContentType, pHeaders) import System.IO (Handle, hClose, openBinaryTempFile)@@ -21,7 +21,7 @@ spanS f cs0 = spanS' 0 cs0 where spanS' _ Empty = (Empty, Empty) spanS' n bs@(Chunk c cs)- | n >= S.length c = + | n >= S.length c = let (x, y) = spanS' 0 cs in (Chunk c x, y) | not (f (Chunk (S.drop n c) cs)) = L.splitAt (fromIntegral n) bs@@ -47,7 +47,7 @@ dropWhileS :: (L.ByteString -> Bool) -> L.ByteString -> L.ByteString dropWhileS f cs0 = dropWhile' cs0- where dropWhile' bs + where dropWhile' bs | L.null bs = bs | f bs = dropWhile' (L.drop 1 bs) | otherwise = bs@@ -55,13 +55,13 @@ data BodyPart = BodyPart L.ByteString L.ByteString -- ^ headers body deriving (Eq, Ord, Read, Show) -data Work +data Work = BodyWork ContentType [(String, String)] L.ByteString- | HeaderWork L.ByteString + | HeaderWork L.ByteString type InputWorker = Work -> IO InputIter -data InputIter +data InputIter = Failed (Maybe (String, Input)) String | BodyResult (String, Input) InputWorker | HeaderResult [Header] InputWorker@@ -77,7 +77,7 @@ do (fn, h) <- openBinaryTempFile tmpDir filename (trunc, len) <- hPutLimit diskQuota h b hClose h- return (trunc, len, fn) + return (trunc, len, fn) defaultInputIter :: FileSaver -> FilePath -> Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> Work -> IO InputIter defaultInputIter fileSaver tmpDir diskCount ramCount headerCount maxDisk maxRAM maxHeader (BodyWork ctype ps b)@@ -85,7 +85,7 @@ | ramCount > maxRAM = return $ Failed Nothing ("ramCount (" ++ show ramCount ++ ") is greater than maxRAM (" ++ show maxRAM ++ ")") | otherwise = case lookup "filename" ps of- Nothing -> + Nothing -> let (b',rest) = L.splitAt (maxRAM - ramCount) b input = (fromMaybe "" $ lookup "name" ps , Input { inputValue = (Right b')@@ -148,7 +148,7 @@ (BodyResult {}) -> return $ Failed Nothing "bodyPartToInput: Got unexpected BodyResult." bodyPartsToInputs :: InputWorker -> [BodyPart] -> IO ([(String,Input)], Maybe String)-bodyPartsToInputs _ [] = +bodyPartsToInputs _ [] = return ([], Nothing) bodyPartsToInputs inputWorker (b:bs) = do r <- bodyPartToInput inputWorker b@@ -246,7 +246,7 @@ (before, after) | L.null after -> Nothing | otherwise -> Just (L.append before crlf, L.drop 4 after) {-# INLINE splitAtEmptyLine #-}- + -- | Split a string at the first CRLF. The CRLF is not included -- in any of the returned strings. splitAtCRLF :: ByteString -- ^ String to split.
src/Happstack/Server/Internal/RFC822Headers.hs view
@@ -18,13 +18,13 @@ ----------------------------------------------------------------------------- module Happstack.Server.Internal.RFC822Headers ( -- * Headers- Header, + Header, pHeader, pHeaders, parseHeaders, -- * Content-type- ContentType(..), + ContentType(..), getContentType, parseContentType, showContentType,@@ -36,9 +36,9 @@ -- * Content-disposition ContentDisposition(..),- getContentDisposition, + getContentDisposition, parseContentDisposition,- + -- * Utilities parseM ) where@@ -56,7 +56,7 @@ parseHeaders = parseM pHeaders pHeader :: Parser Header-pHeader = +pHeader = do name <- many1 headerNameChar char ':' many ws1@@ -66,7 +66,7 @@ return (map toLower name, concat (line:extraLines)) extraFieldLine :: Parser String-extraFieldLine = +extraFieldLine = do sp <- ws1 line <- lineString crLf@@ -92,14 +92,14 @@ -- Workaround for seemingly standardized web browser bug -- where nothing is escaped in the filename parameter -- of the content-disposition header in multipart/form-data- let litStr = if p_name == "filename" + let litStr = if p_name == "filename" then buggyLiteralString else literalString p_value <- litStr <|> p_token return (map toLower p_name, p_value) --- +-- -- * Content type -- @@ -109,7 +109,7 @@ -- string representation. -- See <http://www.ietf.org/rfc/rfc2046.txt> for more -- information about MIME media types.-data ContentType = +data ContentType = ContentType { -- | The top-level media type, the general type -- of the data. Common examples are@@ -121,7 +121,7 @@ -- \"jpeg\", \"form-data\", etc. ctSubtype :: String, -- | Media type parameters. On common example is- -- the charset parameter for the \"text\" + -- the charset parameter for the \"text\" -- top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@. ctParameters :: [(String, String)] }@@ -133,7 +133,7 @@ showContentType (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps pContentType :: Parser ContentType-pContentType = +pContentType = do many ws1 c_type <- p_token lexeme $ char '/'@@ -165,11 +165,11 @@ return $ ContentTransferEncoding (map toLower c_cte) parseContentTransferEncoding :: Monad m => String -> m ContentTransferEncoding-parseContentTransferEncoding = +parseContentTransferEncoding = parseM pContentTransferEncoding "Content-transfer-encoding" getContentTransferEncoding :: Monad m => [Header] -> m ContentTransferEncoding-getContentTransferEncoding hs = +getContentTransferEncoding hs = lookupM "content-transfer-encoding" hs >>= parseContentTransferEncoding --@@ -191,7 +191,7 @@ parseContentDisposition = parseM pContentDisposition "Content-disposition" getContentDisposition :: Monad m => [Header] -> m ContentDisposition-getContentDisposition hs = +getContentDisposition hs = lookupM "content-disposition" hs >>= parseContentDisposition --@@ -207,7 +207,7 @@ lookupM :: (Monad m, Eq a, Show a) => a -> [(a,b)] -> m b lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n --- +-- -- * Parsing utilities -- @@ -238,11 +238,11 @@ -- -- Note that this eats everything until the last double quote on the line. buggyLiteralString :: Parser String-buggyLiteralString = +buggyLiteralString = do char '\"' str <- manyTill anyChar (try lastQuote) return str- where lastQuote = do char '\"' + where lastQuote = do char '\"' notFollowedBy (try (many (noneOf "\"") >> char '\"')) headerNameChar :: Parser Char
src/Happstack/Server/Internal/TimeoutIO.hs view
@@ -1,4 +1,4 @@-module Happstack.Server.Internal.TimeoutIO +module Happstack.Server.Internal.TimeoutIO ( TimeoutIO(..) ) where
src/Happstack/Server/Internal/TimeoutManager.hs view
@@ -65,6 +65,6 @@ tickle (Handle _ iactive) = I.writeIORef iactive $! Active pause (Handle _ iactive) = I.writeIORef iactive $! Paused resume = tickle-cancel (Handle action iactive) = +cancel (Handle action iactive) = do I.writeIORef iactive $! Canceled I.writeIORef action $! (return ())
src/Happstack/Server/Internal/TimeoutSocket.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns, ScopedTypeVariables #-}-{- | +{- | -- borrowed from snap-server. Check there periodically for updates. -} module Happstack.Server.Internal.TimeoutSocket where@@ -34,7 +34,7 @@ return () {-# INLINE sPutTickle #-} -sGetContents :: TM.Handle +sGetContents :: TM.Handle -> Socket -- ^ Connected socket -> IO L.ByteString -- ^ Data received sGetContents handle sock = loop where@@ -52,8 +52,8 @@ sendFileIterWith' (iterTickle thandle) outs fp 65536 offset count iterTickle :: TM.Handle -> IO Iter -> IO ()-iterTickle thandle = - iterTickle' +iterTickle thandle =+ iterTickle' where iterTickle' :: (IO Iter -> IO ()) iterTickle' iter =@@ -71,7 +71,7 @@ timeoutSocketIO :: TM.Handle -> Socket -> TimeoutIO timeoutSocketIO handle socket = TimeoutIO { toHandle = handle- , toShutdown = sClose socket + , toShutdown = sClose socket , toPutLazy = sPutLazyTickle handle socket , toPut = sPutTickle handle socket , toGetContents = sGetContents handle socket
src/Happstack/Server/Internal/Types.hs view
@@ -84,7 +84,7 @@ -- -> Integer -- ^ size -- -> String -- ^ referer -- -> String -- ^ userAgent--- -> IO ()) +-- -> IO ()) type LogAccess time = ( String -> String@@ -94,7 +94,7 @@ -> Integer -> String -> String- -> IO ()) + -> IO ()) -- | HTTP configuration data Conf = Conf
src/Happstack/Server/Response.hs view
@@ -39,8 +39,8 @@ import Happstack.Server.SURI (ToSURI) import System.Locale (defaultTimeLocale) import System.Time (CalendarTime, formatCalendarTime)-import qualified Text.Blaze as Blaze-import qualified Text.Blaze.Renderer.Utf8 as Blaze+import qualified Text.Blaze.Html as Blaze+import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze import Text.Html (Html, renderHtml) import qualified Text.XHtml as XHtml (Html, renderHtml)
src/Happstack/Server/Routing.hs view
@@ -15,6 +15,7 @@ , dirs , nullDir , trailingSlash+ , noTrailingSlash , anyPath , path , uriRest@@ -246,3 +247,7 @@ -- for distinguishing between @foo@ and @foo/@ trailingSlash :: (ServerMonad m, MonadPlus m) => m () trailingSlash = guardRq $ \rq -> (last (rqUri rq)) == '/'++-- | The opposite of 'trailingSlash'.+noTrailingSlash :: (ServerMonad m, MonadPlus m) => m ()+noTrailingSlash = guardRq $ \rq -> (last (rqUri rq)) /= '/'