mirror of
https://github.com/typeable/wai.git
synced 2025-01-07 06:36:36 +03:00
Switch to conduits.
All packages are getting bumped to 1.0 to signify the difference.
This commit is contained in:
Michael Snoyman
parent
46357e53d6
commit
ad8eafc699
@ -1,6 +1,6 @@
|
||||
#!/bin/bash
|
||||
|
||||
pkgs=( ./wai
|
||||
pkgs=( ./wai
|
||||
./wai-test
|
||||
./wai-extra
|
||||
./warp
|
||||
@ -9,4 +9,5 @@ pkgs=( ./wai
|
||||
./wai-handler-launch
|
||||
./wai-handler-scgi
|
||||
./warp-static
|
||||
./wai-websockets )
|
||||
)
|
||||
# ./wai-websockets
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: wai-app-static
|
||||
version: 0.3.5.1
|
||||
version: 1.0.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -24,7 +24,7 @@ Flag print
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, wai >= 0.4 && < 0.5
|
||||
, wai >= 1.0 && < 1.1
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
, http-types >= 0.6 && < 0.7
|
||||
, transformers >= 0.2.2 && < 0.3
|
||||
@ -59,7 +59,7 @@ test-suite runtests
|
||||
, time >= 1.1.4
|
||||
, old-locale >= 1.0.0.2 && < 1.1
|
||||
, http-date
|
||||
, wai-app-static >= 0.3
|
||||
, wai-app-static >= 1.0
|
||||
, wai-test
|
||||
, wai
|
||||
, http-types
|
||||
|
||||
@ -19,20 +19,19 @@ import Control.Arrow ((***))
|
||||
import Data.Char (toLower)
|
||||
import qualified System.IO
|
||||
import qualified Data.String as String
|
||||
import Data.Enumerator
|
||||
( Enumerator, Step (..), Stream (..), continue, yield
|
||||
, enumList, ($$), joinI, returnI, (>>==), run_
|
||||
)
|
||||
import Data.Monoid (mconcat)
|
||||
import Blaze.ByteString.Builder (fromByteString, toLazyByteString)
|
||||
import Blaze.ByteString.Builder.Char8 (fromChar, fromString)
|
||||
import Blaze.ByteString.Builder.Enumerator (builderToByteString)
|
||||
import Data.Conduit.Blaze (builderToByteString)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.ByteString.Lazy.Internal (defaultChunkSize)
|
||||
import System.IO (Handle)
|
||||
import Network.HTTP.Types (Status (..))
|
||||
import qualified Network.HTTP.Types as H
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Monoid (mappend)
|
||||
import qualified Data.Conduit as C
|
||||
import qualified Data.Conduit.List as CL
|
||||
|
||||
safeRead :: Read a => a -> String -> a
|
||||
safeRead d s =
|
||||
@ -67,7 +66,7 @@ runSendfile sf app = do
|
||||
-- stick with 'run' or 'runSendfile'.
|
||||
runGeneric
|
||||
:: [(String, String)] -- ^ all variables
|
||||
-> (forall a. Int -> Enumerator B.ByteString IO a) -- ^ responseBody of input
|
||||
-> (Int -> C.Source IO B.ByteString) -- ^ responseBody of input
|
||||
-> (B.ByteString -> IO ()) -- ^ destination for output
|
||||
-> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?
|
||||
-> Application
|
||||
@ -95,26 +94,32 @@ runGeneric vars inputH outputH xsendfile app = do
|
||||
case addrs of
|
||||
a:_ -> addrAddress a
|
||||
[] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'
|
||||
let env = Request
|
||||
{ requestMethod = rmethod
|
||||
, rawPathInfo = B.pack pinfo
|
||||
, pathInfo = H.decodePathSegments $ B.pack pinfo
|
||||
, rawQueryString = B.pack qstring
|
||||
, queryString = H.parseQuery $ B.pack qstring
|
||||
, serverName = B.pack servername
|
||||
, serverPort = serverport
|
||||
, requestHeaders = map (cleanupVarName *** B.pack) vars
|
||||
, isSecure = isSecure'
|
||||
, remoteHost = addr
|
||||
, httpVersion = H.http11 -- FIXME
|
||||
}
|
||||
-- FIXME worry about exception?
|
||||
res <- run_ $ inputH contentLength $$ app env
|
||||
case (xsendfile, res) of
|
||||
(Just sf, ResponseFile s hs fp Nothing) ->
|
||||
mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp
|
||||
_ -> responseEnumerator res $ \s hs ->
|
||||
joinI $ enumList 1 [headers s hs, fromChar '\n'] $$ builderIter
|
||||
C.runResourceT $ do
|
||||
input <- C.bufferSource $ inputH contentLength
|
||||
let env = Request
|
||||
{ requestMethod = rmethod
|
||||
, rawPathInfo = B.pack pinfo
|
||||
, pathInfo = H.decodePathSegments $ B.pack pinfo
|
||||
, rawQueryString = B.pack qstring
|
||||
, queryString = H.parseQuery $ B.pack qstring
|
||||
, serverName = B.pack servername
|
||||
, serverPort = serverport
|
||||
, requestHeaders = map (cleanupVarName *** B.pack) vars
|
||||
, isSecure = isSecure'
|
||||
, remoteHost = addr
|
||||
, httpVersion = H.http11 -- FIXME
|
||||
, requestBody = input
|
||||
}
|
||||
-- FIXME worry about exception?
|
||||
res <- app env
|
||||
case (xsendfile, res) of
|
||||
(Just sf, ResponseFile s hs fp Nothing) ->
|
||||
liftIO $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp
|
||||
_ -> do
|
||||
let (s, hs, b) = responseSource res
|
||||
src = CL.sourceList [headers s hs `mappend` fromChar '\n']
|
||||
`mappend` b
|
||||
src C.$$ builderSink
|
||||
where
|
||||
headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))
|
||||
status (Status i m) = (fromByteString "Status", mconcat
|
||||
@ -136,11 +141,11 @@ runGeneric vars inputH outputH xsendfile app = do
|
||||
, fromByteString sf
|
||||
, fromByteString " not supported"
|
||||
]
|
||||
bsStep = Continue bsStep'
|
||||
bsStep' EOF = yield () EOF
|
||||
bsStep' (Chunks []) = continue bsStep'
|
||||
bsStep' (Chunks bss) = liftIO (mapM_ outputH bss) >> continue bsStep'
|
||||
builderIter = builderToByteString bsStep
|
||||
bsSink = C.Sink $ return $ C.SinkData push (return ())
|
||||
push bs = do
|
||||
liftIO $ outputH bs
|
||||
return C.Processing
|
||||
builderSink = builderToByteString C.=$ bsSink
|
||||
fixHeaders h =
|
||||
case lookup "content-type" h of
|
||||
Nothing -> ("Content-Type", "text/html; charset=utf-8") : h
|
||||
@ -159,21 +164,17 @@ cleanupVarName s =
|
||||
helper' (x:rest) = toLower x : helper' rest
|
||||
helper' [] = []
|
||||
|
||||
requestBodyHandle :: Handle -> Int -> Enumerator B.ByteString IO a
|
||||
requestBodyHandle h =
|
||||
requestBodyFunc go
|
||||
where
|
||||
go i = Just `fmap` B.hGet h (min i defaultChunkSize)
|
||||
requestBodyHandle :: Handle -> Int -> C.Source IO B.ByteString
|
||||
requestBodyHandle h = requestBodyFunc $ \i -> do
|
||||
bs <- B.hGet h i
|
||||
return $ if B.null bs then Nothing else Just bs
|
||||
|
||||
requestBodyFunc :: (Int -> IO (Maybe B.ByteString))
|
||||
-> Int
|
||||
-> Enumerator B.ByteString IO a
|
||||
requestBodyFunc _ 0 step = returnI step
|
||||
requestBodyFunc h len (Continue k) = do
|
||||
mbs <- liftIO $ h len
|
||||
case mbs of
|
||||
Nothing -> continue k
|
||||
Just bs -> do
|
||||
let newLen = len - B.length bs
|
||||
k (Chunks [bs]) >>== requestBodyFunc h newLen
|
||||
requestBodyFunc _ _ step = returnI step
|
||||
requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> C.Source IO B.ByteString
|
||||
requestBodyFunc get count0 =
|
||||
C.sourceState count0 pull
|
||||
where
|
||||
pull 0 = return (0, C.Closed)
|
||||
pull count = do
|
||||
mbs <- liftIO $ get $ min count defaultChunkSize
|
||||
let count' = count - maybe 0 B.length mbs
|
||||
return (count', maybe C.Closed C.Open mbs)
|
||||
|
||||
@ -5,7 +5,6 @@ module Network.Wai.Middleware.Autohead (autohead) where
|
||||
|
||||
import Network.Wai
|
||||
import Data.Monoid (mempty)
|
||||
import Data.Enumerator (enumEOF, ($$))
|
||||
|
||||
autohead :: Middleware
|
||||
autohead app req
|
||||
@ -14,10 +13,6 @@ autohead app req
|
||||
case res of
|
||||
ResponseFile s hs _ _ -> return $ ResponseBuilder s hs mempty
|
||||
ResponseBuilder s hs _ -> return $ ResponseBuilder s hs mempty
|
||||
ResponseEnumerator e -> do
|
||||
let helper f =
|
||||
let helper' s hs = enumEOF $$ f s hs
|
||||
in e helper'
|
||||
return $ ResponseEnumerator helper
|
||||
ResponseSource s hs _ -> return $ ResponseBuilder s hs mempty
|
||||
| otherwise = app req
|
||||
|
||||
|
||||
@ -25,18 +25,20 @@ module Network.Wai.Middleware.Gzip
|
||||
) where
|
||||
|
||||
import Network.Wai
|
||||
import Network.Wai.Zlib
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Enumerator (($$), joinI, (=$), run)
|
||||
import Data.Enumerator.Binary (enumFile, iterHandle)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString as S
|
||||
import Data.Default
|
||||
import Network.HTTP.Types (Status, Header)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import qualified Codec.Zlib.Enum as CZE
|
||||
import qualified System.IO as SIO
|
||||
import System.Directory (doesFileExist, createDirectoryIfMissing)
|
||||
import qualified Data.Conduit as C
|
||||
import qualified Data.Conduit.Zlib as CZ
|
||||
import qualified Data.Conduit.Binary as CB
|
||||
import qualified Data.Conduit.List as CL
|
||||
import Data.Conduit.Blaze (builderToByteString)
|
||||
import Blaze.ByteString.Builder (fromByteString)
|
||||
import Control.Exception (try, SomeException)
|
||||
|
||||
data GzipSettings = GzipSettings
|
||||
{ gzipFiles :: GzipFiles
|
||||
@ -79,7 +81,7 @@ gzip' set app env = do
|
||||
Just m
|
||||
| gzipCheckMime set m -> liftIO $ compressFile s hs file cache
|
||||
_ -> return res
|
||||
_ -> return $ ResponseEnumerator $ compressE set $ responseEnumerator res
|
||||
_ -> return $ compressE set res
|
||||
else return res
|
||||
where
|
||||
enc = fromMaybe [] $ (splitCommas . S8.unpack)
|
||||
@ -94,15 +96,16 @@ compressFile s hs file cache = do
|
||||
then onSucc
|
||||
else do
|
||||
createDirectoryIfMissing True cache
|
||||
x <- SIO.withFile tmpfile SIO.WriteMode $ \h ->
|
||||
run
|
||||
$ enumFile file
|
||||
$$ CZE.gzip
|
||||
=$ iterHandle h
|
||||
either (const onErr) (const onSucc) x
|
||||
x <-
|
||||
try $ C.runResourceT $ CB.sourceFile file
|
||||
C.$$ CZ.gzip C.=$ CB.sinkFile tmpfile
|
||||
either onErr (const onSucc) x
|
||||
where
|
||||
onSucc = return $ ResponseFile s (fixHeaders hs) tmpfile Nothing
|
||||
onErr = return $ ResponseFile s hs file Nothing
|
||||
|
||||
onErr :: SomeException -> IO Response
|
||||
onErr = const $ return $ ResponseFile s hs file Nothing -- FIXME log the error message
|
||||
|
||||
tmpfile = cache ++ '/' : map safe file
|
||||
safe c
|
||||
| 'A' <= c && c <= 'Z' = c
|
||||
@ -113,16 +116,18 @@ compressFile s hs file cache = do
|
||||
safe _ = '_'
|
||||
|
||||
compressE :: GzipSettings
|
||||
-> (forall a. ResponseEnumerator a)
|
||||
-> (forall a. ResponseEnumerator a)
|
||||
compressE set re f =
|
||||
re f'
|
||||
--e s hs'
|
||||
-> Response
|
||||
-> Response
|
||||
compressE set res =
|
||||
case lookup "content-type" hs of
|
||||
Just m | gzipCheckMime set m ->
|
||||
let hs' = fixHeaders hs
|
||||
in ResponseSource s hs' $ b C.$= builderToByteString
|
||||
C.$= CZ.gzip
|
||||
C.$= CL.map fromByteString
|
||||
_ -> res
|
||||
where
|
||||
f' s hs =
|
||||
case lookup "content-type" hs of
|
||||
Just m | gzipCheckMime set m -> joinI $ compress $$ f s (fixHeaders hs)
|
||||
_ -> f s hs
|
||||
(s, hs, b) = responseSource res
|
||||
|
||||
-- Remove Content-Length header, since we will certainly have a
|
||||
-- different length after gzip compression.
|
||||
|
||||
@ -18,13 +18,13 @@ module Network.Wai.Middleware.Jsonp (jsonp) where
|
||||
import Network.Wai
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
import Data.Enumerator (($$), enumList, Step (..), Enumerator, Iteratee, Enumeratee, joinI, checkDone, continue, Stream (..), (>>==))
|
||||
import Blaze.ByteString.Builder (copyByteString, Builder)
|
||||
import Blaze.ByteString.Builder (copyByteString)
|
||||
import Blaze.ByteString.Builder.Char8 (fromChar)
|
||||
import Data.Monoid (mappend)
|
||||
import Control.Monad (join)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.Conduit.List as CL
|
||||
|
||||
-- | Wrap json responses in a jsonp callback.
|
||||
--
|
||||
@ -54,7 +54,6 @@ jsonp app env = do
|
||||
Nothing -> return res
|
||||
Just c -> go c res
|
||||
where
|
||||
go c r@(ResponseFile _ hs _ _) = go' c r hs
|
||||
go c r@(ResponseBuilder s hs b) =
|
||||
case checkJSON hs of
|
||||
Nothing -> return r
|
||||
@ -63,39 +62,26 @@ jsonp app env = do
|
||||
`mappend` fromChar '('
|
||||
`mappend` b
|
||||
`mappend` fromChar ')'
|
||||
go c (ResponseEnumerator e) = addCallback c e
|
||||
go' c r hs =
|
||||
go c r =
|
||||
case checkJSON hs of
|
||||
Just _ -> addCallback c $ responseEnumerator r
|
||||
Just hs' -> addCallback c s hs' b
|
||||
Nothing -> return r
|
||||
where
|
||||
(s, hs, b) = responseSource r
|
||||
|
||||
checkJSON hs =
|
||||
case lookup "Content-Type" hs of
|
||||
Just x
|
||||
| B8.pack "application/json" `S.isPrefixOf` x -> Just $ fixHeaders hs
|
||||
| B8.pack "application/json" `S.isPrefixOf` x ->
|
||||
Just $ fixHeaders hs
|
||||
_ -> Nothing
|
||||
fixHeaders = changeVal "Content-Type" "text/javascript"
|
||||
addCallback :: B8.ByteString -> (forall a. ResponseEnumerator a)
|
||||
-> Iteratee B8.ByteString IO Response
|
||||
addCallback cb e =
|
||||
return $ ResponseEnumerator $ helper
|
||||
where
|
||||
helper f =
|
||||
e helper'
|
||||
where
|
||||
helper' s hs =
|
||||
case checkJSON hs of
|
||||
Just hs' -> wrap $$ f s hs'
|
||||
Nothing -> f s hs
|
||||
wrap :: Step Builder IO b -> Iteratee Builder IO b
|
||||
wrap step = joinI $ after (enumList 1 [fromChar ')'])
|
||||
$$ enumList 1 [copyByteString cb, fromChar '('] step
|
||||
after :: Enumerator Builder IO b -> Enumeratee Builder Builder IO b
|
||||
after enum =
|
||||
loop
|
||||
where
|
||||
loop = checkDone $ continue . step
|
||||
step k EOF = enum (Continue k) >>== return
|
||||
step k s = k s >>== loop
|
||||
|
||||
addCallback cb s hs b =
|
||||
return $ ResponseSource s hs $
|
||||
CL.sourceList [copyByteString cb `mappend` fromChar '(']
|
||||
`mappend` b
|
||||
`mappend` CL.sourceList [fromChar ')']
|
||||
|
||||
changeVal :: Eq a
|
||||
=> a
|
||||
|
||||
@ -21,9 +21,11 @@ import qualified Data.Text.Encoding as TE
|
||||
import Network.Wai.Parse (parseRequestBody, lbsSink, fileName, Param, File)
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Enumerator (run_, ($$), enumList)
|
||||
import Data.Enumerator.List (consume)
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
|
||||
import qualified Data.Conduit as C
|
||||
import qualified Data.Conduit.List as CL
|
||||
|
||||
-- | like @logHandle@, but prints to 'stdout'
|
||||
logStdout :: Middleware
|
||||
logStdout = logHandle $ \bs -> hPutLogStr stdout [LB bs]
|
||||
@ -68,7 +70,7 @@ logHandleDevLT cb app req =
|
||||
-- For production use use module Network.Wai.Middleware.RequestLogger
|
||||
logHandleDev :: (BS.ByteString -> IO ()) -> Middleware
|
||||
logHandleDev cb app req = do
|
||||
body <- consume
|
||||
body <- requestBody req C.$$ CL.consume
|
||||
postParams <- if any (requestMethod req ==) ["GET", "HEAD"]
|
||||
then return []
|
||||
else do postParams <- liftIO $ allPostParams req body
|
||||
@ -86,7 +88,8 @@ logHandleDev cb app req = do
|
||||
, paramsToBS "POST " postParams
|
||||
]
|
||||
-- we just consumed the body- fill the enumerator back up so it is available again
|
||||
liftIO $ run_ $ enumList 1 body $$ app req
|
||||
body' <- C.bufferSource $ CL.sourceList body
|
||||
app req { requestBody = body' }
|
||||
where
|
||||
paramsToBS prefix params =
|
||||
if null params then ""
|
||||
|
||||
@ -1,41 +0,0 @@
|
||||
module Network.Wai.Zlib (compress) where
|
||||
|
||||
import Prelude hiding (head)
|
||||
import Data.Enumerator
|
||||
( Enumeratee, checkDone, Stream (..)
|
||||
, (>>==), ($$), joinI
|
||||
)
|
||||
import Data.Enumerator.List (head)
|
||||
import Blaze.ByteString.Builder (Builder, fromByteString)
|
||||
import Blaze.ByteString.Builder.Enumerator (builderToByteString)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
import Codec.Zlib
|
||||
|
||||
-- Note: this function really should return a stream of ByteStrings, but the
|
||||
-- WAI protocol needs Builders anyway.
|
||||
compress :: Enumeratee Builder Builder IO a
|
||||
compress step0 = joinI $ builderToByteString $$ do
|
||||
def <- liftIO $ initDeflate 7 $ WindowBits 31
|
||||
loop def step0
|
||||
where
|
||||
loop def = checkDone $ step def
|
||||
step def k = do
|
||||
minput <- head
|
||||
case minput of
|
||||
Nothing -> do
|
||||
bss <- liftIO $ finishDeflate def drain
|
||||
k (Chunks bss) >>== return
|
||||
Just input -> do
|
||||
bss <- liftIO $ withDeflateInput def input drain
|
||||
case bss of
|
||||
[] -> step def k
|
||||
_ -> k (Chunks bss) >>== loop def
|
||||
drain =
|
||||
go id
|
||||
where
|
||||
go front mbs' = do
|
||||
mbs <- mbs'
|
||||
case mbs of
|
||||
Nothing -> return $ map fromByteString $ front []
|
||||
Just bs -> go (front . (:) bs) mbs'
|
||||
@ -1,5 +1,5 @@
|
||||
Name: wai-extra
|
||||
Version: 0.4.6
|
||||
Version: 1.0.0
|
||||
Synopsis: Provides some basic WAI handlers and middleware.
|
||||
Description: The goal here is to provide common features without many dependencies.
|
||||
License: BSD3
|
||||
@ -22,22 +22,24 @@ extra-source-files:
|
||||
Library
|
||||
Build-Depends: base >= 4 && < 5
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
, wai >= 0.4 && < 0.5
|
||||
, wai >= 1.0 && < 1.1
|
||||
, old-locale >= 1.0.0.2 && < 1.1
|
||||
, time >= 1.1.4
|
||||
, network >= 2.2.1.5 && < 2.4
|
||||
, directory >= 1.0.1 && < 1.2
|
||||
, zlib-bindings >= 0.0 && < 0.1
|
||||
, blaze-builder-enumerator >= 0.2 && < 0.3
|
||||
, transformers >= 0.2.2 && < 0.3
|
||||
, enumerator >= 0.4.8 && < 0.5
|
||||
, blaze-builder >= 0.2.1.4 && < 0.4
|
||||
, http-types >= 0.6 && < 0.7
|
||||
, text >= 0.7 && < 0.12
|
||||
, case-insensitive >= 0.2
|
||||
, zlib-enum >= 0.2.1 && < 0.3
|
||||
, data-default >= 0.3 && < 0.4
|
||||
, fast-logger >= 0.0.1
|
||||
, conduit
|
||||
, zlib-conduit
|
||||
, blaze-builder-conduit
|
||||
-- FIXME this must be removed
|
||||
, enumerator
|
||||
|
||||
Exposed-modules: Network.Wai.Handler.CGI
|
||||
Network.Wai.Middleware.AcceptOverride
|
||||
@ -50,7 +52,6 @@ Library
|
||||
Network.Wai.Middleware.MethodOverride
|
||||
Network.Wai.Middleware.Rewrite
|
||||
Network.Wai.Middleware.Vhost
|
||||
Network.Wai.Zlib
|
||||
Network.Wai.Parse
|
||||
ghc-options: -Wall
|
||||
|
||||
@ -69,16 +70,16 @@ test-suite tests
|
||||
, wai
|
||||
, http-types
|
||||
, transformers
|
||||
, enumerator
|
||||
, zlib
|
||||
, text
|
||||
, bytestring
|
||||
, directory
|
||||
, zlib-bindings
|
||||
, blaze-builder-enumerator >= 0.2 && < 0.3
|
||||
, blaze-builder >= 0.2.1.4 && < 0.4
|
||||
, zlib-enum
|
||||
, data-default
|
||||
, conduit
|
||||
-- FIXME this must be removed
|
||||
, enumerator
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
Name: wai-handler-devel
|
||||
Version: 0.4.4.1
|
||||
Version: 1.0.0
|
||||
Synopsis: WAI server that automatically reloads code after modification.
|
||||
Description: This handler automatically reloads your source code upon any changes. It works by using the hint package, essentially embedding GHC inside the handler. The handler (both the executable and library) takes three arguments: the port to listen on, the module name containing the application function, and the name of the function.
|
||||
.
|
||||
@ -10,7 +10,7 @@ License: BSD3
|
||||
License-file: LICENSE
|
||||
Author: Michael Snoyman
|
||||
Maintainer: michael@snoyman.com
|
||||
Homepage: http://github.com/snoyberg/wai-handler-devel
|
||||
Homepage: http://github.com/yesodweb/wai
|
||||
Category: Web
|
||||
Build-Type: Simple
|
||||
Cabal-Version: >=1.6
|
||||
@ -18,14 +18,14 @@ Stability: Stable
|
||||
|
||||
Source-repository head
|
||||
type: git
|
||||
location: git://github.com/snoyberg/wai-handler-devel.git
|
||||
location: git://github.com/yesodweb/wai.git
|
||||
|
||||
Library
|
||||
Build-Depends: base >= 4 && < 5
|
||||
, wai >= 0.4 && < 0.5
|
||||
, wai-extra >= 0.4 && < 0.5
|
||||
, wai >= 1.0 && < 1.1
|
||||
, wai-extra >= 1.0 && < 1.1
|
||||
, http-types >= 0.6 && < 0.7
|
||||
, warp >= 0.4 && < 0.5
|
||||
, warp >= 1.0 && < 1.1
|
||||
, directory >= 1.0.1 && < 1.2
|
||||
, network >= 2.2.1.5 && < 2.4
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: wai-handler-fastcgi
|
||||
version: 0.4.2
|
||||
version: 1.0.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -15,8 +15,8 @@ description: Calls out to the libfcgi C library.
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, wai >= 0.4 && < 0.5
|
||||
, wai-extra >= 0.4 && < 0.5
|
||||
, wai >= 1.0 && < 1.1
|
||||
, wai-extra >= 1.0 && < 1.1
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
exposed-modules: Network.Wai.Handler.FastCGI
|
||||
ghc-options: -Wall
|
||||
|
||||
@ -13,7 +13,6 @@ import Data.IORef
|
||||
import Control.Concurrent
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import qualified Data.ByteString as S
|
||||
import Data.Enumerator (($$), joinI, Enumeratee, Stream (..), Iteratee (..), Step (..))
|
||||
import Blaze.ByteString.Builder (fromByteString)
|
||||
#if WINDOWS
|
||||
import Foreign
|
||||
@ -21,10 +20,10 @@ import Foreign.C.String
|
||||
#else
|
||||
import System.Cmd (rawSystem)
|
||||
#endif
|
||||
import Codec.Zlib.Enum (ungzip)
|
||||
import Blaze.ByteString.Builder.Enumerator (builderToByteString)
|
||||
import qualified Data.Enumerator.List as EL
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Conduit.Zlib (ungzip)
|
||||
import Data.Conduit.Blaze (builderToByteString)
|
||||
import qualified Data.Conduit as C
|
||||
import qualified Data.Conduit.List as CL
|
||||
|
||||
ping :: IORef Bool -> Middleware
|
||||
ping var app req
|
||||
@ -42,64 +41,45 @@ ping var app req
|
||||
| not $ isHtml hs -> return res
|
||||
ResponseBuilder _ hs _
|
||||
| not $ isHtml hs -> return res
|
||||
ResponseSource _ hs _
|
||||
| not $ isHtml hs -> return res
|
||||
_ -> do
|
||||
let renum = responseEnumerator res
|
||||
return $ ResponseEnumerator $ \f -> renum $ \status headers ->
|
||||
if isHtml headers
|
||||
then do
|
||||
let (isEnc, headers') = fixHeaders id headers
|
||||
let headers'' = filter (\(x, _) -> x /= "content-length") headers'
|
||||
let fixEnc x =
|
||||
if isEnc
|
||||
then joinI $ ungzip $$ x
|
||||
else x
|
||||
joinI $ builderToByteString $$ fixEnc $ joinI $ insideHead "<script>setInterval(function(){var x;if(window.XMLHttpRequest){x=new XMLHttpRequest();}else{x=new ActiveXObject(\"Microsoft.XMLHTTP\");}x.open(\"GET\",\"/_ping\",false);x.send();},60000)</script>" $$ joinI $ EL.map fromByteString $$ f status headers''
|
||||
else f status headers
|
||||
let (s, hs, body) = responseSource res
|
||||
let (isEnc, headers') = fixHeaders id hs
|
||||
let headers'' = filter (\(x, _) -> x /= "content-length") headers'
|
||||
let fixEnc src = if isEnc then src C.$= ungzip else src
|
||||
return $ ResponseSource s headers''
|
||||
$ fixEnc (body C.$= builderToByteString)
|
||||
C.$= insideHead
|
||||
C.$= CL.map fromByteString
|
||||
|
||||
insideHead :: S.ByteString -> Enumeratee S.ByteString S.ByteString IO a
|
||||
insideHead toInsert =
|
||||
go "" whole
|
||||
toInsert :: S.ByteString
|
||||
toInsert = "<script>setInterval(function(){var x;if(window.XMLHttpRequest){x=new XMLHttpRequest();}else{x=new ActiveXObject(\"Microsoft.XMLHTTP\");}x.open(\"GET\",\"/_ping\",false);x.send();},60000)</script>"
|
||||
|
||||
insideHead :: C.Conduit S.ByteString IO S.ByteString
|
||||
insideHead =
|
||||
C.conduitState (Just (S.empty, whole)) push close
|
||||
where
|
||||
whole = "<head>"
|
||||
go :: S.ByteString -> S.ByteString -> Step S.ByteString IO a -> Iteratee S.ByteString IO (Step S.ByteString IO a)
|
||||
go held atFront step = do
|
||||
mx <- EL.head
|
||||
case mx of
|
||||
Nothing -> feedDone $ Chunks [held, toInsert]
|
||||
Just x
|
||||
| atFront `S.isPrefixOf` x -> do
|
||||
let y = S.drop (S.length atFront) x
|
||||
let stream = Chunks [held, atFront, toInsert, y]
|
||||
feedDone stream
|
||||
| whole `S.isInfixOf` x -> do
|
||||
let (before, rest) = S.breakSubstring whole x
|
||||
let after = S.drop (S.length whole) rest
|
||||
feedDone $ Chunks [held, before, whole, toInsert, after]
|
||||
| x `S.isPrefixOf` atFront -> go
|
||||
(held `S.append` x)
|
||||
(S.drop (S.length x) atFront)
|
||||
step
|
||||
| otherwise -> do
|
||||
let (held', atFront', x') = getOverlap whole x
|
||||
feedCont held' atFront' $ Chunks [held, x']
|
||||
where
|
||||
--feedDone :: Stream S.ByteString -> Iteratee S.ByteString IO (Step S.ByteString IO a)
|
||||
feedDone stream =
|
||||
case step of
|
||||
Continue k -> do
|
||||
step' <- lift $ runIteratee $ k stream
|
||||
EL.map id step'
|
||||
Yield b s -> return $ Yield b s
|
||||
Error e -> return $ Error e
|
||||
push (Just (held, atFront)) x
|
||||
| atFront `S.isPrefixOf` x = do
|
||||
let y = S.drop (S.length atFront) x
|
||||
return (Nothing, C.Producing [held, atFront, toInsert, y])
|
||||
| whole `S.isInfixOf` x = do
|
||||
let (before, rest) = S.breakSubstring whole x
|
||||
let after = S.drop (S.length whole) rest
|
||||
return (Nothing, C.Producing [held, before, whole, toInsert, after])
|
||||
| x `S.isPrefixOf` atFront = do
|
||||
let held' = held `S.append` x
|
||||
atFront' = S.drop (S.length x) atFront
|
||||
return (Just (held', atFront'), C.Producing [])
|
||||
| otherwise = do
|
||||
let (held', atFront', x') = getOverlap whole x
|
||||
return (Just (held', atFront'), C.Producing [held, x'])
|
||||
push Nothing x = return (Nothing, C.Producing [x])
|
||||
|
||||
--feedCont :: Monad m => S.ByteString -> S.ByteString -> Stream S.ByteString -> Iteratee S.ByteString m (Step S.ByteString m a)
|
||||
feedCont held' atFront' stream = do
|
||||
case step of
|
||||
Continue k -> do
|
||||
step' <- lift $ runIteratee $ k stream
|
||||
go held' atFront' step'
|
||||
Yield b s -> return $ Yield b s
|
||||
Error e -> return $ Error e
|
||||
close (Just (held, _)) = return [held, toInsert]
|
||||
close Nothing = return []
|
||||
|
||||
getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)
|
||||
getOverlap whole x =
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
Name: wai-handler-launch
|
||||
Version: 0.0.4
|
||||
Version: 1.0.0
|
||||
Synopsis: Launch a web app in the default browser.
|
||||
Description: This handles cross-platform launching and inserts Javascript code to ping the server. When the server no longer receives pings, it shuts down.
|
||||
License: BSD3
|
||||
@ -13,15 +13,17 @@ Cabal-version: >=1.2
|
||||
Library
|
||||
Exposed-modules: Network.Wai.Handler.Launch
|
||||
build-depends: base >= 4 && < 5
|
||||
, wai >= 0.4 && < 0.5
|
||||
, warp >= 0.4 && < 0.5
|
||||
, wai >= 1.0 && < 1.1
|
||||
, warp >= 1.0 && < 1.1
|
||||
, http-types >= 0.6 && < 0.7
|
||||
, transformers >= 0.2.2 && < 0.3
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
, blaze-builder >= 0.2.1.4 && < 0.4
|
||||
, enumerator >= 0.4.8 && < 0.5
|
||||
, blaze-builder-enumerator >= 0.2 && < 0.3
|
||||
, zlib-enum >= 0.2.1 && < 0.3
|
||||
, conduit
|
||||
, blaze-builder-conduit
|
||||
, zlib-conduit
|
||||
|
||||
if os(windows)
|
||||
c-sources: windows.c
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: wai-handler-scgi
|
||||
version: 0.4.1
|
||||
version: 1.0.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -14,8 +14,8 @@ description: Wai handler to SCGI
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, wai >= 0.4 && < 0.5
|
||||
, wai-extra >= 0.4 && < 0.5
|
||||
, wai >= 1.0 && < 1.1
|
||||
, wai-extra >= 1.0 && < 1.1
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
exposed-modules: Network.Wai.Handler.SCGI
|
||||
ghc-options: -Wall
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: wai-handler-webkit
|
||||
version: 0.3.0
|
||||
version: 1.0.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -16,8 +16,8 @@ homepage: http://www.yesodweb.com/book/wai
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, wai >= 0.4 && < 0.5
|
||||
, warp >= 0.4 && < 0.5
|
||||
, wai >= 1.0 && < 1.1
|
||||
, warp >= 1.0 && < 1.1
|
||||
ghc-options: -Wall
|
||||
exposed-modules: Network.Wai.Handler.Webkit
|
||||
c-sources: webkit.cpp
|
||||
|
||||
@ -26,14 +26,14 @@ import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Data.Enumerator (joinI, ($$), run_, enumList)
|
||||
import Data.Enumerator.List (consume)
|
||||
import Blaze.ByteString.Builder.Enumerator (builderToByteString)
|
||||
import Data.Conduit.Blaze (builderToByteString)
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
import qualified Network.HTTP.Types as H
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.Conduit as C
|
||||
import qualified Data.Conduit.List as CL
|
||||
|
||||
type Session = ReaderT Application (StateT ClientState IO)
|
||||
|
||||
@ -73,23 +73,26 @@ defaultRequest = Request
|
||||
, remoteHost = error "Network.Wai.Test.defaultRequest{remoteHost}"
|
||||
, pathInfo = []
|
||||
, queryString = []
|
||||
, requestBody = error "requestBody of defaultRequest"
|
||||
}
|
||||
|
||||
srequest :: SRequest -> Session SResponse
|
||||
srequest (SRequest req bod) = do
|
||||
app <- ask
|
||||
res <- liftIO $ run_ $ enumList 4 (L.toChunks bod) $$ app req
|
||||
sres <- liftIO $ runResponse res
|
||||
-- FIXME cookie processing
|
||||
return sres
|
||||
liftIO $ C.runResourceT $ do
|
||||
body <- C.bufferSource $ CL.sourceList $ L.toChunks bod
|
||||
let req' = req { requestBody = body }
|
||||
res <- app req'
|
||||
sres <- runResponse res
|
||||
-- FIXME cookie processing
|
||||
return sres
|
||||
|
||||
runResponse :: Response -> IO SResponse
|
||||
runResponse res =
|
||||
responseEnumerator res go
|
||||
runResponse :: Response -> C.ResourceT IO SResponse
|
||||
runResponse res = do
|
||||
bss <- body C.$= builderToByteString C.$$ CL.consume
|
||||
return $ SResponse s h $ L.fromChunks bss
|
||||
where
|
||||
go s h = do
|
||||
bss <- joinI $ builderToByteString $$ consume
|
||||
return $ SResponse s h $ L.fromChunks bss
|
||||
(s, h, body) = responseSource res
|
||||
|
||||
assertBool :: String -> Bool -> Session ()
|
||||
assertBool s b = liftIO $ H.assertBool s b
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: wai-test
|
||||
version: 0.1.3.1
|
||||
version: 1.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -14,14 +14,14 @@ description: Unit test framework (built on HUnit) for WAI applications.
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, wai >= 0.4 && < 0.5
|
||||
, wai >= 1.0 && < 1.1
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
, blaze-builder >= 0.2.1.4 && < 0.4
|
||||
, transformers >= 0.2.2 && < 0.3
|
||||
, containers >= 0.2 && < 0.5
|
||||
, enumerator >= 0.4.8 && < 0.5
|
||||
, conduit >= 0.0 && < 0.1
|
||||
, blaze-builder-conduit >= 0.0 && < 0.1
|
||||
, cookie >= 0.2 && < 0.4
|
||||
, blaze-builder-enumerator >= 0.2 && < 0.3
|
||||
, HUnit >= 1.2 && < 1.3
|
||||
, http-types >= 0.6 && < 0.7
|
||||
, case-insensitive >= 0.2
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
Name: wai-websockets
|
||||
Version: 0.5.0.1
|
||||
Version: 1.0.0
|
||||
Synopsis: Provide a bridge betweeen WAI and the websockets package.
|
||||
License: BSD3
|
||||
License-file: LICENSE
|
||||
@ -19,7 +19,7 @@ flag example
|
||||
Library
|
||||
Build-Depends: base >= 3 && < 5
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
, wai >= 0.4 && < 0.5
|
||||
, wai >= 1.0 && < 1.1
|
||||
, enumerator >= 0.4.8 && < 0.5
|
||||
, network-enumerator >= 0.1.2 && < 0.2
|
||||
, blaze-builder >= 0.2.1.4 && < 0.4
|
||||
|
||||
@ -39,8 +39,7 @@ module Network.Wai
|
||||
( -- * WAI interface
|
||||
Request (..)
|
||||
, Response (..)
|
||||
, ResponseStream
|
||||
, responseStream
|
||||
, responseSource
|
||||
, Application
|
||||
, Middleware
|
||||
, FilePart (..)
|
||||
@ -61,7 +60,6 @@ import qualified Network.HTTP.Types as H
|
||||
import Data.Text (Text)
|
||||
import Data.ByteString.Lazy.Char8 () -- makes it easier to use responseLBS
|
||||
import Blaze.ByteString.Builder (fromByteString)
|
||||
import Filesystem.Path.CurrentOS (decodeString)
|
||||
|
||||
-- | Information on the request sent by the client. This abstracts away the
|
||||
-- details of the underlying implementation.
|
||||
@ -96,21 +94,10 @@ data Request = Request
|
||||
, pathInfo :: [Text]
|
||||
-- | Parsed query string information
|
||||
, queryString :: H.Query
|
||||
, requestBody :: C.BSource IO B.ByteString
|
||||
, requestBody :: C.BufferedSource IO B.ByteString
|
||||
}
|
||||
deriving (Typeable)
|
||||
|
||||
data Response
|
||||
= ResponseFile H.Status H.ResponseHeaders FilePath (Maybe FilePart)
|
||||
| ResponseBuilder H.Status H.ResponseHeaders Builder
|
||||
| ResponseStream (forall a. ResponseStream a)
|
||||
deriving Typeable
|
||||
|
||||
data FilePart = FilePart
|
||||
{ filePartOffset :: Integer
|
||||
, filePartByteCount :: Integer
|
||||
} deriving Show
|
||||
|
||||
-- |
|
||||
--
|
||||
-- Some questions and answers about the usage of 'Builder' here:
|
||||
@ -134,23 +121,29 @@ data FilePart = FilePart
|
||||
--
|
||||
-- A3. You can force blaze-builder to output a ByteString before it is an
|
||||
-- optimal size by sending a flush command.
|
||||
data Response
|
||||
= ResponseFile H.Status H.ResponseHeaders FilePath (Maybe FilePart)
|
||||
| ResponseBuilder H.Status H.ResponseHeaders Builder
|
||||
| ResponseSource H.Status H.ResponseHeaders (C.Source IO Builder)
|
||||
deriving Typeable
|
||||
|
||||
type ResponseStream a =
|
||||
(H.Status -> H.ResponseHeaders -> C.SinkM Builder IO a)
|
||||
-> ResourceT IO a
|
||||
data FilePart = FilePart
|
||||
{ filePartOffset :: Integer
|
||||
, filePartByteCount :: Integer
|
||||
} deriving Show
|
||||
|
||||
responseStream :: Response -> ResponseStream a
|
||||
responseStream (ResponseStream e) f = e f
|
||||
responseStream (ResponseFile s h fp (Just part)) f =
|
||||
sourceFilePart part fp C.$$ CL.map fromByteString C.=$ f s h
|
||||
responseStream (ResponseFile s h fp Nothing) f =
|
||||
CB.sourceFile (decodeString fp) C.$$ CL.map fromByteString C.=$ f s h
|
||||
responseStream (ResponseBuilder s h b) f =
|
||||
CL.fromList [b] C.$$ f s h
|
||||
responseSource :: Response -> (H.Status, H.ResponseHeaders, C.Source IO Builder) -- FIXME re-analyze usage of Builder
|
||||
responseSource (ResponseSource s h b) = (s, h, b)
|
||||
responseSource (ResponseFile s h fp (Just part)) =
|
||||
(s, h, sourceFilePart part fp C.$= CL.map fromByteString)
|
||||
responseSource (ResponseFile s h fp Nothing) =
|
||||
(s, h, CB.sourceFile fp C.$= CL.map fromByteString)
|
||||
responseSource (ResponseBuilder s h b) =
|
||||
(s, h, CL.sourceList [b])
|
||||
|
||||
sourceFilePart :: FilePart -> FilePath -> C.SourceM IO B.ByteString
|
||||
sourceFilePart :: FilePart -> FilePath -> C.Source IO B.ByteString
|
||||
sourceFilePart (FilePart offset count) fp =
|
||||
CB.sourceFileRange (decodeString fp) (Just offset) (Just count)
|
||||
CB.sourceFileRange fp (Just offset) (Just count)
|
||||
|
||||
responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response
|
||||
responseLBS s h = ResponseBuilder s h . fromLazyByteString
|
||||
|
||||
@ -25,6 +25,5 @@ Library
|
||||
, http-types >= 0.6 && < 0.7
|
||||
, text >= 0.7 && < 0.12
|
||||
, transformers >= 0.2.2 && < 0.3
|
||||
, system-filepath >= 0.4.3 && < 0.5
|
||||
Exposed-modules: Network.Wai
|
||||
ghc-options: -Wall
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
Name: warp-static
|
||||
Version: 0.2.2
|
||||
Version: 1.0.0
|
||||
Synopsis: Static file server based on Warp and wai-app-static
|
||||
Homepage: http://github.com/yesodweb/wai
|
||||
License: BSD3
|
||||
@ -15,9 +15,9 @@ Description: Serve up static files by running the warp executable. Based
|
||||
Executable warp
|
||||
Main-is: warp.hs
|
||||
Build-depends: base >= 4 && < 5
|
||||
, warp >= 0.4 && < 0.5
|
||||
, wai-app-static >= 0.3 && < 0.4
|
||||
, wai-extra >= 0.4 && < 0.5
|
||||
, warp >= 1.0 && < 1.1
|
||||
, wai-app-static >= 1.0 && < 1.1
|
||||
, wai-extra >= 1.0 && < 1.1
|
||||
, cmdargs >= 0.6.7
|
||||
, directory >= 1.0
|
||||
, containers >= 0.2 && < 0.5
|
||||
|
||||
@ -96,7 +96,7 @@ import Blaze.ByteString.Builder.HTTP
|
||||
import Blaze.ByteString.Builder
|
||||
(copyByteString, Builder, toLazyByteString, toByteStringIO)
|
||||
import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)
|
||||
import Data.Monoid (mappend, mconcat)
|
||||
import Data.Monoid (mappend)
|
||||
import Network.Sendfile
|
||||
|
||||
import qualified System.PosixCompat.Files as P
|
||||
@ -211,12 +211,13 @@ serveConnection settings th onException port app conn remoteHost' = do
|
||||
serveConnection' :: ResourceT IO ()
|
||||
serveConnection' = do
|
||||
fromClient <- C.bufferSource $ sourceSocket th bytesPerRead conn
|
||||
(len, env) <- parseRequest port remoteHost' fromClient
|
||||
env <- parseRequest port remoteHost' fromClient
|
||||
case settingsIntercept settings env of
|
||||
Nothing -> do
|
||||
-- Let the application run for as long as it wants
|
||||
liftIO $ T.pause th
|
||||
res <- app env
|
||||
-- FIXME flush the rest of the request body
|
||||
liftIO $ T.resume th
|
||||
keepAlive <- sendResponse th env conn res
|
||||
if keepAlive then serveConnection' else return ()
|
||||
@ -225,8 +226,8 @@ serveConnection settings th onException port app conn remoteHost' = do
|
||||
intercept fromClient conn
|
||||
|
||||
parseRequest :: Port -> SockAddr
|
||||
-> C.BSource IO S.ByteString
|
||||
-> ResourceT IO (Integer, Request)
|
||||
-> C.BufferedSource IO S.ByteString
|
||||
-> ResourceT IO Request
|
||||
parseRequest port remoteHost' src = do
|
||||
headers' <- takeHeaders src
|
||||
parseRequest' port headers' remoteHost' src
|
||||
@ -250,8 +251,8 @@ instance Exception InvalidRequest
|
||||
parseRequest' :: Port
|
||||
-> [ByteString]
|
||||
-> SockAddr
|
||||
-> C.BSource IO S.ByteString
|
||||
-> ResourceT IO (Integer, Request)
|
||||
-> C.BufferedSource IO S.ByteString
|
||||
-> ResourceT IO Request
|
||||
parseRequest' _ [] _ _ = throwIO $ NotEnoughLines []
|
||||
parseRequest' port (firstLine:otherLines) remoteHost' src = do
|
||||
(method, rpath', gets, httpversion) <- parseFirst firstLine
|
||||
@ -270,21 +271,21 @@ parseRequest' port (firstLine:otherLines) remoteHost' src = do
|
||||
let serverName' = takeUntil 58 host -- ':'
|
||||
-- FIXME isolate takes an Integer instead of Int or Int64. If this is a
|
||||
-- performance penalty, we may need our own version.
|
||||
rbody <- C.bufferSource $ src C.$= CB.isolate (fromIntegral len)
|
||||
return (len, Request
|
||||
{ requestMethod = method
|
||||
, httpVersion = httpversion
|
||||
, pathInfo = H.decodePathSegments rpath
|
||||
, rawPathInfo = rpath
|
||||
, rawQueryString = gets
|
||||
, queryString = H.parseQuery gets
|
||||
, serverName = serverName'
|
||||
, serverPort = port
|
||||
, requestHeaders = heads
|
||||
, isSecure = False
|
||||
, remoteHost = remoteHost'
|
||||
, requestBody = rbody
|
||||
})
|
||||
rbody <- C.bufferSource $ src C.$= CB.isolate len
|
||||
return Request
|
||||
{ requestMethod = method
|
||||
, httpVersion = httpversion
|
||||
, pathInfo = H.decodePathSegments rpath
|
||||
, rawPathInfo = rpath
|
||||
, rawQueryString = gets
|
||||
, queryString = H.parseQuery gets
|
||||
, serverName = serverName'
|
||||
, serverPort = port
|
||||
, requestHeaders = heads
|
||||
, isSecure = False
|
||||
, remoteHost = remoteHost'
|
||||
, requestBody = rbody
|
||||
}
|
||||
|
||||
|
||||
takeUntil :: Word8 -> ByteString -> ByteString
|
||||
@ -427,41 +428,33 @@ sendResponse th req socket r = sendResponse' r
|
||||
`mappend` chunkedTransferTerminator
|
||||
else (headers' False) `mappend` b
|
||||
|
||||
sendResponse' (ResponseStream res) =
|
||||
res enumResponse
|
||||
sendResponse' (ResponseSource s hs body) =
|
||||
response
|
||||
where
|
||||
enumResponse :: H.Status -> H.ResponseHeaders -> C.SinkM Builder IO Bool
|
||||
enumResponse s hs =
|
||||
response
|
||||
where
|
||||
headers' = headers version s hs
|
||||
-- FIXME perhaps alloca a buffer per thread and reuse that in all functiosn below. Should lessen greatly the GC burden (I hope)
|
||||
response
|
||||
| not (hasBody s req) = do
|
||||
liftIO $ Sock.sendMany socket
|
||||
$ L.toChunks $ toLazyByteString
|
||||
$ headers' False
|
||||
return (checkPersist req)
|
||||
| otherwise = C.SinkM $ do
|
||||
let sink = builderToByteString C.=$ sinkSocket th (isKeepAlive hs) socket
|
||||
CL.fromList [headers' needsChunked'] C.$$ sink
|
||||
C.genSink $ chunk' sink
|
||||
needsChunked' = needsChunked hs
|
||||
chunk' sink = if needsChunked'
|
||||
then chunk C.=$ sink
|
||||
else sink
|
||||
chunk :: C.ConduitM Builder IO Builder
|
||||
chunk = C.ConduitM $ return $ C.Conduit
|
||||
{ C.conduitPush = push
|
||||
, C.conduitClose = close
|
||||
}
|
||||
headers' = headers version s hs
|
||||
-- FIXME perhaps alloca a buffer per thread and reuse that in all
|
||||
-- functions below. Should lessen greatly the GC burden (I hope)
|
||||
response
|
||||
| not (hasBody s req) = do
|
||||
liftIO $ Sock.sendMany socket
|
||||
$ L.toChunks $ toLazyByteString
|
||||
$ headers' False
|
||||
return (checkPersist req)
|
||||
| otherwise = do
|
||||
let src =
|
||||
CL.sourceList [headers' needsChunked'] `mappend`
|
||||
(if needsChunked' then body C.$= chunk else body)
|
||||
src C.$$ builderToByteString C.=$ sinkSocket th socket
|
||||
return $ isKeepAlive hs
|
||||
needsChunked' = needsChunked hs
|
||||
chunk :: C.Conduit Builder IO Builder
|
||||
chunk = C.Conduit $ return $ C.PreparedConduit
|
||||
{ C.conduitPush = push
|
||||
, C.conduitClose = close
|
||||
}
|
||||
|
||||
go [] = id
|
||||
go [x] = (chunkedTransferEncoding x:)
|
||||
go xs = (chunkedTransferEncoding (mconcat xs):)
|
||||
|
||||
push xs = return $ C.ConduitResult C.Processing $ go xs []
|
||||
close xs = return $ C.ConduitResult [] $ go xs [chunkedTransferTerminator]
|
||||
push x = return $ C.Producing [chunkedTransferEncoding x]
|
||||
close = return [chunkedTransferTerminator]
|
||||
|
||||
parseHeaderNoAttr :: ByteString -> H.Header
|
||||
parseHeaderNoAttr s =
|
||||
@ -473,14 +466,14 @@ parseHeaderNoAttr s =
|
||||
else rest
|
||||
in (CI.mk k, rest')
|
||||
|
||||
sourceSocket :: T.Handle -> Int -> Socket -> C.Source IO ByteString
|
||||
sourceSocket th len socket = C.Source
|
||||
sourceSocket :: T.Handle -> Int -> Socket -> C.PreparedSource IO ByteString
|
||||
sourceSocket th len socket = C.PreparedSource
|
||||
{ C.sourcePull = do
|
||||
bs <- liftIO $ Sock.recv socket len
|
||||
liftIO $ T.tickle th
|
||||
return $ if S.null bs
|
||||
then C.SourceResult C.StreamClosed []
|
||||
else C.SourceResult C.StreamOpen [bs]
|
||||
then C.Closed
|
||||
else C.Open bs
|
||||
, C.sourceClose = return ()
|
||||
}
|
||||
|
||||
@ -488,23 +481,19 @@ sourceSocket th len socket = C.Source
|
||||
--separate package.
|
||||
|
||||
sinkSocket :: T.Handle
|
||||
-> ret
|
||||
-> Socket
|
||||
-> C.SinkM B.ByteString IO ret
|
||||
sinkSocket th ret sock = C.SinkM $ return $ C.SinkData
|
||||
-> C.Sink B.ByteString IO ()
|
||||
sinkSocket th sock = C.Sink $ return $ C.SinkData
|
||||
{ C.sinkPush = push
|
||||
, C.sinkClose = close
|
||||
}
|
||||
where
|
||||
close xs = do
|
||||
close = do
|
||||
liftIO (T.resume th)
|
||||
liftIO $ Sock.sendMany sock xs
|
||||
liftIO (T.resume th)
|
||||
return (C.SinkResult [] ret)
|
||||
push [] = return $ C.Processing
|
||||
push xs = do
|
||||
return ()
|
||||
push x = do
|
||||
liftIO $ T.resume th
|
||||
liftIO $ Sock.sendMany sock xs
|
||||
liftIO $ Sock.sendAll sock x
|
||||
liftIO $ T.pause th
|
||||
return $ C.Processing
|
||||
-- We pause timeouts before passing control back to user code. This ensures
|
||||
@ -523,7 +512,7 @@ data Settings = Settings
|
||||
, settingsHost :: String -- ^ Host to bind to, or * for all. Default value: *
|
||||
, settingsOnException :: SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr.
|
||||
, settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
|
||||
, settingsIntercept :: Request -> Maybe (C.BSource IO S.ByteString -> Socket -> ResourceT IO ())
|
||||
, settingsIntercept :: Request -> Maybe (C.BufferedSource IO S.ByteString -> Socket -> ResourceT IO ())
|
||||
, settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'
|
||||
}
|
||||
|
||||
@ -550,7 +539,7 @@ defaultSettings = Settings
|
||||
go' (Just ThreadKilled) = False
|
||||
go' _ = True
|
||||
|
||||
takeHeaders :: C.BSource IO ByteString -> ResourceT IO [ByteString]
|
||||
takeHeaders :: C.BufferedSource IO ByteString -> ResourceT IO [ByteString]
|
||||
takeHeaders src = do
|
||||
!x <- forceHead ConnectionClosedByPeer src
|
||||
takeHeaders' 0 id id x src
|
||||
@ -561,7 +550,7 @@ takeHeaders' :: Int
|
||||
-> ([ByteString] -> [ByteString])
|
||||
-> ([ByteString] -> [ByteString])
|
||||
-> ByteString
|
||||
-> C.BSource IO ByteString
|
||||
-> C.BufferedSource IO ByteString
|
||||
-> ResourceT IO [ByteString]
|
||||
takeHeaders' !len _ _ _ _ | len > maxTotalHeaderLength = throwIO OverLargeHeader
|
||||
takeHeaders' !len !lines !prepend !bs src = do
|
||||
@ -590,7 +579,7 @@ takeHeaders' !len !lines !prepend !bs src = do
|
||||
if start < bsLen
|
||||
then {-# SCC "takeHeaders'.noMoreHeaders.yield" #-} do
|
||||
let !rest = {-# SCC "takeHeaders'.noMoreHeaders.yield.rest" #-} SU.unsafeDrop start bs
|
||||
C.bsourceUnpull src [rest]
|
||||
C.bsourceUnpull src rest
|
||||
return lines'
|
||||
else return lines'
|
||||
|
||||
@ -606,7 +595,7 @@ takeHeaders' !len !lines !prepend !bs src = do
|
||||
{-# INLINE takeHeaders' #-}
|
||||
|
||||
forceHead :: InvalidRequest
|
||||
-> C.BSource IO ByteString
|
||||
-> C.BufferedSource IO ByteString
|
||||
-> ResourceT IO ByteString
|
||||
forceHead err src = do
|
||||
!mx <- src C.$$ CL.head
|
||||
|
||||
@ -21,6 +21,7 @@ Library
|
||||
, wai >= 1.0 && < 1.1
|
||||
, transformers >= 0.2.2 && < 0.3
|
||||
, conduit >= 0.0 && < 0.1
|
||||
, blaze-builder-conduit >= 0.0 && < 0.1
|
||||
, lifted-base >= 0.1 && < 0.2
|
||||
, blaze-builder >= 0.2.1.4 && < 0.4
|
||||
, simple-sendfile >= 0.1 && < 0.3
|
||||
|
||||
Loading…
Reference in New Issue
Block a user