Merge branch 'master' into wai2

Conflicts:
	wai-app-static/wai-app-static.cabal
	wai-extra/wai-extra.cabal
	wai-websockets/Network/Wai/Handler/WebSockets.hs
	wai-websockets/wai-websockets.cabal
	warp/warp.cabal

wai-extra/Network/Wai/Middleware/RequestLogger.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE CPP #-}
+
+-- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should
+-- not use CPP.
 module Network.Wai.Middleware.RequestLogger
     ( -- * Basic stdout logging
       logStdout
@@ -40,11 +42,7 @@ import System.IO.Unsafe
 
 import Data.Default (Default (def))
 import Network.Wai.Logger.Format (apacheFormat, IPAddrSource (..))
-#if MIN_VERSION_fast_logger(0,3,0)
-import System.Date.Cache (ondemandDateCacher)
-#else
-import System.Log.FastLogger.Date (getDate, dateInit, ZonedDate)
-#endif
+import Network.Wai.Middleware.RequestLogger.Internal
 
 data OutputFormat = Apache IPAddrSource
                   | Detailed Bool -- ^ use colors?
@@ -97,13 +95,7 @@ mkRequestLogger RequestLoggerSettings{..} = do
     dateHelper mgetdate = do
         case mgetdate of
             Just x -> return x
-#if MIN_VERSION_fast_logger(0, 3, 0)
-            Nothing -> do
-                (getter,_) <- ondemandDateCacher zonedDateCacheConf
-                return getter
-#else
-            Nothing -> fmap getDate dateInit
-#endif
+            Nothing -> getDateGetter
 
 apacheMiddleware :: Callback -> IPAddrSource -> IO ZonedDate -> Middleware
 apacheMiddleware cb ipsrc getdate = customMiddleware cb getdate $ apacheFormat ipsrc

wai-extra/Network/Wai/Middleware/RequestLogger/Internal.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE CPP #-}
+-- | A module for containing some CPPed code, due to:
+--
+-- https://github.com/yesodweb/wai/issues/192
+module Network.Wai.Middleware.RequestLogger.Internal where
+
+import Data.ByteString (ByteString)
+import System.Log.FastLogger
+#if MIN_VERSION_fast_logger(0,3,0)
+import System.Date.Cache (ondemandDateCacher)
+#else
+import System.Log.FastLogger.Date (getDate, dateInit, ZonedDate)
+#endif
+
+getDateGetter :: IO (IO ByteString)
+#if MIN_VERSION_fast_logger(0, 3, 0)
+getDateGetter = fmap fst $ ondemandDateCacher zonedDateCacheConf
+#else
+getDateGetter = fmap getDate dateInit
+#endif

wai-extra/wai-extra.cabal

@@ -61,6 +61,7 @@ Library
                      Network.Wai.Middleware.Vhost
                      Network.Wai.Middleware.HttpAuth
                      Network.Wai.Parse
+  other-modules:     Network.Wai.Middleware.RequestLogger.Internal
   ghc-options:       -Wall
 
 

wai-handler-launch/wai-handler-launch.cabal

@@ -28,7 +28,7 @@ Library
         cpp-options: -DWINDOWS
         extra-libraries: Shell32
     else
-        build-depends: process >= 1.0 && < 1.2
+        build-depends: process >= 1.0 && < 1.3
         if os(darwin)
             cpp-options: -DMAC
 

wai-websockets/Network/Wai/Handler/WebSockets.hs

@@ -4,71 +4,96 @@ module Network.Wai.Handler.WebSockets
     , interceptWith
     ) where
 
-import Control.Monad.IO.Class (liftIO)
-import Data.ByteString (ByteString)
-import Data.Char (toLower)
-import qualified Data.ByteString.Char8 as S
-import Data.Conduit
-import qualified Data.Enumerator as E
-import qualified Network.Wai as Wai
-import qualified Network.Wai.Handler.Warp as Warp
-import qualified Network.WebSockets as WS
+import              Control.Monad                   (forever)
+import              Control.Monad.IO.Class          (liftIO)
+import              Control.Concurrent              (forkIO, threadDelay)
+import              Control.Exception               (SomeException (..), handle)
+import              Blaze.ByteString.Builder        (Builder)
+import qualified    Blaze.ByteString.Builder        as Builder
+import              Data.ByteString                 (ByteString)
+import qualified    Data.ByteString.Char8           as BC
+import              Data.Char                       (toLower)
+import              Data.Conduit
+import qualified    Network.Wai                     as Wai
+import qualified    Network.Wai.Handler.Warp        as Warp
+import qualified    Network.WebSockets              as WS
+import qualified    Network.WebSockets.Connection   as WS
+import              System.IO.Streams               (InputStream, OutputStream)
+import qualified    System.IO.Streams               as Streams
 
