wai 3.0.3.0 → 3.0.4.0

raw patch · 4 files changed

+387/−4 lines, 4 filesdep +bytestring-builderdep +transformersdep +unix-compatdep ~blaze-builderdep ~bytestringnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring-builder, transformers, unix-compat

Dependency ranges changed: blaze-builder, bytestring

API changes (from Hackage documentation)

Files

• ChangeLog.md +9/−1
• Network/Wai/HTTP2.hs +271/−0
• Network/Wai/Internal.hs +102/−2
• wai.cabal +5/−1

@@ -1,6 +1,14 @@+## 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+* Allow blaze-builder 0.4  ## 3.0.2.2 

@@ -0,0 +1,271 @@+{-# 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           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 "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

@@ -1,6 +1,7 @@ {-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -- | Internal constructors and helper functions. Note that no guarantees are@@ -8,14 +9,25 @@ module Network.Wai.Internal where  import           Blaze.ByteString.Builder     (Builder)-import qualified Data.ByteString              as B+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.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.@@ -145,3 +157,91 @@ -- 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

@@ -1,5 +1,5 @@ Name:                wai-Version:             3.0.3.0+Version:             3.0.4.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 <http://www.stackage.org/package/wai>.@@ -21,12 +21,16 @@ Library   Build-Depends:     base                      >= 4        && < 5                    , bytestring                >= 0.9.1.4+                   , 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