wai-3.0.5.0/0000755000000000000000000000000012631246225010626 5ustar0000000000000000wai-3.0.5.0/ChangeLog.md0000644000000000000000000000060612631246225013001 0ustar0000000000000000## 3.0.5.0 * Avoid using the IsString Builder instance ## 3.0.4.0 * A new module Network.Wai.HTTP2 is exported. ## 3.0.3.0 * mapResponseHeaders, ifRequest and modifyResponse are exported. ## 3.0.2.3 * Allow blaze-builder 0.4 ## 3.0.2.2 * Clarify some documentation on `rawPathInfo`. [Relevant Github discussion](https://github.com/yesodweb/wai/issues/325#issuecomment-69896780). wai-3.0.5.0/LICENSE0000644000000000000000000000207512631246225011637 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. wai-3.0.5.0/README.md0000644000000000000000000000525712631246225012116 0ustar0000000000000000WAI: Web Application Interface ============================== Getting started --------------- You want a minimal example? Here it is! ~~~ {.haskell} {-# LANGUAGE OverloadedStrings #-} import Network.Wai import Network.HTTP.Types import Network.Wai.Handler.Warp (run) app :: Application app _ respond = do putStrLn "I've done some IO here" respond $ responseLBS status200 [("Content-Type", "text/plain")] "Hello, Web!" main :: IO () main = do putStrLn $ "http://localhost:8080/" run 8080 app ~~~ Put that code into a file named _hello.hs_ and install [wai] and [warp] from Hackage: cabal install wai warp Run it: runhaskell hello.hs Point your browser to: http://localhost:8080/ Serving static content ---------------------- We can modify our previous example to serve static content. For this create a file named _index.html_:

Hello, Web!

