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: 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 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, diff --git a/src/Happstack/Server/FileServe/BuildingBlocks.hs b/src/Happstack/Server/FileServe/BuildingBlocks.hs --- a/src/Happstack/Server/FileServe/BuildingBlocks.hs +++ b/src/Happstack/Server/FileServe/BuildingBlocks.hs @@ -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 diff --git a/src/Happstack/Server/Internal/Clock.hs b/src/Happstack/Server/Internal/Clock.hs --- a/src/Happstack/Server/Internal/Clock.hs +++ b/src/Happstack/Server/Internal/Clock.hs @@ -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 diff --git a/src/Happstack/Server/Internal/Compression.hs b/src/Happstack/Server/Internal/Compression.hs --- a/src/Happstack/Server/Internal/Compression.hs +++ b/src/Happstack/Server/Internal/Compression.hs @@ -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 "*" diff --git a/src/Happstack/Server/Internal/Listen.hs b/src/Happstack/Server/Internal/Listen.hs --- a/src/Happstack/Server/Internal/Listen.hs +++ b/src/Happstack/Server/Internal/Listen.hs @@ -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 diff --git a/src/Happstack/Server/Internal/LogFormat.hs b/src/Happstack/Server/Internal/LogFormat.hs --- a/src/Happstack/Server/Internal/LogFormat.hs +++ b/src/Happstack/Server/Internal/LogFormat.hs @@ -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 ++ "]" diff --git a/src/Happstack/Server/Internal/Monads.hs b/src/Happstack/Server/Internal/Monads.hs --- a/src/Happstack/Server/Internal/Monads.hs +++ b/src/Happstack/Server/Internal/Monads.hs @@ -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 = "" ++ "Happstack " ++ ver ++ " Internal Server Error" @@ -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 diff --git a/src/Happstack/Server/Internal/Multipart.hs b/src/Happstack/Server/Internal/Multipart.hs --- a/src/Happstack/Server/Internal/Multipart.hs +++ b/src/Happstack/Server/Internal/Multipart.hs @@ -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. diff --git a/src/Happstack/Server/Internal/RFC822Headers.hs b/src/Happstack/Server/Internal/RFC822Headers.hs --- a/src/Happstack/Server/Internal/RFC822Headers.hs +++ b/src/Happstack/Server/Internal/RFC822Headers.hs @@ -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 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 diff --git a/src/Happstack/Server/Internal/TimeoutIO.hs b/src/Happstack/Server/Internal/TimeoutIO.hs --- a/src/Happstack/Server/Internal/TimeoutIO.hs +++ b/src/Happstack/Server/Internal/TimeoutIO.hs @@ -1,4 +1,4 @@ -module Happstack.Server.Internal.TimeoutIO +module Happstack.Server.Internal.TimeoutIO ( TimeoutIO(..) ) where diff --git a/src/Happstack/Server/Internal/TimeoutManager.hs b/src/Happstack/Server/Internal/TimeoutManager.hs --- a/src/Happstack/Server/Internal/TimeoutManager.hs +++ b/src/Happstack/Server/Internal/TimeoutManager.hs @@ -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 ()) diff --git a/src/Happstack/Server/Internal/TimeoutSocket.hs b/src/Happstack/Server/Internal/TimeoutSocket.hs --- a/src/Happstack/Server/Internal/TimeoutSocket.hs +++ b/src/Happstack/Server/Internal/TimeoutSocket.hs @@ -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 diff --git a/src/Happstack/Server/Internal/Types.hs b/src/Happstack/Server/Internal/Types.hs --- a/src/Happstack/Server/Internal/Types.hs +++ b/src/Happstack/Server/Internal/Types.hs @@ -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 diff --git a/src/Happstack/Server/Response.hs b/src/Happstack/Server/Response.hs --- a/src/Happstack/Server/Response.hs +++ b/src/Happstack/Server/Response.hs @@ -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) diff --git a/src/Happstack/Server/Routing.hs b/src/Happstack/Server/Routing.hs --- a/src/Happstack/Server/Routing.hs +++ b/src/Happstack/Server/Routing.hs @@ -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)) /= '/'