happstack-server 7.4.5 → 7.4.6
raw patch · 9 files changed
+153/−43 lines, 9 filesdep ~template-haskelldep ~transformersdep ~transformers-compat
Dependency ranges changed: template-haskell, transformers, transformers-compat
Files
- README.md +13/−0
- happstack-server.cabal +4/−4
- src/Happstack/Server/Compression.hs +17/−1
- src/Happstack/Server/Internal/Compression.hs +82/−16
- src/Happstack/Server/Internal/Handler.hs +11/−9
- src/Happstack/Server/Internal/MessageWrap.hs +1/−1
- src/Happstack/Server/Internal/Monads.hs +3/−2
- src/Happstack/Server/Internal/Types.hs +15/−3
- src/Happstack/Server/RqData.hs +7/−7
+ README.md view
@@ -0,0 +1,13 @@+# happstack-server [][hackage] [](https://travis-ci.org/Happstack/happstack-server)++[hackage]: https://hackage.haskell.org/package/happstack-server++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.++## Install++There are packages available on [hackage][] and [stack](https://www.stackage.org/lts-3.12/package/happstack-server-7.4.5).++## Documentation ++Please refer to the [Documentation on Hackage][hackage].
happstack-server.cabal view
@@ -1,5 +1,5 @@ Name: happstack-server-Version: 7.4.5+Version: 7.4.6 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@@ -10,7 +10,7 @@ Category: Web, Happstack Build-Type: Simple Cabal-Version: >= 1.8-Extra-Source-Files: tests/Happstack/Server/Tests.hs+Extra-Source-Files: tests/Happstack/Server/Tests.hs README.md source-repository head type: git@@ -95,9 +95,9 @@ time, time-compat, threads >= 0.5,- transformers >= 0.1.3 && < 0.5,+ transformers >= 0.1.3 && < 0.6, transformers-base >= 0.4 && < 0.5,- transformers-compat >= 0.3 && < 0.5,+ transformers-compat >= 0.3 && < 0.6, utf8-string >= 0.3.4 && < 1.1, xhtml, zlib
src/Happstack/Server/Compression.hs view
@@ -2,6 +2,22 @@ -- | Filter for compressing the 'Response' body. module Happstack.Server.Compression ( compressedResponseFilter+ , compressedResponseFilter'+ , compressWithFilter+ , gzipFilter+ , deflateFilter+ , identityFilter+ , starFilter+ , standardEncodingHandlers ) where -import Happstack.Server.Internal.Compression (compressedResponseFilter)+import Happstack.Server.Internal.Compression ( compressedResponseFilter+ , compressedResponseFilter'+ , compressWithFilter+ , gzipFilter+ , deflateFilter+ , identityFilter+ , starFilter+ , standardEncodingHandlers+ )+
src/Happstack/Server/Internal/Compression.hs view
@@ -2,10 +2,14 @@ -- | Filter for compressing the 'Response' body. module Happstack.Server.Internal.Compression ( compressedResponseFilter+ , compressedResponseFilter' , compressWithFilter , gzipFilter , deflateFilter+ , identityFilter+ , starFilter , encodings+ , standardEncodingHandlers ) where import Happstack.Server.SimpleHTTP import Text.ParserCombinators.Parsec@@ -20,14 +24,51 @@ -- | reads the @Accept-Encoding@ header. Then, if possible -- will compress the response body with methods @gzip@ or @deflate@. --+-- This function uses 'standardEncodingHandlers'. If you want to+-- provide alternative handers (perhaps to change compression levels),+-- see 'compressedResponseFilter''+-- -- > main = -- > simpleHTTP nullConf $ -- > do str <- compressedResponseFilter -- > return $ toResponse ("This response compressed using: " ++ str)-compressedResponseFilter::+compressedResponseFilter :: (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m) =>+ m String -- ^ name of the encoding chosen+compressedResponseFilter = compressedResponseFilter' standardEncodingHandlers++-- | reads the @Accept-Encoding@ header. Then, if possible+-- will compress the response body using one of the supplied filters.+--+-- A filter function takes two arguments. The first is a 'String' with+-- the value to be used as the 'Content-Encoding' header. The second+-- is 'Bool' which indicates if the compression filter is allowed to+-- fallback to @identity@.+--+-- This is important if the resource being sent using sendfile, since+-- sendfile does not provide a compression option. If @identity@ is+-- allowed, then the file can be sent uncompressed using sendfile. But+-- if @identity@ is not allowed, then the filter will need to return+-- error 406.+--+-- You should probably always include the @identity@ and @*@ encodings+-- as acceptable.+--+-- > myFilters :: (FilterMonad Response m) => [(String, String -> Bool -> m ()]+-- > myFilters = [ ("gzip" , gzipFilter)+-- > , ("identity", identityFilter)+-- > , ("*" , starFilter)+-- > ]+-- >+-- > main =+-- > simpleHTTP nullConf $+-- > do let filters =+-- > str <- compressedResponseFilter'+-- > return $ toResponse ("This response compressed using: " ++ str)+compressedResponseFilter' :: (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m)- => m String -- ^ name of the encoding chosen-compressedResponseFilter = do+ => [(String, String -> Bool -> m ())] -- ^ compression filter assoc list+ -> m String -- ^ name of the encoding chosen+compressedResponseFilter' encodingHandlers = do getHeaderM "Accept-Encoding" >>= (maybe (return "identity") installHandler) @@ -35,7 +76,7 @@ badEncoding = "Encoding returned not in the list of known encodings" installHandler accept = do- let eEncoding = bestEncoding allEncodings $ BS.unpack accept+ let eEncoding = bestEncoding (map fst encodingHandlers) $ BS.unpack accept (coding, identityAllowed, action) <- case eEncoding of Left _ -> do setResponseCode 406@@ -44,7 +85,7 @@ Right encs@(a:_) -> return (a , "identity" `elem` encs , fromMaybe (fail badEncoding)- (lookup a allEncodingHandlers)+ (lookup a encodingHandlers) ) Right [] -> fail badEncoding action coding identityAllowed@@ -73,13 +114,31 @@ -> m () deflateFilter = compressWithFilter Z.compress +-- | compression filter for the identity encoding (aka, do nothing)+--+-- see also: 'compressedResponseFilter'+identityFilter :: (FilterMonad Response m) =>+ String -- ^ encoding to use for Content-Encoding header+ -> Bool -- ^ fallback to identity for SendFile (irrelavant for this filter)+ -> m ()+identityFilter = compressWithFilter id++-- | compression filter for the * encoding+--+-- This filter always fails.+starFilter :: (FilterMonad Response m) =>+ String -- ^ encoding to use for Content-Encoding header+ -> Bool -- ^ fallback to identity for SendFile (irrelavant for this filter)+ -> m ()+starFilter _ _ = fail "chose * as content encoding"+ -- | Ignore the @Accept-Encoding@ header in the 'Request' and attempt to compress the body of the response using the supplied compressor. -- -- We can not compress files being transfered using 'SendFile'. If -- @identity@ is an allowed encoding, then just return the 'Response'--- unmodified. Otherwise we return "406 Not Acceptable".+-- unmodified. Otherwise we return @406 Not Acceptable@. ----- see also: 'gzipFilter' and 'defaultFilter'+-- see also: 'gzipFilter', 'deflateFilter', 'identityFilter', 'starFilter', 'compressedResponseFilter'' compressWithFilter :: (FilterMonad Response m) => (L.ByteString -> L.ByteString) -- ^ function to compress the body -> String -- ^ encoding to use for Content-Encoding header@@ -137,11 +196,18 @@ | otherwise = compare (m0 mI) (m0 mJ) -allEncodingHandlers:: (FilterMonad Response m) => [(String, String -> Bool -> m ())]-allEncodingHandlers = zip allEncodings handlers+-- | an assoc list of encodings and their corresponding compression+-- functions.+--+-- e.g.+--+-- > [("gzip", gzipFilter), ("identity", identityFilter), ("*",starFilter)]+standardEncodingHandlers :: (FilterMonad Response m) =>+ [(String, String -> Bool -> m ())]+standardEncodingHandlers = zip standardEncodings handlers -allEncodings :: [String]-allEncodings =+standardEncodings :: [String]+standardEncodings = ["gzip" ,"x-gzip" -- ,"compress" -- as far as I can tell there is no haskell library that supports this@@ -153,13 +219,13 @@ handlers::(FilterMonad Response m) => [String -> Bool -> m ()] handlers =- [gzipFilter- ,gzipFilter+ [ gzipFilter+ , gzipFilter -- ,compressFilter -- ,compressFilter- ,deflateFilter- , \encoding _ -> setHeaderM "Accept-Encoding" encoding- ,const $ fail "chose * as content encoding"+ , deflateFilter+ , identityFilter+ , starFilter ] -- | a parser for the Accept-Encoding header
src/Happstack/Server/Internal/Handler.hs view
@@ -194,15 +194,17 @@ method :: B.ByteString -> Method method r = fj $ lookup r mtable where fj (Just x) = x- fj Nothing = error "invalid request method"- mtable = [(P.pack "GET", GET),- (P.pack "HEAD", HEAD),- (P.pack "POST", POST),- (P.pack "PUT", PUT),- (P.pack "DELETE", DELETE),- (P.pack "TRACE", TRACE),- (P.pack "OPTIONS", OPTIONS),- (P.pack "CONNECT", CONNECT)]+ fj Nothing = EXTENSION r+ mtable = [ (P.pack "GET", GET)+ , (P.pack "HEAD", HEAD)+ , (P.pack "POST", POST)+ , (P.pack "PUT", PUT)+ , (P.pack "DELETE", DELETE)+ , (P.pack "TRACE", TRACE)+ , (P.pack "OPTIONS", OPTIONS)+ , (P.pack "CONNECT", CONNECT)+ , (P.pack "PATCH", PATCH)+ ] -- Result side
src/Happstack/Server/Internal/MessageWrap.hs view
@@ -43,7 +43,7 @@ } bodyInput :: (MonadIO m) => BodyPolicy -> Request -> m ([(String, Input)], Maybe String)-bodyInput _ req | ((rqMethod req /= POST) && (rqMethod req /= PUT)) || (not (isDecodable ctype)) =+bodyInput _ req | (not (canHaveBody (rqMethod req))) || (not (isDecodable ctype)) = do _ <- liftIO $ tryPutMVar (rqInputsBody req) [] return ([], Nothing) where
src/Happstack/Server/Internal/Monads.hs view
@@ -50,8 +50,9 @@ import Happstack.Server.Internal.Cookie (Cookie) import Happstack.Server.Internal.RFC822Headers (parseContentType)+import Happstack.Server.Internal.Types (canHaveBody) import Happstack.Server.Types-import Prelude (Bool(..), Either(..), Eq(..), Functor(..), IO(..), Monad(..), Char, Maybe(..), String, Show(..), ($), (.), (>), (++), (&&), (||), (=<<), const, concatMap, flip, id, otherwise, zip)+import Prelude (Bool(..), Either(..), Eq(..), Functor(..), IO, Monad(..), Char, Maybe(..), String, Show(..), ($), (.), (>), (++), (&&), (||), (=<<), const, concatMap, flip, id, otherwise, zip) -- | An alias for 'WebT' when using 'IO'. type Web a = WebT IO a@@ -235,7 +236,7 @@ smAskRqEnv :: (ServerMonad m, MonadIO m) => m ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)]) smAskRqEnv = do rq <- askRq- mbi <- liftIO $ if ((rqMethod rq == POST) || (rqMethod rq == PUT)) && (isDecodable (ctype rq))+ mbi <- liftIO $ if (canHaveBody (rqMethod rq)) && (isDecodable (ctype rq)) then readInputsBody rq else return (Just []) return (rqInputsQuery rq, mbi, rqCookies rq)
src/Happstack/Server/Internal/Types.hs view
@@ -13,7 +13,7 @@ redirect, -- redirect_, redirect', redirect'_, isHTTP1_0, isHTTP1_1, RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength,- HttpVersion(..), Length(..), Method(..), Headers, continueHTTP,+ HttpVersion(..), Length(..), Method(..), canHaveBody, Headers, continueHTTP, Host, ContentType(..), readDec', fromReadS, readM, FromReqURI(..) ) where@@ -132,8 +132,20 @@ logM "Happstack.Server.AccessLog.Combined" INFO $ formatRequestCombined host user time requestLine responseCode size referer userAgent -- | HTTP request method-data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT- deriving(Show,Read,Eq,Ord,Typeable,Data)+data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT | PATCH | EXTENSION ByteString+ deriving (Show,Read,Eq,Ord,Typeable,Data)++-- | Does the method support a message body?+--+-- For extension methods, we assume yes.+canHaveBody :: Method+ -> Bool+canHaveBody POST = True+canHaveBody PUT = True+canHaveBody PATCH = True+canHaveBody DELETE = True+canHaveBody (EXTENSION _) = True+canHaveBody _ = False -- | an HTTP header data HeaderPair = HeaderPair
src/Happstack/Server/RqData.hs view
@@ -536,11 +536,11 @@ let bdy = fromMaybeBody "lookPairsBS" "" mBody return $ map (\(n,vbs) -> (n, inputValue vbs)) (query ++ bdy) --- | The POST\/PUT body of a Request is not received or decoded unless+-- | The body of a 'Request' is not received or decoded unless -- this function is invoked. ----- It is an error to try to use the look functions for a POST\/PUT--- request with out first calling this function.+-- It is an error to try to use the look functions for a+-- 'Request' with out first calling this function. -- -- It is ok to call 'decodeBody' at the beginning of every request: --@@ -588,7 +588,7 @@ -- > (Right a) | otherwise -> errorHandler "invalid" -- -- NOTE: you must call 'decodeBody' prior to calling this function if--- the request method is POST or PUT.+-- the request method is POST, PUT, PATCH, etc. getDataFn :: (HasRqData m, ServerMonad m) => RqData a -- ^ 'RqData' monad to evaluate -> m (Either [String] a) -- ^ return 'Left' errors or 'Right' a@@ -600,7 +600,7 @@ -- or 'mzero' on failure. -- -- NOTE: you must call 'decodeBody' prior to calling this function if--- the request method is POST or PUT.+-- the request method is POST, PUT, PATCH, etc. withDataFn :: (HasRqData m, MonadPlus m, ServerMonad m) => RqData a -> (a -> m r) -> m r withDataFn fn handle = getDataFn fn >>= either (const mzero) handle @@ -630,14 +630,14 @@ -- > (Right a) | otherwise -> errorHandler "invalid" -- -- NOTE: you must call 'decodeBody' prior to calling this function if--- the request method is POST or PUT.+-- the request method is POST, PUT, PATCH, etc. getData :: (HasRqData m, ServerMonad m, FromData a) => m (Either [String] a) getData = getDataFn fromData -- | similar to 'getData' except it calls a subhandler on success or 'mzero' on failure. -- -- NOTE: you must call 'decodeBody' prior to calling this function if--- the request method is POST or PUT.+-- the request method is POST, PUT, PATCH, etc. withData :: (HasRqData m, FromData a, MonadPlus m, ServerMonad m) => (a -> m r) -> m r withData = withDataFn fromData