Permalink
Browse files

Full upgrade to conduit 0.5

  • Loading branch information...
1 parent 8d24847 commit 2d2582c450327747e1134633424e849aad749f5c @snoyberg snoyberg committed Jun 21, 2012
View
8 wai-app-static/wai-app-static.cabal
@@ -1,5 +1,5 @@
name: wai-app-static
-version: 1.2.0.3
+version: 1.3.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@@ -24,7 +24,7 @@ Flag print
library
build-depends: base >= 4 && < 5
- , wai >= 1.2 && < 1.3
+ , wai >= 1.3 && < 1.4
, bytestring >= 0.9.1.4
, http-types >= 0.6 && < 0.7
, transformers >= 0.2.2 && < 0.4
@@ -43,7 +43,7 @@ library
, http-date
, blaze-html >= 0.5 && < 0.6
, blaze-markup >= 0.5.1 && < 0.6
- , crypto-conduit >= 0.3.2 && < 0.4
+ , crypto-conduit >= 0.4 && < 0.5
, cereal >= 0.3.5 && < 0.4
exposed-modules: Network.Wai.Application.Static
@@ -53,7 +53,7 @@ library
WaiAppStatic.Mime
WaiAppStatic.Types
other-modules: Util
- ghc-options: -Wall -Werror
+ ghc-options: -Wall
extensions: CPP
if flag(print)
View
39 wai-eventsource/src/Network/Wai/EventSource.hs
@@ -10,8 +10,7 @@ module Network.Wai.EventSource (
import Blaze.ByteString.Builder (Builder)
import Control.Concurrent.Chan (Chan, dupChan, readChan)
import Control.Monad.IO.Class (liftIO)
-import Data.Conduit (($=))
-import qualified Data.Conduit as C
+import Data.Conduit
import qualified Data.Conduit.List as CL
import Network.HTTP.Types (status200)
import Network.Wai (Application, Response(..))
@@ -27,45 +26,39 @@ eventSourceAppChan chan _ = do
-- | Make a new WAI EventSource application reading events from
-- the given source.
-eventSourceAppSource :: C.Source (C.ResourceT IO) ServerEvent -> Application
+eventSourceAppSource :: Source (ResourceT IO) ServerEvent -> Application
eventSourceAppSource src _ = return $ response sourceToSource src
-- | Make a new WAI EventSource application reading events from
-- the given IO action.
eventSourceAppIO :: IO ServerEvent -> Application
eventSourceAppIO act _ = return $ response ioToSource act
-response :: (a -> C.Source (C.ResourceT IO) (C.Flush Builder)) -> a -> Response
+response :: (a -> Source (ResourceT IO) (Flush Builder)) -> a -> Response
response f a = ResponseSource status200 [("Content-Type", "text/event-stream")] $ f a
-chanToSource :: Chan ServerEvent -> C.Source (C.ResourceT IO) (C.Flush Builder)
-chanToSource chan =
- C.sourceState Nothing pull
- where
- pull Nothing = do
- x <- liftIO $ readChan chan
- return $ case eventToBuilder x of
- Nothing -> C.StateClosed
- Just y -> C.StateOpen (Just C.Flush) (C.Chunk y)
- pull (Just x) = return $ C.StateOpen Nothing x
+chanToSource :: Chan ServerEvent -> Source (ResourceT IO) (Flush Builder)
+chanToSource = ioToSource . readChan
-ioToSource :: IO ServerEvent -> C.Source (C.ResourceT IO) (C.Flush Builder)
+ioToSource :: IO ServerEvent -> Source (ResourceT IO) (Flush Builder)
ioToSource act =
- C.sourceState Nothing pull
+ loop
where
- pull Nothing = do
+ loop = do
x <- liftIO act
- return $ case eventToBuilder x of
- Nothing -> C.StateClosed
- Just y -> C.StateOpen (Just C.Flush) (C.Chunk y)
- pull (Just x) = return $ C.StateOpen Nothing x
+ case eventToBuilder x of
+ Nothing -> return ()
+ Just y -> do
+ yield $ Chunk y
+ yield Flush
+ loop
-- | Convert a ServerEvent source into a Builder source of serialized
-- events.
-sourceToSource :: Monad m => C.Source m ServerEvent -> C.Source m (C.Flush Builder)
+sourceToSource :: Monad m => Source m ServerEvent -> Source m (Flush Builder)
sourceToSource src = src $= CL.concatMap eventToFlushBuilder
where
eventToFlushBuilder event =
case eventToBuilder event of
Nothing -> []
- Just x -> [C.Chunk x, C.Flush]
+ Just x -> [Chunk x, Flush]
View
8 wai-eventsource/wai-eventsource.cabal
@@ -1,5 +1,5 @@
Name: wai-eventsource
-Version: 1.2.0.2
+Version: 1.3.0
Synopsis: WAI support for server-sent events
Description: WAI support for server-sent events
License: MIT
@@ -17,10 +17,10 @@ Library
base >= 4.3 && < 5
, bytestring >= 0.9.1.4
, blaze-builder >= 0.3 && < 0.4
- , conduit >= 0.4 && < 0.5
+ , conduit >= 0.5 && < 0.6
, http-types >= 0.6 && < 0.7
- , wai >= 1.2 && < 1.3
- , warp >= 1.2 && < 1.3
+ , wai >= 1.3 && < 1.4
+ , warp >= 1.3 && < 1.4
, transformers
ghc-options: -Wall
View
38 wai-extra/Network/Wai/Handler/CGI.hs
@@ -30,7 +30,7 @@ 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 Data.Conduit
import qualified Data.Conduit.List as CL
safeRead :: Read a => a -> String -> a
@@ -66,7 +66,7 @@ runSendfile sf app = do
-- stick with 'run' or 'runSendfile'.
runGeneric
:: [(String, String)] -- ^ all variables
- -> (Int -> C.Source (C.ResourceT IO) B.ByteString) -- ^ responseBody of input
+ -> (Int -> Source (ResourceT IO) B.ByteString) -- ^ responseBody of input
-> (B.ByteString -> IO ()) -- ^ destination for output
-> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?
-> Application
@@ -94,7 +94,7 @@ runGeneric vars inputH outputH xsendfile app = do
case addrs of
a:_ -> addrAddress a
[] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'
- C.runResourceT $ do
+ runResourceT $ do
let env = Request
{ requestMethod = rmethod
, rawPathInfo = B.pack pinfo
@@ -117,9 +117,9 @@ runGeneric vars inputH outputH xsendfile app = do
liftIO $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp
_ -> do
let (s, hs, b) = responseSource res
- src = CL.sourceList [C.Chunk $ headers s hs `mappend` fromChar '\n']
+ src = CL.sourceList [Chunk $ headers s hs `mappend` fromChar '\n']
`mappend` b
- src C.$$ builderSink
+ src $$ builderSink
where
headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))
status (Status i m) = (fromByteString "Status", mconcat
@@ -141,13 +141,13 @@ runGeneric vars inputH outputH xsendfile app = do
, fromByteString sf
, fromByteString " not supported"
]
- bsSink = C.NeedInput push (return ())
- push (C.Chunk bs) = C.PipeM (do
+ bsSink = awaitE >>= either return push
+ push (Chunk bs) = do
liftIO $ outputH bs
- return bsSink) (return ())
+ bsSink
-- FIXME actually flush?
- push C.Flush = bsSink
- builderSink = builderToByteStringFlush C.=$ bsSink
+ push Flush = bsSink
+ builderSink = builderToByteStringFlush =$ bsSink
fixHeaders h =
case lookup "content-type" h of
Nothing -> ("Content-Type", "text/html; charset=utf-8") : h
@@ -166,19 +166,19 @@ cleanupVarName s =
helper' (x:rest) = toLower x : helper' rest
helper' [] = []
-requestBodyHandle :: Handle -> Int -> C.Source (C.ResourceT IO) B.ByteString
+requestBodyHandle :: Handle -> Int -> Source (ResourceT 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 -> C.Source (C.ResourceT IO) B.ByteString
-requestBodyFunc get count0 =
- C.sourceState count0 pull
+requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source (ResourceT IO) B.ByteString
+requestBodyFunc get =
+ loop
where
- pull 0 = return C.StateClosed
- pull count = do
+ loop 0 = return ()
+ loop count = do
mbs <- liftIO $ get $ min count defaultChunkSize
let count' = count - maybe 0 B.length mbs
- return $ case mbs of
- Nothing -> C.StateClosed
- Just bs -> C.StateOpen count' bs
+ case mbs of
+ Nothing -> return ()
+ Just bs -> yield bs >> loop count'
View
164 wai-extra/Network/Wai/Parse.hs
@@ -36,15 +36,15 @@ import Data.Function (on)
import System.Directory (removeFile, getTemporaryDirectory)
import System.IO (hClose, openBinaryTempFile)
import Network.Wai
-import qualified Data.Conduit as C
+import Data.Conduit
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Binary as CB
import Control.Monad.IO.Class (liftIO)
import qualified Network.HTTP.Types as H
import Data.Either (partitionEithers)
+import Control.Monad (when, unless)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Resource (allocate, release, register)
-import Data.Void (absurd)
uncons :: S.ByteString -> Maybe (Word8, S.ByteString)
uncons s
@@ -97,11 +97,11 @@ parseHttpAccept = map fst
trimWhite = S.dropWhile (== 32) -- space
-- | Store uploaded files in memory
-lbsSink :: Monad m => C.Sink S.ByteString m L.ByteString
+lbsSink :: Monad m => Sink S.ByteString m L.ByteString
lbsSink = fmap L.fromChunks CL.consume
-- | Save uploaded files on disk as temporary files
-tempFileSink :: C.MonadResource m => C.Sink S.ByteString m FilePath
+tempFileSink :: MonadResource m => Sink S.ByteString m FilePath
tempFileSink = do
(key, (fp, h)) <- lift $ allocate (do
tempDir <- getTemporaryDirectory
@@ -145,45 +145,47 @@ getRequestBodyType req = do
else Nothing
else Nothing
-parseRequestBody :: C.Sink S.ByteString (C.ResourceT IO) y
+parseRequestBody :: Sink S.ByteString (ResourceT IO) y
-> Request
- -> C.ResourceT IO ([Param], [File y])
+ -> ResourceT IO ([Param], [File y])
parseRequestBody s r =
case getRequestBodyType r of
Nothing -> return ([], [])
- Just rbt -> fmap partitionEithers $ requestBody r C.$$ conduitRequestBody s rbt C.=$ CL.consume
+ Just rbt -> fmap partitionEithers $ requestBody r $$ conduitRequestBody s rbt =$ CL.consume
-sinkRequestBody :: C.Sink S.ByteString (C.ResourceT IO) y
+sinkRequestBody :: Sink S.ByteString (ResourceT IO) y
-> RequestBodyType
- -> C.Sink S.ByteString (C.ResourceT IO) ([Param], [File y])
-sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r C.=$ CL.consume
+ -> Sink S.ByteString (ResourceT IO) ([Param], [File y])
+sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r =$ CL.consume
-conduitRequestBody :: C.Sink S.ByteString (C.ResourceT IO) y
+conduitRequestBody :: Sink S.ByteString (ResourceT IO) y
-> RequestBodyType
- -> C.Conduit S.ByteString (C.ResourceT IO) (Either Param (File y))
-conduitRequestBody _ UrlEncoded = C.sequenceSink () $ \() -> do -- url-encoded
+ -> Conduit S.ByteString (ResourceT IO) (Either Param (File y))
+conduitRequestBody _ UrlEncoded = do
-- NOTE: in general, url-encoded data will be in a single chunk.
-- Therefore, I'm optimizing for the usual case by sticking with
-- strict byte strings here.
bs <- CL.consume
- return $ C.Emit () $ map Left $ H.parseSimpleQuery $ S.concat bs
+ mapM_ yield $ map Left $ H.parseSimpleQuery $ S.concat bs
conduitRequestBody backend (Multipart bound) =
parsePieces backend $ S8.pack "--" `S.append` bound
-takeLine :: C.Sink S.ByteString (C.ResourceT IO) (Maybe S.ByteString)
+takeLine :: Monad m => Pipe S.ByteString S.ByteString o u m (Maybe S.ByteString)
takeLine =
- C.sinkState id push close'
+ go id
where
- close' _ = return Nothing
+ go front = await >>= maybe (close front) (push front)
+
+ close front = leftover (front S.empty) >> return Nothing
push front bs = do
let (x, y) = S.break (== 10) $ front bs -- LF
in if S.null y
- then return $ C.StateProcessing $ S.append x
+ then go $ S.append x
else do
- let lo = if S.length y > 1 then Just (S.drop 1 y) else Nothing
- return $ C.StateDone lo $ Just $ killCR x
+ when (S.length y > 1) $ leftover $ S.drop 1 y
+ return $ Just $ killCR x
-takeLines :: C.Sink S.ByteString (C.ResourceT IO) [S.ByteString]
+takeLines :: Pipe S.ByteString S.ByteString o u (ResourceT IO) [S.ByteString]
takeLines = do
res <- takeLine
case res of
@@ -194,20 +196,16 @@ takeLines = do
ls <- takeLines
return $ l : ls
-parsePieces :: C.Sink S.ByteString (C.ResourceT IO) y -> S.ByteString
- -> C.Conduit S.ByteString (C.ResourceT IO) (Either Param (File y))
-parsePieces sink bound = C.sequenceSink True (parsePiecesSink sink bound)
-
-parsePiecesSink :: C.Sink S.ByteString (C.ResourceT IO) y
- -> S.ByteString
- -> C.SequencedSink Bool S.ByteString (C.ResourceT IO) (Either Param (File y))
-parsePiecesSink _ _ False = return C.Stop
-parsePiecesSink sink bound True = do
- _boundLine <- takeLine
- res' <- takeLines
- case res' of
- [] -> return C.Stop
- _ -> do
+parsePieces :: Sink S.ByteString (ResourceT IO) y
+ -> S.ByteString
+ -> Pipe S.ByteString S.ByteString (Either Param (File y)) u (ResourceT IO) ()
+parsePieces sink bound =
+ loop
+ where
+ loop = do
+ _boundLine <- takeLine
+ res' <- takeLines
+ unless (null res') $ do
let ls' = map parsePair res'
let x = do
cd <- lookup contDisp ls'
@@ -218,30 +216,31 @@ parsePiecesSink sink bound True = do
case x of
Just (mct, name, Just filename) -> do
let ct = fromMaybe "application/octet-stream" mct
- (y, wasFound) <- sinkTillBound' Nothing bound sink
+ (wasFound, y) <- sinkTillBound' bound sink
let fi = FileInfo filename ct y
let y' = (name, fi)
- return $ C.Emit wasFound [Right y']
+ yield $ Right y'
+ when wasFound loop
Just (_ct, name, Nothing) -> do
let seed = id
let iter front bs = return $ front . (:) bs
- (front, wasFound) <-
- sinkTillBound bound iter seed
+ (wasFound, front) <- sinkTillBound bound iter seed
let bs = S.concat $ front []
let x' = (name, qsDecode bs)
- return $ C.Emit wasFound [Left x']
+ yield $ Left x'
+ when wasFound loop
_ -> do
-- ignore this part
let seed = ()
iter () _ = return ()
- ((), wasFound) <- sinkTillBound bound iter seed
- return $ C.Emit wasFound []
- where
- contDisp = S8.pack "Content-Disposition"
- contType = S8.pack "Content-Type"
- parsePair s =
- let (x, y) = breakDiscard 58 s -- colon
- in (x, S.dropWhile (== 32) y) -- space
+ (wasFound, ()) <- sinkTillBound bound iter seed
+ when wasFound loop
+ where
+ contDisp = S8.pack "Content-Disposition"
+ contType = S8.pack "Content-Type"
+ parsePair s =
+ let (x, y) = breakDiscard 58 s -- colon
+ in (x, S.dropWhile (== 32) y) -- space
data Bound = FoundBound S.ByteString S.ByteString
| NoBound
@@ -265,60 +264,49 @@ findBound b bs = go [0..S.length bs - 1]
| S.index b x == S.index bs y = mismatch xs ys
| otherwise = True
-sinkTillBound' :: Maybe S.ByteString -> S.ByteString -> C.Sink S.ByteString (C.ResourceT IO) y -> C.Sink S.ByteString (C.ResourceT IO) (y, Bool)
-sinkTillBound' mfront _ (C.Done _ y) = C.Done mfront (y, False)
-sinkTillBound' _ _ (C.HaveOutput _ _ o) = absurd o
-sinkTillBound' mfront bound (C.PipeM mp mc) = C.PipeM (fmap (sinkTillBound' mfront bound) mp) (fmap (\y -> (y, False)) mc)
-sinkTillBound' mfront bound (C.NeedInput pushI closeI) =
- C.NeedInput push close
+sinkTillBound' :: S.ByteString
+ -> Sink S.ByteString (ResourceT IO) y
+ -> Pipe S.ByteString S.ByteString o u (ResourceT IO) (Bool, y)
+sinkTillBound' bound sink = conduitTillBound bound >+> withUpstream (sinkToPipe sink)
+
+conduitTillBound :: Monad m
+ => S.ByteString -- bound
+ -> Pipe S.ByteString S.ByteString S.ByteString u m Bool
+conduitTillBound bound =
+ go id
where
- push bs' = do
- let bs = maybe id S.append mfront $ bs'
+ go front = await >>= maybe (close front) (push front)
+ close front = do
+ let bs = front S.empty
+ unless (S.null bs) $ yield bs
+ return False
+ push front bs' = do
+ let bs = front bs'
case findBound bound bs of
FoundBound before after -> do
let before' = killCRLF before
- res <- lift $ return () C.$$ pushI before'
- C.Done (Just after) (res, True)
+ yield before'
+ leftover after
+ return True
NoBound -> do
-- don't emit newlines, in case it's part of a bound
let (toEmit, front') =
if not (S8.null bs) && S8.last bs `elem` "\r\n"
then let (x, y) = S.splitAt (S.length bs - 2) bs
- in (x, Just y)
- else (bs, Nothing)
- sinkTillBound' front' bound (pushI toEmit)
- PartialBound -> sinkTillBound' (Just bs) bound (C.NeedInput pushI closeI)
- close = fmap (\y -> (y, False)) closeI
+ in (x, S.append y)
+ else (bs, id)
+ yield toEmit
+ go front'
+ PartialBound -> go $ S.append bs
sinkTillBound :: S.ByteString
-> (x -> S.ByteString -> IO x)
-> x
- -> C.Sink S.ByteString (C.ResourceT IO) (x, Bool)
-sinkTillBound bound iter seed0 = C.sinkState
- (id, seed0)
- push
- close'
+ -> Pipe S.ByteString S.ByteString o u (ResourceT IO) (Bool, x)
+sinkTillBound bound iter seed0 =
+ conduitTillBound bound >+> withUpstream (CL.foldM iter' seed0)
where
- close' (front, seed) = do
- seed' <- liftIO $ iter seed $ front S.empty
- return (seed', False)
- push (front, seed) bs' = do
- let bs = front bs'
- case findBound bound bs of
- FoundBound before after -> do
- let before' = killCRLF before
- seed' <- liftIO $ iter seed before'
- return $ C.StateDone (Just after) (seed', True)
- NoBound -> do
- -- don't emit newlines, in case it's part of a bound
- let (toEmit, front') =
- if not (S8.null bs) && S8.last bs `elem` "\r\n"
- then let (x, y) = S.splitAt (S.length bs - 2) bs
- in (x, S.append y)
- else (bs, id)
- seed' <- liftIO $ iter seed toEmit
- return $ C.StateProcessing (front', seed')
- PartialBound -> return $ C.StateProcessing (S.append bs, seed)
+ iter' a b = liftIO $ iter a b
parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]
parseAttrs = map go . S.split 59 -- semicolon
View
14 wai-extra/wai-extra.cabal
@@ -1,5 +1,5 @@
Name: wai-extra
-Version: 1.2.0.4
+Version: 1.3.0
Synopsis: Provides some basic WAI handlers and middleware.
Description: The goal here is to provide common features without many dependencies.
License: MIT
@@ -22,7 +22,7 @@ extra-source-files:
Library
Build-Depends: base >= 4 && < 5
, bytestring >= 0.9.1.4
- , wai >= 1.2 && < 1.3
+ , wai >= 1.3 && < 1.4
, old-locale >= 1.0.0.2 && < 1.1
, time >= 1.1.4
, network >= 2.2.1.5 && < 2.4
@@ -34,9 +34,9 @@ Library
, case-insensitive >= 0.2
, data-default >= 0.3 && < 0.5
, fast-logger >= 0.0.2
- , conduit >= 0.4 && < 0.5
- , zlib-conduit >= 0.4 && < 0.5
- , blaze-builder-conduit >= 0.4 && < 0.5
+ , conduit >= 0.5 && < 0.6
+ , zlib-conduit >= 0.5 && < 0.6
+ , blaze-builder-conduit >= 0.5 && < 0.6
, ansi-terminal
, resourcet >= 0.3 && < 0.4
, void >= 0.5 && < 0.6
@@ -63,8 +63,8 @@ test-suite tests
build-depends: base >= 4 && < 5
, wai-extra
- , wai-test
- , hspec >= 0.8 && < 1.2
+ , wai-test >= 1.3
+ , hspec
, HUnit
, wai
View
6 wai-frontend-monadcgi/wai-frontend-monadcgi.cabal
@@ -1,5 +1,5 @@
name: wai-frontend-monadcgi
-version: 1.2.0.2
+version: 1.3.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@@ -16,11 +16,11 @@ library
, bytestring
, containers >= 0.2
, cgi
- , conduit >= 0.4
+ , conduit >= 0.5 && < 0.6
, http-types
, transformers
, case-insensitive
- , wai >= 1.2 && < 1.3
+ , wai >= 1.3 && < 1.4
exposed-modules: Network.Wai.Frontend.MonadCGI
ghc-options: -Wall
View
12 wai-handler-devel/wai-handler-devel.cabal
@@ -1,5 +1,5 @@
Name: wai-handler-devel
-Version: 1.2.0.2
+Version: 1.3.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.
.
@@ -22,12 +22,12 @@ Source-repository head
Library
Build-Depends: base >= 4 && < 5
- , wai >= 1.2 && < 1.3
- , wai-extra >= 1.2 && < 1.3
+ , wai >= 1.3 && < 1.4
+ , wai-extra >= 1.3 && < 1.4
, http-types >= 0.6 && < 0.7
- , warp >= 1.2 && < 1.3
- , directory >= 1.0.1 && < 1.2
- , network >= 2.2.1.5 && < 2.4
+ , warp >= 1.3 && < 1.4
+ , directory >= 1.0.1 && < 1.2
+ , network >= 2.2.1.5 && < 2.4
, bytestring >= 0.9.1.4
, hint >= 0.3.2.3 && < 0.4
, text >= 0.7 && < 0.12
View
6 wai-handler-fastcgi/wai-handler-fastcgi.cabal
@@ -1,5 +1,5 @@
name: wai-handler-fastcgi
-version: 1.2.0.2
+version: 1.3.0
license: MIT
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 >= 1.2 && < 1.3
- , wai-extra >= 1.2 && < 1.3
+ , wai >= 1.3 && < 1.4
+ , wai-extra >= 1.3 && < 1.4
, bytestring >= 0.9.1.4
exposed-modules: Network.Wai.Handler.FastCGI
ghc-options: -Wall
View
41 wai-handler-launch/Network/Wai/Handler/Launch.hs
@@ -11,19 +11,19 @@ import Network.Wai
import Network.HTTP.Types
import qualified Network.Wai.Handler.Warp as Warp
import Data.IORef
-import Control.Concurrent
+import Control.Concurrent (forkIO, threadDelay)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString as S
import Blaze.ByteString.Builder (fromByteString)
#if WINDOWS
import Foreign
-import Foreign.C.String
+import Foreign.String
#else
import System.Cmd (rawSystem)
#endif
import Data.Conduit.Zlib (decompressFlush, WindowBits (WindowBits))
import Data.Conduit.Blaze (builderToByteStringFlush)
-import qualified Data.Conduit as C
+import Data.Conduit
import qualified Data.Conduit.List as CL
ping :: IORef Bool -> Middleware
@@ -50,42 +50,45 @@ ping var app req
let headers'' = filter (\(x, _) -> x /= "content-length") headers'
let fixEnc src =
if isEnc then
- src C.$= decompressFlush (WindowBits 31)
+ src $= decompressFlush (WindowBits 31)
else src
return $ ResponseSource s headers''
- $ fixEnc (body C.$= builderToByteStringFlush)
- C.$= insideHead
- C.$= CL.map (fmap fromByteString)
+ $ fixEnc (body $= builderToByteStringFlush)
+ $= insideHead
+ $= CL.map (fmap fromByteString)
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 (C.Flush S.ByteString) (C.ResourceT IO) (C.Flush S.ByteString)
+insideHead :: Pipe l (Flush S.ByteString) (Flush S.ByteString) r (ResourceT IO) r
insideHead =
- C.conduitState (Just (S.empty, whole)) push' close
+ loop' (S.empty, whole)
where
+ loop' state = awaitE >>= either (close state) (push' state)
whole = "<head>"
- push' state (C.Chunk x) = (fmap . fmap) C.Chunk (push state x)
- push' state C.Flush = return $ C.StateProducing state [C.Flush]
- push (Just (held, atFront)) x
+ push' state (Chunk x) = push state x
+ push' state Flush = yield Flush >> loop' state
+
+ push (held, atFront) x
| atFront `S.isPrefixOf` x = do
let y = S.drop (S.length atFront) x
- return $ C.StateProducing Nothing [held, atFront, toInsert, y]
+ mapM_ (yield . Chunk) [held, atFront, toInsert, y]
+ CL.map id
| whole `S.isInfixOf` x = do
let (before, rest) = S.breakSubstring whole x
let after = S.drop (S.length whole) rest
- return $ C.StateProducing Nothing [held, before, whole, toInsert, after]
+ mapM_ (yield . Chunk) [held, before, whole, toInsert, after]
+ CL.map id
| x `S.isPrefixOf` atFront = do
let held' = held `S.append` x
atFront' = S.drop (S.length x) atFront
- return $ C.StateProducing (Just (held', atFront')) []
+ loop' (held', atFront')
| otherwise = do
let (held', atFront', x') = getOverlap whole x
- return $ C.StateProducing (Just (held', atFront')) [held, x']
- push Nothing x = return $ C.StateProducing Nothing [x]
+ mapM_ (yield . Chunk) [held, x']
+ loop' (held', atFront')
- close (Just (held, _)) = return [C.Chunk held, C.Chunk toInsert]
- close Nothing = return []
+ close (held, _) r = mapM_ yield [Chunk held, Chunk toInsert] >> return r
getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)
getOverlap whole x =
View
12 wai-handler-launch/wai-handler-launch.cabal
@@ -1,5 +1,5 @@
Name: wai-handler-launch
-Version: 1.2.0.2
+Version: 1.3.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: MIT
@@ -13,15 +13,15 @@ Cabal-version: >=1.6
Library
Exposed-modules: Network.Wai.Handler.Launch
build-depends: base >= 4 && < 5
- , wai >= 1.2 && < 1.3
- , warp >= 1.2 && < 1.3
+ , wai >= 1.3 && < 1.4
+ , warp >= 1.3 && < 1.4
, http-types >= 0.6 && < 0.7
, transformers >= 0.2.2 && < 0.4
, bytestring >= 0.9.1.4
, blaze-builder >= 0.2.1.4 && < 0.4
- , conduit >= 0.4 && < 0.5
- , blaze-builder-conduit >= 0.4 && < 0.5
- , zlib-conduit >= 0.4 && < 0.5
+ , conduit >= 0.5 && < 0.6
+ , blaze-builder-conduit >= 0.5 && < 0.6
+ , zlib-conduit >= 0.5 && < 0.6
if os(windows)
c-sources: windows.c
View
6 wai-handler-scgi/wai-handler-scgi.cabal
@@ -1,5 +1,5 @@
name: wai-handler-scgi
-version: 1.2.0.2
+version: 1.3.0
license: MIT
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 >= 1.2 && < 1.3
- , wai-extra >= 1.2 && < 1.3
+ , wai >= 1.3 && < 1.4
+ , wai-extra >= 1.3 && < 1.4
, bytestring >= 0.9.1.4
exposed-modules: Network.Wai.Handler.SCGI
ghc-options: -Wall
View
6 wai-handler-webkit/wai-handler-webkit.cabal
@@ -1,5 +1,5 @@
name: wai-handler-webkit
-version: 1.2.0
+version: 1.3.0
license: MIT
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 >= 1.2 && < 1.3
- , warp >= 1.2 && < 1.3
+ , wai >= 1.3 && < 1.4
+ , warp >= 1.3 && < 1.4
ghc-options: -Wall
exposed-modules: Network.Wai.Handler.Webkit
c-sources: webkit.cpp
View
8 wai-test/Network/Wai/Test.hs
@@ -99,19 +99,13 @@ srequest (SRequest req bod) = do
runResponse :: Response -> C.ResourceT IO SResponse
runResponse res = do
- bss <- fmap2 toBuilder body C.$= builderToByteString C.$$ CL.consume
+ bss <- C.mapOutput toBuilder body C.$= builderToByteString C.$$ CL.consume
return $ SResponse s h $ L.fromChunks bss
where
(s, h, body) = responseSource res
toBuilder (C.Chunk builder) = builder
toBuilder C.Flush = flush
-fmap2 :: Functor m => (a -> b) -> C.Source m a -> C.Source m b
-fmap2 f (C.HaveOutput p c o) = C.HaveOutput (fmap2 f p) c (f o)
-fmap2 f (C.NeedInput p c) = C.NeedInput (fmap2 f . p) (fmap2 f c)
-fmap2 _ (C.Done i r) = C.Done i r
-fmap2 f (C.PipeM mp c) = C.PipeM (fmap (fmap2 f) mp) c
-
assertBool :: String -> Bool -> Session ()
assertBool s b = liftIO $ H.assertBool s b
View
8 wai-test/wai-test.cabal
@@ -1,5 +1,5 @@
name: wai-test
-version: 1.2.0.2
+version: 1.3.0
license: MIT
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 >= 1.2 && < 1.3
+ , wai >= 1.3 && < 1.4
, bytestring >= 0.9.1.4
, text >= 0.7 && < 0.12
, blaze-builder >= 0.2.1.4 && < 0.4
, transformers >= 0.2.2 && < 0.4
, containers >= 0.2
- , conduit >= 0.4 && < 0.5
- , blaze-builder-conduit >= 0.4 && < 0.5
+ , conduit >= 0.5 && < 0.6
+ , blaze-builder-conduit >= 0.5 && < 0.6
, cookie >= 0.2 && < 0.5
, HUnit >= 1.2 && < 1.3
, http-types >= 0.6 && < 0.7
View
20 wai-websockets/Network/Wai/Handler/WebSockets.hs
@@ -8,7 +8,7 @@ import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString)
import Data.Char (toLower)
import qualified Data.ByteString.Char8 as S
-import qualified Data.Conduit as C
+import Data.Conduit
import qualified Data.Enumerator as E
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
@@ -18,15 +18,15 @@ import qualified Network.WebSockets as WS
intercept :: WS.Protocol p
=> (WS.Request -> WS.WebSockets p ())
-> Wai.Request
- -> Maybe (C.Source (C.ResourceT IO) ByteString -> Warp.Connection -> C.ResourceT IO ())
+ -> Maybe (Source (ResourceT IO) ByteString -> Warp.Connection -> ResourceT IO ())
intercept = interceptWith WS.defaultWebSocketsOptions
-- | Variation of 'intercept' which allows custom options.
interceptWith :: WS.Protocol p
=> WS.WebSocketsOptions
-> (WS.Request -> WS.WebSockets p ())
-> Wai.Request
- -> Maybe (C.Source (C.ResourceT IO) ByteString -> Warp.Connection -> C.ResourceT IO ())
+ -> Maybe (Source (ResourceT IO) ByteString -> Warp.Connection -> ResourceT IO ())
interceptWith opts app req = case lookup "upgrade" $ Wai.requestHeaders req of
Just s
| S.map toLower s == "websocket" -> Just $ runWebSockets opts req' app
@@ -41,21 +41,23 @@ runWebSockets :: WS.Protocol p
=> WS.WebSocketsOptions
-> WS.RequestHttpPart
-> (WS.Request -> WS.WebSockets p ())
- -> C.Source (C.ResourceT IO) ByteString
+ -> Source (ResourceT IO) ByteString
-> Warp.Connection
- -> C.ResourceT IO ()
+ -> ResourceT IO ()
runWebSockets opts req app source conn = do
step <- liftIO $ E.runIteratee $ WS.runWebSocketsWith opts req app send
- source C.$$ C.sinkState (E.returnI step) push close
+ source $$ sink (E.returnI step)
where
send = iterConnection conn
+ sink iter = await >>= maybe (close iter) (push iter)
+
push iter bs = do
step <- liftIO $ E.runIteratee $ E.enumList 1 [bs] E.$$ iter
case step of
- E.Continue _ -> return $ C.StateProcessing $ E.returnI step
- E.Yield out inp -> return $ C.StateDone (streamToMaybe inp) out
- E.Error e -> C.monadThrow e
+ E.Continue _ -> sink $ E.returnI step
+ E.Yield out inp -> maybe (return ()) leftover (streamToMaybe inp) >> return out
+ E.Error e -> liftIO $ monadThrow e
close iter = do
_ <- liftIO $ E.runIteratee $ E.enumEOF E.$$ iter
return ()
View
4 wai-websockets/server.lhs
@@ -87,9 +87,7 @@ actual server. For this purpose, we use the simple server provided by
> } staticApp
> staticApp :: Network.Wai.Application
-> staticApp = Static.staticApp Static.defaultFileServerSettings
-> { Static.ssFolder = Static.embeddedLookup $ Static.toEmbedded $(embedDir "static")
-> }
+> staticApp = Static.staticApp $ Static.embeddedSettings $(embedDir "static")
When a client connects, we accept the connection, regardless of the path.
View
8 wai-websockets/wai-websockets.cabal
@@ -1,5 +1,5 @@
Name: wai-websockets
-Version: 1.2.0.3
+Version: 1.3.0
Synopsis: Provide a bridge betweeen WAI and the websockets package.
License: MIT
License-file: LICENSE
@@ -19,16 +19,16 @@ flag example
Library
Build-Depends: base >= 3 && < 5
, bytestring >= 0.9.1.4
- , conduit >= 0.4 && < 0.5
- , wai >= 1.2 && < 1.3
+ , conduit >= 0.5 && < 0.6
+ , wai >= 1.3 && < 1.4
, enumerator >= 0.4.8 && < 0.5
, network-enumerator >= 0.1.2 && < 0.2
, blaze-builder >= 0.2.1.4 && < 0.4
, case-insensitive >= 0.2
, network >= 2.2.1.5 && < 2.4
, transformers >= 0.2 && < 0.4
, websockets >= 0.6 && < 0.7
- , warp >= 1.2 && < 1.3
+ , warp >= 1.3 && < 1.4
Exposed-modules: Network.Wai.Handler.WebSockets
ghc-options: -Wall
View
4 wai/wai.cabal
@@ -1,5 +1,5 @@
Name: wai
-Version: 1.2.0.3
+Version: 1.3.0
Synopsis: Web Application Interface.
Description: Provides a common protocol for communication between web applications and web servers.
License: MIT
@@ -20,7 +20,7 @@ Library
Build-Depends: base >= 4 && < 5
, bytestring >= 0.9.1.4
, blaze-builder >= 0.2.1.4 && < 0.4
- , conduit >= 0.4 && < 0.6
+ , conduit >= 0.5 && < 0.6
, network >= 2.2.1.5 && < 2.4
, http-types >= 0.6 && < 0.7
, text >= 0.7 && < 0.12
View
10 warp-static/warp-static.cabal
@@ -1,5 +1,5 @@
Name: warp-static
-Version: 1.2.0.2
+Version: 1.3.0
Synopsis: Static file server based on Warp and wai-app-static
Homepage: http://github.com/yesodweb/wai
License: MIT
@@ -15,14 +15,14 @@ Description: Serve up static files by running the warp executable. Based
Executable warp
Main-is: warp.hs
Build-depends: base >= 4 && < 5
- , warp >= 1.2 && < 1.3
- , wai-app-static >= 1.2 && < 1.3
- , wai-extra >= 1.2 && < 1.3
+ , warp >= 1.3 && < 1.4
+ , wai-app-static >= 1.3 && < 1.4
+ , wai-extra >= 1.3 && < 1.4
, cmdargs >= 0.6.7
, directory >= 1.0
, containers >= 0.2
, bytestring >= 0.9.1.4
- , text >= 0.7 && < 0.12
+ , text >= 0.7 && < 0.12
source-repository head
type: git
View
24 warp-static/warp.hs
@@ -1,11 +1,5 @@
{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
-import Network.Wai.Application.Static
- ( StaticSettings (..), staticApp, defaultMimeType, defaultListing
- , defaultMimeTypes, mimeTypeByExt
- , defaultFileServerSettings, fileSystemLookup
- , fileName, toFilePath
- , ssRedirectToIndex
- )
+import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)
import Network.Wai.Handler.Warp
( runSettings, defaultSettings, settingsHost, settingsPort
)
@@ -21,6 +15,9 @@ import qualified Data.ByteString.Char8 as S8
import Control.Arrow ((***))
import Data.Text (pack)
import Data.String (fromString)
+import WaiAppStatic.Mime (defaultMimeMap, mimeByExt, defaultMimeType)
+import WaiAppStatic.Types (ssIndices, toPiece, ssGetMimeType, fileName)
+import Data.Maybe (mapMaybe)
data Args = Args
{ docroot :: FilePath
@@ -40,8 +37,8 @@ defaultArgs = Args "." ["index.html", "index.htm"] 3000 False False False [] "*"
main :: IO ()
main = do
Args {..} <- cmdArgs defaultArgs
- let mime' = map (toFilePath *** S8.pack) mime
- let mimeMap = Map.fromList mime' `Map.union` defaultMimeTypes
+ let mime' = map (pack *** S8.pack) mime
+ let mimeMap = Map.fromList mime' `Map.union` defaultMimeMap
docroot' <- canonicalizePath docroot
unless quiet $ printf "Serving directory %s on port %d with %s index files.\n" docroot' port (if noindex then "no" else show index)
let middle = gzip def
@@ -50,10 +47,7 @@ main = do
runSettings defaultSettings
{ settingsPort = port
, settingsHost = fromString host
- } $ middle $ staticApp defaultFileServerSettings
- { ssFolder = fileSystemLookup $ toFilePath docroot
- , ssIndices = if noindex then [] else map pack index
- , ssRedirectToIndex = False
- , ssListing = Just defaultListing
- , ssGetMimeType = return . mimeTypeByExt mimeMap defaultMimeType . fileName
+ } $ middle $ staticApp (defaultFileServerSettings $ fromString docroot)
+ { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index
+ , ssGetMimeType = return . mimeByExt mimeMap defaultMimeType . fileName
}
View
10 warp-tls/warp-tls.cabal
@@ -1,5 +1,5 @@
Name: warp-tls
-Version: 1.2.0.4
+Version: 1.3.0
Synopsis: SSL support for Warp via the TLS package
License: MIT
License-file: LICENSE
@@ -15,11 +15,11 @@ Description: SSL support for Warp via the TLS package
Library
Build-Depends: base >= 4 && < 5
, bytestring >= 0.9
- , wai >= 1.2 && < 1.3
- , warp >= 1.2 && < 1.3
+ , wai >= 1.3 && < 1.4
+ , warp >= 1.3 && < 1.4
, transformers >= 0.2 && < 0.4
- , conduit >= 0.4 && < 0.5
- , network-conduit >= 0.4 && < 0.5
+ , conduit >= 0.5 && < 0.6
+ , network-conduit >= 0.5 && < 0.6
, certificate >= 1.2 && < 1.3
, pem >= 0.1 && < 0.2
, cryptocipher >= 0.3 && < 0.4
View
4 warp/warp.cabal
@@ -1,5 +1,5 @@
Name: warp
-Version: 1.2.1.2
+Version: 1.3.0
Synopsis: A fast, light-weight web server for WAI applications.
License: MIT
License-file: LICENSE
@@ -19,7 +19,7 @@ flag network-bytestring
Library
Build-Depends: base >= 3 && < 5
, bytestring >= 0.9.1.4
- , wai >= 1.2 && < 1.3
+ , wai >= 1.3 && < 1.4
, transformers >= 0.2.2 && < 0.4
, conduit >= 0.5 && < 0.6
, network-conduit >= 0.5 && < 0.6

0 comments on commit 2d2582c

Please sign in to comment.