diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,8 @@ +- 0.10.0.0 + * Bump snap-core and snap-server to 1.0.0.0 + * Remove git submodules; use hackage for all dependencies + * Use cabal.project file to build example server + - 0.9.2.0 * Bump websockets to 0.9.5.0 to fix socket closing issues diff --git a/src/Network/WebSockets/Snap.hs b/src/Network/WebSockets/Snap.hs --- a/src/Network/WebSockets/Snap.hs +++ b/src/Network/WebSockets/Snap.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -------------------------------------------------------------------------------- -- | Snap integration for the WebSockets library {-# LANGUAGE DeriveDataTypeable #-} @@ -9,26 +11,21 @@ -------------------------------------------------------------------------------- import Control.Concurrent (forkIO, myThreadId, threadDelay) -import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, - takeMVar) import Control.Exception (Exception (..), - SomeException (..), finally, - handle, throwIO, throwTo) + SomeException (..), + handle, throwTo) import Control.Monad (forever) -import Control.Monad.Trans (lift) import Data.ByteString (ByteString) +import qualified Data.ByteString.Builder as BSBuilder +import qualified Data.ByteString.Builder.Extra as BSBuilder import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.Enumerator as E -import qualified Data.Enumerator.List as EL -import Data.IORef (newIORef, readIORef, writeIORef) import Data.Typeable (Typeable, cast) import qualified Network.WebSockets as WS import qualified Network.WebSockets.Connection as WS import qualified Network.WebSockets.Stream as WS import qualified Snap.Core as Snap -import qualified Snap.Internal.Http.Types as Snap import qualified Snap.Types.Headers as Headers +import qualified System.IO.Streams as Streams -------------------------------------------------------------------------------- @@ -51,61 +48,6 @@ -------------------------------------------------------------------------------- -copyIterateeToMVar - :: ((Int -> Int) -> IO ()) - -> MVar Chunk - -> E.Iteratee ByteString IO () -copyIterateeToMVar tickle mvar = E.catchError go handler - where - go = do - mbs <- EL.head - case mbs of - Just x -> do - lift (tickle (max 60)) - lift (putMVar mvar (Chunk x)) - go - Nothing -> lift (putMVar mvar Eof) - - handler se@(SomeException e) = case cast e of - -- Clean exit - Just ServerAppDone -> return () - -- Actual error - Nothing -> lift $ putMVar mvar $ Error se - - --------------------------------------------------------------------------------- -copyMVarToStream :: MVar Chunk -> IO (IO (Maybe ByteString)) -copyMVarToStream mvar = return go - where - go = do - chunk <- takeMVar mvar - case chunk of - Chunk x -> return (Just x) - Eof -> return Nothing - Error (SomeException e) -> throwIO e - - --------------------------------------------------------------------------------- -copyStreamToIteratee - :: E.Iteratee ByteString IO () - -> IO (Maybe BL.ByteString -> IO ()) -copyStreamToIteratee iteratee0 = do - ref <- newIORef =<< E.runIteratee iteratee0 - return (go ref) - where - go _ Nothing = return () - go ref (Just bl) = do - step <- readIORef ref - case step of - E.Continue f -> do - let chunks = BL.toChunks bl - step' <- E.runIteratee $ f $ E.Chunks chunks - writeIORef ref step' - E.Yield () _ -> throwIO WS.ConnectionClosed - E.Error (SomeException e) -> throwIO e - - --------------------------------------------------------------------------------- -- | The following function escapes from the current 'Snap.Snap' handler, and -- continues processing the 'WS.WebSockets' action. The action to be executed -- takes the 'WS.Request' as a parameter, because snap has already read this @@ -120,37 +62,34 @@ -------------------------------------------------------------------------------- -- | Variant of 'runWebSocketsSnap' which allows custom options runWebSocketsSnapWith - :: Snap.MonadSnap m - => WS.ConnectionOptions - -> WS.ServerApp - -> m () + :: Snap.MonadSnap m + => WS.ConnectionOptions + -> WS.ServerApp + -> m () runWebSocketsSnapWith options app = do - rq <- Snap.getRequest - Snap.escapeHttp $ \tickle writeEnd -> do - - thisThread <- lift myThreadId - mvar <- lift newEmptyMVar - parse <- lift $ copyMVarToStream mvar - write <- lift $ copyStreamToIteratee writeEnd - stream <- lift $ WS.makeStream parse write + rq <- Snap.getRequest + Snap.escapeHttp $ \tickle readEnd writeEnd -> do - let options' = options - { WS.connectionOnPong = do - tickle (max 60) - WS.connectionOnPong options - } + thisThread <- myThreadId + stream <- WS.makeStream (tickle (max 20) >> Streams.read readEnd) + (\v -> do + Streams.write (fmap BSBuilder.lazyByteString v) writeEnd + Streams.write (Just BSBuilder.flush) writeEnd + ) - pc = WS.PendingConnection - { WS.pendingOptions = options' - , WS.pendingRequest = fromSnapRequest rq - , WS.pendingOnAccept = forkPingThread tickle - , WS.pendingStream = stream - } + let options' = options + { WS.connectionOnPong = do + tickle (max 30) + WS.connectionOnPong options + } - _ <- lift $ forkIO $ finally (app pc) $ do - WS.close stream - throwTo thisThread ServerAppDone - copyIterateeToMVar tickle mvar + pc = WS.PendingConnection + { WS.pendingOptions = options' + , WS.pendingRequest = fromSnapRequest rq + , WS.pendingOnAccept = forkPingThread tickle + , WS.pendingStream = stream + } + app pc >> throwTo thisThread ServerAppDone -------------------------------------------------------------------------------- diff --git a/websockets-snap.cabal b/websockets-snap.cabal --- a/websockets-snap.cabal +++ b/websockets-snap.cabal @@ -1,5 +1,5 @@ Name: websockets-snap -Version: 0.9.2.0 +Version: 0.10.0.0 Synopsis: Snap integration for the websockets library Description: Snap integration for the websockets library License: BSD3 @@ -23,10 +23,10 @@ Build-depends: base >= 4 && < 5, bytestring >= 0.9 && < 0.11, - enumerator >= 0.4 && < 0.5, + io-streams >= 1.3 && < 1.4, mtl >= 2.1 && < 2.3, - snap-core >= 0.8 && < 0.10, - snap-server >= 0.8 && < 0.10, + snap-core >= 1.0 && < 1.1, + snap-server >= 1.0 && < 1.1, websockets >= 0.9.5 && < 0.10 Source-repository head