+--------------------------------------------------------------------------------
 -- | For use with 'settingsIntercept' from the Warp web server.
-intercept :: WS.Protocol p
-          => (WS.Request -> WS.WebSockets p ())
+intercept :: WS.ServerApp
           -> Wai.Request
           -> Maybe (Source IO ByteString -> Warp.Connection -> IO ())
-intercept = interceptWith WS.defaultWebSocketsOptions
+intercept = interceptWith WS.defaultConnectionOptions
 
+--------------------------------------------------------------------------------
 -- | Variation of 'intercept' which allows custom options.
-interceptWith :: WS.Protocol p
-              => WS.WebSocketsOptions
-              -> (WS.Request -> WS.WebSockets p ())
+interceptWith :: WS.ConnectionOptions
+              -> WS.ServerApp
               -> Wai.Request
               -> Maybe (Source IO ByteString -> Warp.Connection -> IO ())
-interceptWith opts app req = case lookup "upgrade" $ Wai.requestHeaders req of
+interceptWith opts app req = case lookup "upgrade" (Wai.requestHeaders req) of
     Just s
-        | S.map toLower s == "websocket" -> Just $ runWebSockets opts req' app
+        | BC.map toLower s == "websocket" -> Just $ runWebSockets opts req' app
         | otherwise                      -> Nothing
     _                                    -> Nothing
-  where
-    req' = WS.RequestHttpPart (Wai.rawPathInfo req) (Wai.requestHeaders req)
-        (Wai.isSecure req)
+    where
+        req' = WS.RequestHead (Wai.rawPathInfo req) (Wai.requestHeaders req) (Wai.isSecure req)
 
--- | Internal function to run the WebSocket iteratee using the conduit library
-runWebSockets :: WS.Protocol p
-              => WS.WebSocketsOptions
-              -> WS.RequestHttpPart
-              -> (WS.Request -> WS.WebSockets p ())
+--------------------------------------------------------------------------------
+---- | Internal function to run the WebSocket io-streams using the conduit library
+runWebSockets :: WS.ConnectionOptions
+              -> WS.RequestHead
+              -> WS.ServerApp
               -> Source IO ByteString
               -> Warp.Connection
               -> IO ()
-runWebSockets opts req app source conn = do
-    step <- liftIO $ E.runIteratee $ WS.runWebSocketsWith opts req app send
-    source $$ sink (E.returnI step)
-  where
-    send  = iterConnection conn
+runWebSockets opts req app _ conn = do
 
-    sink iter = await >>= maybe (close iter) (push iter)
+    (is, os) <- liftIO $ connectionToStreams conn
 
-    push iter bs = do
-        step <- liftIO $ E.runIteratee $ E.enumList 1 [bs] E.$$ iter
-        case step of
-            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 ()
+    let pc = WS.PendingConnection 
+                { WS.pendingOptions     = opts
+                , WS.pendingRequest     = req
+                , WS.pendingOnAccept    = forkPingThread
+                , WS.pendingIn          = is
+                , WS.pendingOut         = os
+                }
 
-iterConnection :: Warp.Connection -> E.Iteratee ByteString IO ()
-iterConnection c = E.continue go
-  where
-    go (E.Chunks []) = E.continue go
-    go (E.Chunks cs) = E.tryIO (Warp.connSendMany c cs) >> E.continue go
-    go E.EOF         = E.continue go
+    liftIO $ app pc
 