Now we redefine `responseBody` to refer to that file: ~~~ {.haskell} app2 :: Application app2 _ respond = respond index index :: Response index = responseFile status200 [("Content-Type", "text/html")] "index.html" Nothing ~~~ Basic dispatching ----------------- An `Application` maps `Request`s to `Response`s: ghci> :info Application type Application = Request -> IO Response Depending on the path info provided with each `Request` we can serve different `Response`s: ~~~ {.haskell} app3 :: Application app3 request respond = respond $ case rawPathInfo request of "/" -> index "/raw/" -> plainIndex _ -> notFound plainIndex :: Response plainIndex = responseFile status200 [("Content-Type", "text/plain")] "index.html" Nothing notFound :: Response notFound = responseLBS status404 [("Content-Type", "text/plain")] "404 - Not Found" ~~~ Doing without overloaded strings -------------------------------- For the sake of efficiency, WAI uses the [bytestring] package. We used GHCs [overloaded strings] to almost hide this fact. But we can easily do without. What follows is a more verbose definition of `notFound`, that works without GHC extensions: ~~~ {.haskell .ignore} import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as LB8 import Data.CaseInsensitive (mk) notFound = responseLBS status404 [(mk $ B8.pack "Content-Type", B8.pack "text/plain")] (LB8.pack "404 - Not Found") ~~~ [wai]: http://hackage.haskell.org/package/wai [warp]: http://hackage.haskell.org/package/warp [overloaded strings]: http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#overloaded-strings [bytestring]: http://hackage.haskell.org/package/bytestring wai-3.0.5.0/Setup.lhs0000644000000000000000000000016212631246225012435 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain wai-3.0.5.0/wai.cabal0000644000000000000000000000361412631246225012376 0ustar0000000000000000Name: wai Version: 3.0.5.0 Synopsis: Web Application Interface. Description: Provides a common protocol for communication between web applications and web servers. description: API docs and the README are available at . License: MIT License-file: LICENSE Author: Michael Snoyman Maintainer: michael@snoyman.com Homepage: https://github.com/yesodweb/wai Category: Web Build-Type: Simple Cabal-Version: >=1.8 Stability: Stable extra-source-files: README.md ChangeLog.md Source-repository head type: git location: git://github.com/yesodweb/wai.git Library Build-Depends: base >= 4 && < 5 , bytestring >= 0.10 , bytestring-builder >= 0.10.4.0 && < 0.10.7 , blaze-builder >= 0.2.1.4 && < 0.5 , network >= 2.2.1.5 , http-types >= 0.7 , text >= 0.7 , transformers >= 0.0 , unix-compat >= 0.2 , vault >= 0.3 && < 0.4 Exposed-modules: Network.Wai Network.Wai.HTTP2 Network.Wai.Internal ghc-options: -Wall test-suite test hs-source-dirs: test main-is: Spec.hs type: exitcode-stdio-1.0 ghc-options: -threaded cpp-options: -DTEST build-depends: base , wai , hspec , blaze-builder , bytestring other-modules: Network.WaiSpec source-repository head type: git location: git://github.com/yesodweb/wai.git wai-3.0.5.0/Network/0000755000000000000000000000000012631246225012257 5ustar0000000000000000wai-3.0.5.0/Network/Wai.hs0000644000000000000000000002765612631246225013353 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} {-# LANGUAGE CPP #-} {-| This module defines a generic web application interface. It is a common protocol between web servers and web applications. The overriding design principles here are performance and generality. To address performance, this library is built on top of the conduit and blaze-builder packages. The advantages of conduits over lazy IO have been debated elsewhere and so will not be addressed here. However, helper functions like 'responseLBS' allow you to continue using lazy IO if you so desire. Generality is achieved by removing many variables commonly found in similar projects that are not universal to all servers. The goal is that the 'Request' object contains only data which is meaningful in all circumstances. Please remember when using this package that, while your application may compile without a hitch against many different servers, there are other considerations to be taken when moving to a new backend. For example, if you transfer from a CGI application to a FastCGI one, you might suddenly find you have a memory leak. Conversely, a FastCGI application would be well served to preload all templates from disk when first starting; this would kill the performance of a CGI application. This package purposely provides very little functionality. You can find various middlewares, backends and utilities on Hackage. Some of the most commonly used include: [warp] [wai-extra] [wai-test] -} module Network.Wai ( -- * Types Application , Middleware , ResponseReceived -- * Request , Request , defaultRequest , RequestBodyLength (..) -- ** Request accessors , requestMethod , httpVersion , rawPathInfo , rawQueryString , requestHeaders , isSecure , remoteHost , pathInfo , queryString , requestBody , vault , requestBodyLength , requestHeaderHost , requestHeaderRange , strictRequestBody , lazyRequestBody -- * Response , Response , StreamingBody , FilePart (..) -- ** Response composers , responseFile , responseBuilder , responseLBS , responseStream , responseRaw -- ** Response accessors , responseStatus , responseHeaders -- ** Response modifiers , responseToStream , mapResponseHeaders -- * Middleware composition , ifRequest , modifyResponse ) where import Blaze.ByteString.Builder (Builder, fromLazyByteString) import Blaze.ByteString.Builder (fromByteString) import Control.Monad (unless) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Internal as LI import Data.ByteString.Lazy.Internal (defaultChunkSize) import Data.ByteString.Lazy.Char8 () import Data.Function (fix) import Data.Monoid (mempty) import qualified Network.HTTP.Types as H import Network.Socket (SockAddr (SockAddrInet)) import Network.Wai.Internal import qualified System.IO as IO import System.IO.Unsafe (unsafeInterleaveIO) ---------------------------------------------------------------- -- | Creating 'Response' from a file. responseFile :: H.Status -> H.ResponseHeaders -> FilePath -> Maybe FilePart -> Response responseFile = ResponseFile -- | Creating 'Response' from 'Builder'. -- -- Some questions and answers about the usage of 'Builder' here: -- -- Q1. Shouldn't it be at the user's discretion to use Builders internally and -- then create a stream of ByteStrings? -- -- A1. That would be less efficient, as we wouldn't get cheap concatenation -- with the response headers. -- -- Q2. Isn't it really inefficient to convert from ByteString to Builder, and -- then right back to ByteString? -- -- A2. No. If the ByteStrings are small, then they will be copied into a larger -- buffer, which should be a performance gain overall (less system calls). If -- they are already large, then blaze-builder uses an InsertByteString -- instruction to avoid copying. -- -- Q3. Doesn't this prevent us from creating comet-style servers, since data -- will be cached? -- -- A3. You can force blaze-builder to output a ByteString before it is an -- optimal size by sending a flush command. responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response responseBuilder = ResponseBuilder -- | Creating 'Response' from 'L.ByteString'. This is a wrapper for -- 'responseBuilder'. responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response responseLBS s h = ResponseBuilder s h . fromLazyByteString -- | Creating 'Response' from a stream of values. -- -- In order to allocate resources in an exception-safe manner, you can use the -- @bracket@ pattern outside of the call to @responseStream@. As a trivial -- example: -- -- @ -- app :: Application -- app req respond = bracket_ -- (putStrLn \"Allocating scarce resource\") -- (putStrLn \"Cleaning up\") -- $ respond $ responseStream status200 [] $ \\write flush -> do -- write $ fromByteString \"Hello\\n\" -- flush -- write $ fromByteString \"World\\n\" -- @ -- -- Note that in some cases you can use @bracket@ from inside @responseStream@ -- as well. However, placing the call on the outside allows your status value -- and response headers to depend on the scarce resource. -- -- Since 3.0.0 responseStream :: H.Status -> H.ResponseHeaders -> StreamingBody -> Response responseStream = ResponseStream -- | Create a response for a raw application. This is useful for \"upgrade\" -- situations such as WebSockets, where an application requests for the server -- to grant it raw network access. -- -- This function requires a backup response to be provided, for the case where -- the handler in question does not support such upgrading (e.g., CGI apps). -- -- In the event that you read from the request body before returning a -- @responseRaw@, behavior is undefined. -- -- Since 2.1.0 responseRaw :: (IO B.ByteString -> (B.ByteString -> IO ()) -> IO ()) -> Response -> Response responseRaw = ResponseRaw ---------------------------------------------------------------- -- | Accessing 'H.Status' in 'Response'. responseStatus :: Response -> H.Status responseStatus (ResponseFile s _ _ _) = s responseStatus (ResponseBuilder s _ _ ) = s responseStatus (ResponseStream s _ _ ) = s responseStatus (ResponseRaw _ res ) = responseStatus res -- | Accessing 'H.ResponseHeaders' in 'Response'. responseHeaders :: Response -> H.ResponseHeaders responseHeaders (ResponseFile _ hs _ _) = hs responseHeaders (ResponseBuilder _ hs _ ) = hs responseHeaders (ResponseStream _ hs _ ) = hs responseHeaders (ResponseRaw _ res) = responseHeaders res -- | Converting the body information in 'Response' to a 'StreamingBody'. responseToStream :: Response -> ( H.Status , H.ResponseHeaders , (StreamingBody -> IO a) -> IO a ) responseToStream (ResponseStream s h b) = (s, h, ($ b)) responseToStream (ResponseFile s h fp (Just part)) = ( s , h , \withBody -> IO.withBinaryFile fp IO.ReadMode $ \handle -> withBody $ \sendChunk _flush -> do IO.hSeek handle IO.AbsoluteSeek $ filePartOffset part let loop remaining | remaining <= 0 = return () loop remaining = do bs <- B.hGetSome handle defaultChunkSize unless (B.null bs) $ do let x = B.take remaining bs sendChunk $ fromByteString x loop $ remaining - B.length x loop $ fromIntegral $ filePartByteCount part ) responseToStream (ResponseFile s h fp Nothing) = ( s , h , \withBody -> IO.withBinaryFile fp IO.ReadMode $ \handle -> withBody $ \sendChunk _flush -> fix $ \loop -> do bs <- B.hGetSome handle defaultChunkSize unless (B.null bs) $ do sendChunk $ fromByteString bs loop ) responseToStream (ResponseBuilder s h b) = (s, h, \withBody -> withBody $ \sendChunk _flush -> sendChunk b) responseToStream (ResponseRaw _ res) = responseToStream res -- | Apply the provided function to the response header list of the Response. mapResponseHeaders :: (H.ResponseHeaders -> H.ResponseHeaders) -> Response -> Response mapResponseHeaders f (ResponseFile s h b1 b2) = ResponseFile s (f h) b1 b2 mapResponseHeaders f (ResponseBuilder s h b) = ResponseBuilder s (f h) b mapResponseHeaders f (ResponseStream s h b) = ResponseStream s (f h) b mapResponseHeaders _ r@(ResponseRaw _ _) = r ---------------------------------------------------------------- -- | The WAI application. -- -- Note that, since WAI 3.0, this type is structured in continuation passing -- style to allow for proper safe resource handling. This was handled in the -- past via other means (e.g., @ResourceT@). As a demonstration: -- -- @ -- app :: Application -- app req respond = bracket_ -- (putStrLn \"Allocating scarce resource\") -- (putStrLn \"Cleaning up\") -- (respond $ responseLBS status200 [] \"Hello World\") -- @ type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived -- | A default, blank request. -- -- Since 2.0.0 defaultRequest :: Request defaultRequest = Request { requestMethod = H.methodGet , httpVersion = H.http10 , rawPathInfo = B.empty , rawQueryString = B.empty , requestHeaders = [] , isSecure = False , remoteHost = SockAddrInet 0 0 , pathInfo = [] , queryString = [] , requestBody = return B.empty , vault = mempty , requestBodyLength = KnownLength 0 , requestHeaderHost = Nothing , requestHeaderRange = Nothing } -- | Middleware is a component that sits between the server and application. It -- can do such tasks as GZIP encoding or response caching. What follows is the -- general definition of middleware, though a middleware author should feel -- free to modify this. -- -- As an example of an alternate type for middleware, suppose you write a -- function to load up session information. The session information is simply a -- string map \[(String, String)\]. A logical type signature for this middleware -- might be: -- -- @ loadSession :: ([(String, String)] -> Application) -> Application @ -- -- Here, instead of taking a standard 'Application' as its first argument, the -- middleware takes a function which consumes the session information as well. type Middleware = Application -> Application -- | apply a function that modifies a response as a 'Middleware' modifyResponse :: (Response -> Response) -> Middleware modifyResponse f app req respond = app req $ respond . f -- | conditionally apply a 'Middleware' ifRequest :: (Request -> Bool) -> Middleware -> Middleware ifRequest rpred middle app req | rpred req = middle app req | otherwise = app req -- | Get the request body as a lazy ByteString. However, do /not/ use any lazy -- I\/O, instead reading the entire body into memory strictly. -- -- Since 3.0.1 strictRequestBody :: Request -> IO L.ByteString strictRequestBody req = loop id where loop front = do bs <- requestBody req if B.null bs then return $ front LI.Empty else loop (front . LI.Chunk bs) -- | Get the request body as a lazy ByteString. This uses lazy I\/O under the -- surface, and therefore all typical warnings regarding lazy I/O apply. -- -- Since 1.4.1 lazyRequestBody :: Request -> IO L.ByteString lazyRequestBody req = loop where loop = unsafeInterleaveIO $ do bs <- requestBody req if B.null bs then return LI.Empty else do bss <- loop return $ LI.Chunk bs bss wai-3.0.5.0/Network/Wai/0000755000000000000000000000000012631246225012777 5ustar0000000000000000wai-3.0.5.0/Network/Wai/HTTP2.hs0000644000000000000000000002656112631246225014206 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, RankNTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -- | An HTTP\/2-aware variant of the 'Network.Wai.Application' type. Compared -- to the original, this exposes the new functionality of server push and -- trailers, allows stream fragments to be sent in the form of file ranges, and -- allows the stream body to produce a value to be used in constructing the -- trailers. Existing @Applications@ can be faithfully upgraded to HTTP\/2 -- with 'promoteApplication' or served transparently over both protocols with -- the normal Warp 'Network.Wai.Handler.Warp.run' family of functions. -- -- An 'HTTP2Application' takes a 'Request' and a 'PushFunc' and produces a -- 'Responder' that will push any associated resources and send the response -- body. The response is always a stream of 'Builder's and file chunks. -- Equivalents of the 'Network.Wai.responseBuilder' family of functions are -- provided for creating 'Responder's conveniently. -- -- Pushed streams are handled by an IO action that triggers a server push. It -- returns @True@ if the @PUSH_PROMISE@ frame was sent, @False@ if not. Note -- this means it will still return @True@ if the client reset or ignored the -- stream. This gives handlers the freedom to implement their own heuristics -- for whether to actually push a resource, while also allowing middleware and -- frameworks to trigger server pushes automatically. module Network.Wai.HTTP2 ( -- * Applications HTTP2Application -- * Responder , Responder(..) , RespondFunc , Body , Chunk(..) , Trailers -- * Server push , PushFunc , PushPromise(..) , promiseHeaders -- * Conveniences , promoteApplication -- ** Responders , respond , respondCont , respondIO , respondFile , respondFilePart , respondNotFound , respondWith -- ** Stream Bodies , streamFilePart , streamBuilder , streamSimple ) where import Blaze.ByteString.Builder (Builder) import Blaze.ByteString.Builder.ByteString (fromByteString) import Control.Exception (Exception, throwIO) import Control.Monad.Trans.Cont (ContT(..)) import Data.ByteString (ByteString) #if __GLASGOW_HASKELL__ < 709 import Data.Functor ((<$>)) #endif import Data.IORef (newIORef, readIORef, writeIORef) #if __GLASGOW_HASKELL__ < 709 import Data.Monoid (mempty) #endif import Data.Typeable (Typeable) import qualified Network.HTTP.Types as H import Network.Wai (Application) import Network.Wai.Internal ( FilePart(..) , Request(requestHeaders) , Response(..) , ResponseReceived(..) , StreamingBody , adjustForFilePart , chooseFilePart , tryGetFileSize ) -- | Headers sent after the end of a data stream, as defined by section 4.1.2 of -- the HTTP\/1.1 spec (RFC 7230), and section 8.1 of the HTTP\/2 spec. type Trailers = [H.Header] -- | The synthesized request and headers of a pushed stream. data PushPromise = PushPromise { promisedMethod :: H.Method , promisedPath :: ByteString , promisedAuthority :: ByteString , promisedScheme :: ByteString , promisedHeader :: H.RequestHeaders } -- | The HTTP\/2-aware equivalent of 'Network.Wai.Application'. type HTTP2Application = Request -> PushFunc -> Responder -- | Part of a streaming response -- either a 'Builder' or a range of a file. data Chunk = FileChunk FilePath FilePart | BuilderChunk Builder -- | The streaming body of a response. Equivalent to -- 'Network.Wai.StreamingBody' except that it can also write file ranges and -- return the stream's trailers. type Body = (Chunk -> IO ()) -> IO () -> IO Trailers -- | Given to 'Responders'; provide a status, headers, and a stream body, and -- we'll give you a token proving you called the 'RespondFunc'. type RespondFunc s = H.Status -> H.ResponseHeaders -> Body -> IO s -- | The result of an 'HTTP2Application'; or, alternately, an application -- that's independent of the request. This is a continuation-passing style -- function that first provides a response by calling the given respond -- function, then returns the request's 'Trailers'. -- -- The respond function is similar to the one in 'Network.Wai.Application', but -- it only takes a streaming body, the status and headers are curried, and it -- also produces trailers for the stream. newtype Responder = Responder { runResponder :: forall s. RespondFunc s -> IO s } -- | A function given to an 'HTTP2Application' to initiate a server-pushed -- stream. Its argument is the same as the result of an 'HTTP2Application', so -- you can either implement the response inline, or call your own application -- to create the response. -- -- The result is 'True' if the @PUSH_PROMISE@ frame will be sent, or 'False' if -- it will not. This can happen if server push is disabled, the concurrency -- limit of server-initiated streams is reached, or the associated stream has -- already been closed. -- -- This function shall ensure that stream data provided after it returns will -- be sent after the @PUSH_PROMISE@ frame, so that servers can implement the -- requirement that any pushed stream for a resource be initiated before -- sending DATA frames that reference it. type PushFunc = PushPromise -> Responder -> IO Bool -- | Create the 'H.RequestHeaders' corresponding to the given 'PushPromise'. -- -- This is primarily useful for WAI handlers like Warp, and application -- implementers are unlikely to use it directly. promiseHeaders :: PushPromise -> H.RequestHeaders promiseHeaders p = [ (":method", promisedMethod p) , (":path", promisedPath p) , (":authority", promisedAuthority p) , (":scheme", promisedScheme p) ] ++ promisedHeader p -- | Create a response body consisting of a single range of a file. Does not -- set Content-Length or Content-Range headers. For that, use -- 'respondFilePart' or 'respondFile'. streamFilePart :: FilePath -> FilePart -> Body streamFilePart path part write _ = write (FileChunk path part) >> return [] -- | Respond with a single range of a file, adding the Accept-Ranges, -- Content-Length and Content-Range headers and changing the status to 206 as -- appropriate. -- -- If you want the range to be inferred automatically from the Range header, -- use 'respondFile' instead. On the other hand, if you want to avoid the -- automatic header and status adjustments, use 'respond' and 'streamFilePart' -- directly. respondFilePart :: H.Status -> H.ResponseHeaders -> FilePath -> FilePart -> Responder respondFilePart s h path part = Responder $ \k -> do let (s', h') = adjustForFilePart s h part k s' h' $ streamFilePart path part -- | Serve the requested range of the specified file (based on the Range -- header), using the given 'H.Status' and 'H.ResponseHeaders' as a base. If -- the file is not accessible, the status will be replaced with 404 and a -- default not-found message will be served. If a partial file is requested, -- the status will be replaced with 206 and the Content-Range header will be -- added. The Content-Length header will always be added. respondFile :: H.Status -> H.ResponseHeaders -> FilePath -> H.RequestHeaders -> Responder respondFile s h path reqHdrs = Responder $ \k -> do fileSize <- tryGetFileSize path case fileSize of Left _ -> runResponder (respondNotFound h) k Right size -> runResponder (respondFileExists s h path size reqHdrs) k -- As 'respondFile', but with prior knowledge of the file's existence and size. respondFileExists :: H.Status -> H.ResponseHeaders -> FilePath -> Integer -> H.RequestHeaders -> Responder respondFileExists s h path size reqHdrs = respondFilePart s h path $ chooseFilePart size $ lookup H.hRange reqHdrs -- | Respond with a minimal 404 page with the given headers. respondNotFound :: H.ResponseHeaders -> Responder respondNotFound h = Responder $ \k -> k H.notFound404 h' $ streamBuilder $ fromByteString "File not found." where contentType = (H.hContentType, "text/plain; charset=utf-8") h' = contentType:filter ((/=H.hContentType) . fst) h -- | Construct a 'Responder' that will just call the 'RespondFunc' with the -- given arguments. respond :: H.Status -> H.ResponseHeaders -> Body -> Responder respond s h b = Responder $ \k -> k s h b -- | Fold the given bracketing action into a 'Responder'. Note the first -- argument is isomorphic to @Codensity IO a@ or @forall s. ContT s IO a@, and -- is the type of a partially-applied 'Control.Exception.bracket' or -- @with@-style function. -- -- > respondWith (bracket acquire release) $ -- > \x -> respondNotFound [("x", show x)] -- -- is equivalent to -- -- > Responder $ \k -> bracket acquire release $ -- > \x -> runResponder (respondNotFound [("x", show x)] k -- -- This is morally equivalent to ('>>=') on 'Codensity' 'IO'. respondWith :: (forall s. (a -> IO s) -> IO s) -> (a -> Responder) -> Responder respondWith with f = respondCont $ f <$> ContT with -- | Fold the 'ContT' into the contained 'Responder'. respondCont :: (forall r. ContT r IO Responder) -> Responder respondCont cont = Responder $ \k -> runContT cont $ \r -> runResponder r k -- | Fold the 'IO' into the contained 'Responder'. respondIO :: IO Responder -> Responder respondIO io = Responder $ \k -> io >>= \r -> runResponder r k -- | Create a response body consisting of a single builder. streamBuilder :: Builder -> Body streamBuilder builder write _ = write (BuilderChunk builder) >> return [] -- | Create a response body of a stream of 'Builder's. streamSimple :: StreamingBody -> Body streamSimple body write flush = body (write . BuilderChunk) flush >> return [] -- | Use a normal WAI 'Response' to send the response. Useful if you're -- sharing code between HTTP\/2 applications and HTTP\/1 applications. -- -- The 'Request' is used to determine the right file range to serve for -- 'ResponseFile'. promoteResponse :: Request -> Response -> Responder promoteResponse req response = case response of (ResponseBuilder s h b) -> Responder $ \k -> k s h (streamBuilder b) (ResponseStream s h body) -> Responder $ \k -> k s h (streamSimple body) (ResponseRaw _ fallback) -> promoteResponse req fallback (ResponseFile s h path mpart) -> maybe (respondFile s h path $ requestHeaders req) (respondFilePart s h path) mpart -- | An 'Network.Wai.Application' we tried to promote neither called its -- respond action nor raised; this is only possible if it imported the -- 'ResponseReceived' constructor and used it to lie about having called the -- action. data RespondNeverCalled = RespondNeverCalled deriving (Show, Typeable) instance Exception RespondNeverCalled -- | Promote a normal WAI 'Application' to an 'HTTP2Application' by ignoring -- the HTTP/2-specific features. promoteApplication :: Application -> HTTP2Application promoteApplication app req _ = Responder $ \k -> do -- In HTTP2Applications, the Responder is required to ferry a value of -- arbitrary type from the RespondFunc back to the caller of the -- application, but in Application the type is fixed to ResponseReceived. -- To add this extra power to an Application, we have to squirrel it away -- in an IORef as a hack. ref <- newIORef Nothing let k' r = do writeIORef ref . Just =<< runResponder (promoteResponse req r) k return ResponseReceived ResponseReceived <- app req k' readIORef ref >>= maybe (throwIO RespondNeverCalled) return wai-3.0.5.0/Network/Wai/Internal.hs0000644000000000000000000002434512631246225015117 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -- | Internal constructors and helper functions. Note that no guarantees are -- given for stability of these interfaces. module Network.Wai.Internal where import Blaze.ByteString.Builder (Builder) import Control.Exception (IOException, try) import qualified Data.ByteString as B hiding (pack) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Char8 as B (pack, readInteger) import qualified Data.ByteString.Lazy as L #if __GLASGOW_HASKELL__ < 709 import Data.Functor ((<$>)) #endif import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Typeable (Typeable) import Data.Vault.Lazy (Vault) import Data.Word (Word64) import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as HH import Network.Socket (SockAddr) import Numeric (showInt) import Data.List (intercalate) import qualified System.PosixCompat.Files as P -- | Information on the request sent by the client. This abstracts away the -- details of the underlying implementation. data Request = Request { -- | Request method such as GET. requestMethod :: H.Method -- | HTTP version such as 1.1. , httpVersion :: H.HttpVersion -- | Extra path information sent by the client. The meaning varies slightly -- depending on backend; in a standalone server setting, this is most likely -- all information after the domain name. In a CGI application, this would be -- the information following the path to the CGI executable itself. -- -- Middlewares and routing tools should not modify this raw value, as it may -- be used for such things as creating redirect destinations by applications. -- Instead, if you are writing a middleware or routing framework, modify the -- @pathInfo@ instead. This is the approach taken by systems like Yesod -- subsites. -- -- /Note/: At the time of writing this documentation, there is at least one -- system (@Network.Wai.UrlMap@ from @wai-extra@) that does not follow the -- above recommendation. Therefore, it is recommended that you test the -- behavior of your application when using @rawPathInfo@ and any form of -- library that might modify the @Request@. , rawPathInfo :: B.ByteString -- | If no query string was specified, this should be empty. This value -- /will/ include the leading question mark. -- Do not modify this raw value - modify queryString instead. , rawQueryString :: B.ByteString -- | A list of headers (a pair of key and value) in an HTTP request. , requestHeaders :: H.RequestHeaders -- | Was this request made over an SSL connection? -- -- Note that this value will /not/ tell you if the client originally made -- this request over SSL, but rather whether the current connection is SSL. -- The distinction lies with reverse proxies. In many cases, the client will -- connect to a load balancer over SSL, but connect to the WAI handler -- without SSL. In such a case, 'isSecure' will be 'False', but from a user -- perspective, there is a secure connection. , isSecure :: Bool -- | The client\'s host information. , remoteHost :: SockAddr -- | Path info in individual pieces - the URL without a hostname/port and -- without a query string, split on forward slashes. , pathInfo :: [Text] -- | Parsed query string information. , queryString :: H.Query -- | Get the next chunk of the body. Returns 'B.empty' when the -- body is fully consumed. , requestBody :: IO B.ByteString -- | A location for arbitrary data to be shared by applications and middleware. , vault :: Vault -- | The size of the request body. In the case of a chunked request body, -- this may be unknown. -- -- Since 1.4.0 , requestBodyLength :: RequestBodyLength -- | The value of the Host header in a HTTP request. -- -- Since 2.0.0 , requestHeaderHost :: Maybe B.ByteString -- | The value of the Range header in a HTTP request. -- -- Since 2.0.0 , requestHeaderRange :: Maybe B.ByteString } deriving (Typeable) instance Show Request where show Request{..} = "Request {" ++ intercalate ", " [a ++ " = " ++ b | (a,b) <- fields] ++ "}" where fields = [("requestMethod",show requestMethod) ,("httpVersion",show httpVersion) ,("rawPathInfo",show rawPathInfo) ,("rawQueryString",show rawQueryString) ,("requestHeaders",show requestHeaders) ,("isSecure",show isSecure) ,("remoteHost",show remoteHost) ,("pathInfo",show pathInfo) ,("queryString",show queryString) ,("requestBody","") ,("vault","") ,("requestBodyLength",show requestBodyLength) ,("requestHeaderHost",show requestHeaderHost) ,("requestHeaderRange",show requestHeaderRange) ] data Response = ResponseFile H.Status H.ResponseHeaders FilePath (Maybe FilePart) | ResponseBuilder H.Status H.ResponseHeaders Builder | ResponseStream H.Status H.ResponseHeaders StreamingBody | ResponseRaw (IO B.ByteString -> (B.ByteString -> IO ()) -> IO ()) Response deriving Typeable -- | Represents a streaming HTTP response body. It's a function of two -- parameters; the first parameter provides a means of sending another chunk of -- data, and the second parameter provides a means of flushing the data to the -- client. -- -- Since 3.0.0 type StreamingBody = (Builder -> IO ()) -> IO () -> IO () -- | The size of the request body. In the case of chunked bodies, the size will -- not be known. -- -- Since 1.4.0 data RequestBodyLength = ChunkedBody | KnownLength Word64 deriving Show -- | Information on which part to be sent. -- Sophisticated application handles Range (and If-Range) then -- create 'FilePart'. data FilePart = FilePart { filePartOffset :: Integer , filePartByteCount :: Integer , filePartFileSize :: Integer } deriving Show -- | A special datatype to indicate that the WAI handler has received the -- response. This is to avoid the need for Rank2Types in the definition of -- Application. -- -- It is /highly/ advised that only WAI handlers import and use the data -- constructor for this data type. -- -- Since 3.0.0 data ResponseReceived = ResponseReceived deriving Typeable -- | Look up the size of a file in 'Right' or the 'IOException' in 'Left'. tryGetFileSize :: FilePath -> IO (Either IOException Integer) tryGetFileSize path = fmap (fromIntegral . P.fileSize) <$> try (P.getFileStatus path) -- | \"Content-Range\". hContentRange :: H.HeaderName hContentRange = "Content-Range" -- | \"Accept-Ranges\". hAcceptRanges :: H.HeaderName hAcceptRanges = "Accept-Ranges" -- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header' -- for the range specified. contentRangeHeader :: Integer -> Integer -> Integer -> H.Header contentRangeHeader beg end total = (hContentRange, range) where range = B.pack -- building with ShowS $ 'b' : 'y': 't' : 'e' : 's' : ' ' : (if beg > end then ('*':) else showInt beg . ('-' :) . showInt end) ( '/' : showInt total "") -- | Given the full size of a file and optionally a Range header value, -- determine the range to serve by parsing the range header and obeying it, or -- serving the whole file if it's absent or malformed. chooseFilePart :: Integer -> Maybe B.ByteString -> FilePart chooseFilePart size Nothing = FilePart 0 size size chooseFilePart size (Just range) = case parseByteRanges range >>= listToMaybe of -- Range is broken Nothing -> FilePart 0 size size Just hrange -> checkRange hrange where checkRange (H.ByteRangeFrom beg) = fromRange beg (size - 1) checkRange (H.ByteRangeFromTo beg end) = fromRange beg (min (size - 1) end) checkRange (H.ByteRangeSuffix count) = fromRange (max 0 (size - count)) (size - 1) fromRange beg end = FilePart beg (end - beg + 1) size -- | Adjust the given 'H.Status' and 'H.ResponseHeaders' based on the given -- 'FilePart'. This means replacing the status with 206 if the response is -- partial, and adding the Content-Length and Accept-Ranges (always) and -- Content-Range (if appropriate) headers. adjustForFilePart :: H.Status -> H.ResponseHeaders -> FilePart -> (H.Status, H.ResponseHeaders) adjustForFilePart s h part = (s', h'') where off = filePartOffset part len = filePartByteCount part size = filePartFileSize part contentRange = contentRangeHeader off (off + len - 1) size lengthBS = L.toStrict $ B.toLazyByteString $ B.integerDec len s' = if filePartByteCount part /= size then H.partialContent206 else s h' = (H.hContentLength, lengthBS):(hAcceptRanges, "bytes"):h h'' = (if len == size then id else (contentRange:)) h' -- | Parse the value of a Range header into a 'HH.ByteRanges'. parseByteRanges :: B.ByteString -> Maybe HH.ByteRanges parseByteRanges bs1 = do bs2 <- stripPrefix "bytes=" bs1 (r, bs3) <- range bs2 ranges (r:) bs3 where range bs2 = do (i, bs3) <- B.readInteger bs2 if i < 0 -- has prefix "-" ("-0" is not valid, but here treated as "0-") then Just (HH.ByteRangeSuffix (negate i), bs3) else do bs4 <- stripPrefix "-" bs3 case B.readInteger bs4 of Just (j, bs5) | j >= i -> Just (HH.ByteRangeFromTo i j, bs5) _ -> Just (HH.ByteRangeFrom i, bs4) ranges front bs3 | B.null bs3 = Just (front []) | otherwise = do bs4 <- stripPrefix "," bs3 (r, bs5) <- range bs4 ranges (front . (r:)) bs5 stripPrefix x y | x `B.isPrefixOf` y = Just (B.drop (B.length x) y) | otherwise = Nothing wai-3.0.5.0/test/0000755000000000000000000000000012631246225011605 5ustar0000000000000000wai-3.0.5.0/test/Spec.hs0000644000000000000000000000005412631246225013032 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} wai-3.0.5.0/test/Network/0000755000000000000000000000000012631246225013236 5ustar0000000000000000wai-3.0.5.0/test/Network/WaiSpec.hs0000644000000000000000000000716612631246225015137 0ustar0000000000000000module Network.WaiSpec (spec) where import Test.Hspec import Test.Hspec.QuickCheck (prop) import Network.Wai import Network.Wai.Internal (Request (Request)) import Data.IORef import Data.Monoid import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Blaze.ByteString.Builder (toByteString, Builder, fromWord8) import Control.Monad (forM_) spec :: Spec spec = do describe "responseToStream" $ do let getBody res = do let (_, _, f) = responseToStream res f $ \streamingBody -> do builderRef <- newIORef mempty let add :: Builder -> IO () add b = atomicModifyIORef builderRef $ \builder -> (builder `mappend` b, ()) flush :: IO () flush = return () streamingBody add flush fmap toByteString $ readIORef builderRef prop "responseLBS" $ \bytes -> do body <- getBody $ responseLBS undefined undefined $ L.pack bytes body `shouldBe` S.pack bytes prop "responseBuilder" $ \bytes -> do body <- getBody $ responseBuilder undefined undefined $ mconcat $ map fromWord8 bytes body `shouldBe` S.pack bytes prop "responseStream" $ \chunks -> do body <- getBody $ responseStream undefined undefined $ \sendChunk _ -> forM_ chunks $ \chunk -> sendChunk $ mconcat $ map fromWord8 chunk body `shouldBe` S.concat (map S.pack chunks) it "responseFile total" $ do let fp = "wai.cabal" body <- getBody $ responseFile undefined undefined fp Nothing expected <- S.readFile fp body `shouldBe` expected prop "responseFile partial" $ \offset' count' -> do let fp = "wai.cabal" totalBS <- S.readFile fp let total = S.length totalBS offset = abs offset' `mod` total count = abs count' `mod` (total - offset) body <- getBody $ responseFile undefined undefined fp $ Just FilePart { filePartOffset = fromIntegral offset , filePartByteCount = fromIntegral count , filePartFileSize = fromIntegral total } let expected = S.take count $ S.drop offset totalBS body `shouldBe` expected describe "lazyRequestBody" $ do prop "works" $ \chunks -> do ref <- newIORef $ map S.pack $ filter (not . null) chunks let req = Request { requestBody = atomicModifyIORef ref $ \bss -> case bss of [] -> ([], S.empty) x:y -> (y, x) } body <- lazyRequestBody req body `shouldBe` L.fromChunks (map S.pack chunks) it "is lazy" $ do let req = Request { requestBody = error "requestBody" } _ <- lazyRequestBody req return () describe "strictRequestBody" $ do prop "works" $ \chunks -> do ref <- newIORef $ map S.pack $ filter (not . null) chunks let req = Request { requestBody = atomicModifyIORef ref $ \bss -> case bss of [] -> ([], S.empty) x:y -> (y, x) } body <- strictRequestBody req body `shouldBe` L.fromChunks (map S.pack chunks)