-streamToMaybe :: E.Stream S.ByteString -> Maybe S.ByteString
-streamToMaybe E.EOF         = Nothing
-streamToMaybe (E.Chunks bs) = Just $ S.concat bs
+--------------------------------------------------------------------------------
+-- | Start a ping thread in the background
+forkPingThread :: WS.Connection -> IO ()
+forkPingThread conn = do
+    _ <- forkIO pingThread
+    return ()
+    where
+        pingThread = handle ignore $ forever $ do
+            WS.sendPing conn (BC.pack "ping")
+            threadDelay $ 30 * 1000 * 1000
+
+        ignore :: SomeException -> IO ()
+        ignore _   = return ()
+
+------------------------------------------------------------------------------
+-- | Converts a 'Connection' to an 'InputStream' \/ 'OutputStream' pair. Note that,
+-- as is usually the case in @io-streams@, writing a 'Nothing' to the generated
+-- 'OutputStream' does not cause the underlying 'Connection' to be closed.
+connectionToStreams :: Warp.Connection
+                -> IO (InputStream ByteString, OutputStream Builder)
+connectionToStreams connection = do
+    is <- Streams.makeInputStream input
+    os <- Streams.makeOutputStream output
+    return $! (is, os)
+
+    where
+        input = do
+            s <- Warp.connRecv connection
+            return $! if BC.null s then Nothing else Just s
+
+        output Nothing  = return $! ()
+        output (Just s') = if BC.null s then return $! () else Warp.connSendAll connection s
+            where s = Builder.toByteString s'

wai-websockets/server.lhs

@@ -11,8 +11,8 @@ nearby to check out the functions we use.
 > import Data.Char (isPunctuation, isSpace)
 > import Data.Monoid (mappend)
 > import Data.Text (Text)
-> import Control.Exception (fromException)
-> import Control.Monad (forM_)
+> import Control.Exception (fromException, handle)
+> import Control.Monad (forM_, forever)
 > import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar)
 > import Control.Monad.IO.Class (liftIO)
 > import qualified Data.Text as T
@@ -25,14 +25,9 @@ nearby to check out the functions we use.
 > import qualified Network.Wai.Application.Static as Static
 > import Data.FileEmbed (embedDir)
 
-We represent a client by his username and a 'WS.Sender'. We can use this sender
-to asynchronously send 'Text' to the client later. Note that using `WS.Hybi00`
-here does not imply that our server is only compatible with the `hybi-00`
-version of the protocol, for more details on this, see the
-[Network.WebSockets](http://jaspervdj.be/websockets/reference/Network-WebSockets.html) 
-reference.
+We represent a client by his username and a 'WS.Connection'. We will see how we obtain this 'WS.Connection' later on.
 
-> type Client = (Text, WS.Sink WS.Hybi00)
+> type Client = (Text, WS.Connection)
 
 The state kept on the server is simply a list of connected clients. We've added
 an alias and some utility functions, so it will be easier to extend this state
@@ -71,7 +66,7 @@ Send a message to all clients, and log it on stdout.
 > broadcast :: Text -> ServerState -> IO ()
 > broadcast message clients = do
 >     T.putStrLn message
->     forM_ clients $ \(_, sink) -> WS.sendSink sink $ WS.textData message
+>     forM_ clients $ \(_, conn) -> WS.sendTextData conn message
 
 The main function first creates a new state for the server, then spawns the
 actual server. For this purpose, we use the simple server provided by
@@ -91,44 +86,34 @@ actual server. For this purpose, we use the simple server provided by
 
 When a client connects, we accept the connection, regardless of the path.
 
-> application :: MVar ServerState -> WS.Request -> WS.WebSockets WS.Hybi00 ()
-> application state rq = do
->     WS.acceptRequest rq
-
-We log some information here: in particular, we are interested in the protocol
-version our client is using (for debugging purposes).
-
->     WS.getVersion >>= liftIO . putStrLn . ("Client version: " ++)
-
-If we want to be able to send data to this client later, from another thread, we
-obtain a sink. We will add this to the server state later.
-
->     sink <- WS.getSink
+> application :: MVar ServerState -> WS.ServerApp
+> application state pending = do
+>     conn <- WS.acceptRequest pending
 
 When a client is succesfully connected, we read the first message. This should
 be in the format of "Hi, I am Jasper", where Jasper is the requested username.
 
->     msg <- WS.receiveData
+>     msg <- WS.receiveData conn
 >     clients <- liftIO $ readMVar state
 >     case msg of
 
 Check that the first message has the right format
 
 >         _   | not (prefix `T.isPrefixOf` msg) ->
->                 WS.sendTextData ("Wrong announcement" :: Text)
+>                 WS.sendTextData conn ("Wrong announcement" :: Text)
 
 Check the validity of the username
 
 >             | any ($ fst client)
 >                 [T.null, T.any isPunctuation, T.any isSpace] ->
->                     WS.sendTextData ("Name cannot " `mappend`
+>                     WS.sendTextData conn ("Name cannot " `mappend`
 >                         "contain punctuation or whitespace, and " `mappend`
 >                         "cannot be empty" :: Text)
 
 Check that the given username is not already taken
 
 >             | clientExists client clients ->
->                 WS.sendTextData ("User already exists" :: Text)
+>                 WS.sendTextData conn ("User already exists" :: Text)
 
 All is right!
 
@@ -140,25 +125,25 @@ the list and broadcast the fact that he has joined. Then, we give control to the
 
 >                liftIO $ modifyMVar_ state $ \s -> do
 >                    let s' = addClient client s
->                    WS.sendSink sink $ WS.textData $
+>                    WS.sendTextData conn $
 >                        "Welcome! Users: " `mappend`
 >                        T.intercalate ", " (map fst s)
 >                    broadcast (fst client `mappend` " joined") s'
 >                    return s'
->                talk state client
+>                talk conn state client
 >           where
 >             prefix = "Hi! I am "
->             client = (T.drop (T.length prefix) msg, sink)
+>             client = (T.drop (T.length prefix) msg, conn)
 
 The talk function continues to read messages from a single client until he
 disconnects. All messages are broadcasted to the other clients.
 
-> talk :: WS.Protocol p => MVar ServerState -> Client -> WS.WebSockets p ()
-> talk state client@(user, _) = flip WS.catchWsError catchDisconnect $ do
->     msg <- WS.receiveData
->     liftIO $ readMVar state >>= broadcast
->         (user `mappend` ": " `mappend` msg)
->     talk state client
+> talk :: WS.Connection -> MVar ServerState -> Client -> IO ()
+> talk conn state client@(user, _) = handle catchDisconnect $
+>     forever $ do 
+>         msg <- WS.receiveData conn
+>         liftIO $ readMVar state >>= broadcast
+>             (user `mappend` ": " `mappend` msg)
 >   where
 >     catchDisconnect e = case fromException e of
 >         Just WS.ConnectionClosed -> liftIO $ modifyMVar_ state $ \s -> do

wai-websockets/wai-websockets.cabal

@@ -3,7 +3,7 @@ Version:             2.0.0
 Synopsis:            Provide a bridge betweeen WAI and the websockets package.
 License:             MIT
 License-file:        LICENSE
-Author:              Michael Snoyman, Jasper Van der Jeugt
+Author:              Michael Snoyman, Jasper Van der Jeugt, Ting-Yen Lai
 Maintainer:          michael@snoyman.com
 Homepage:            http://github.com/yesodweb/wai
 Category:            Web, Yesod
@@ -21,14 +21,13 @@ Library
                    , bytestring         >= 0.9.1.4
                    , conduit            >= 0.5      && < 1.1
                    , wai                >= 2.0      && < 2.1
-                   , 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
                    , transformers       >= 0.2      && < 0.4
-                   , websockets         >= 0.6      && < 0.8
+                   , websockets         >= 0.8
                    , warp               >= 2.0      && < 2.1
+                   , io-streams         >= 1.1      && < 1.2
   Exposed-modules:   Network.Wai.Handler.WebSockets
   ghc-options:       -Wall
 
@@ -41,18 +40,17 @@ Executable           wai-websockets-example
                    , conduit
                    , wai-websockets
                    , websockets
-                   , network-enumerator
                    , warp
                    , wai
                    , wai-app-static
                    , bytestring
                    , case-insensitive
                    , blaze-builder
-                   , enumerator
                    , transformers
                    , network
                    , text
                    , file-embed
+                   , io-streams
 
   ghc-options:       -Wall -threaded
   main-is:           server.lhs