websockets 0.7.4.1 → 0.8.0.0

raw patch · 25 files changed

+1210/−1638 lines, 25 filesdep +io-streamsdep −attoparsec-enumeratordep −blaze-builder-enumeratordep −enumerator

Dependencies added: io-streams

Dependencies removed: attoparsec-enumerator, blaze-builder-enumerator, enumerator, network-enumerator, pureMD5

Files

src/Network/WebSockets.hs +46/−211
src/Network/WebSockets/Client.hs +86/−69
src/Network/WebSockets/Connection.hs +190/−0
src/Network/WebSockets/Handshake.hs +0/−37
src/Network/WebSockets/Handshake/Http.hs +0/−211
src/Network/WebSockets/Http.hs +243/−0
src/Network/WebSockets/Hybi13.hs +239/−0
src/Network/WebSockets/Hybi13/Demultiplex.hs +105/−0
src/Network/WebSockets/Hybi13/Mask.hs +46/−0
src/Network/WebSockets/Internal.hs +0/−8
src/Network/WebSockets/Monad.hs +0/−263
src/Network/WebSockets/Protocol.hs +63/−78
src/Network/WebSockets/Protocol/Hybi00.hs +0/−28
src/Network/WebSockets/Protocol/Hybi00/Internal.hs +0/−100
src/Network/WebSockets/Protocol/Hybi10.hs +0/−27
src/Network/WebSockets/Protocol/Hybi10/Demultiplex.hs +0/−77
src/Network/WebSockets/Protocol/Hybi10/Internal.hs +0/−215
src/Network/WebSockets/Protocol/Hybi10/Mask.hs +0/−36
src/Network/WebSockets/Protocol/Unsafe.hs +0/−35
src/Network/WebSockets/Server.hs +81/−0
src/Network/WebSockets/Socket.hs +0/−76
src/Network/WebSockets/Types.hs +56/−25
src/Network/WebSockets/Util/PubSub.hs +0/−79
tests/haskell/TestSuite.hs +13/−8
websockets.cabal +42/−55

src/Network/WebSockets.hs view

@@ -1,229 +1,64 @@--- | How do you use this library? Here's how:------ Get an enumerator/iteratee pair from your favorite web server (or use a--- library which provides integration). Alternatively, use 'I.runServer' to--- set up a simple standalone server.------ An application typically has the form of @I.Request -> I.WebSockets p ()@.--- The first thing to do is accept or reject the request, usually based upon--- the path in the 'I.Request'. An example:------ > {-# LANGUAGE OverloadedStrings #-}--- > import Network.WebSockets--- >--- > app :: Protocol p => Request -> WebSockets p ()--- > app rq = case requestPath rq of--- >    "/forbidden" -> rejectRequest rq "Forbidden!"--- >    _            -> do--- >        acceptRequest rq--- >        ... actual application ...------ You can now start using the socket for sending and receiving data. But what's--- with the @p@ in @WebSockets p ()@?------ Well, the answer is that this library aims to support many versions of the--- WebSockets protocol. Unfortunately, not all versions of the protocol have the--- same capabilities: for example, older versions are not able to send binary--- data.------ The library user (you!) choose which capabilities you need. Then, the browser--- and library will negotiate at runtime which version will be actually used.------ As an example, here are two applications which need different capabilities:------ > import Network.WebSockets--- > import qualified Data.ByteString as B--- > import qualified Data.Text as T--- > --- > app1 :: TextProtocol p => WebSockets p ()--- > app1 = sendTextData (T.pack "Hello world!")--- > --- > app2 :: BinaryProtocol p => WebSockets p ()--- > app2 = sendBinaryData (B.pack [0 .. 100])------ When you /tie the knot/, you will need to decide what protocol to use, to--- prevent ambiguousness. A good rule of thumb is to select the lowest protocol--- possible, since higher versions are generally backwards compatible in terms--- of features. . For example, the following application uses only--- /features from Hybi00/, and is therefore /compatible with Hybi10/ and later--- protocols.--- --- > app :: Request -> WebSockets Hybi00 ()--- > app _ = app1--- > --- > main :: IO ()--- > main = runServer "0.0.0.0" 8000 app--- --- In some cases, you want to escape from the 'I.WebSockets' monad and send data--- to the websocket from different threads. To this end, the 'I.getSink' method--- is provided. The next example spawns a thread which continuously spams the--- client in another thread:------ > import Control.Concurrent (forkIO)--- > import Control.Monad (forever)--- > import Control.Monad.Trans (liftIO)--- > import Network.WebSockets--- > import qualified Data.Text as T--- > --- > spam :: TextProtocol p => WebSockets p ()--- > spam = do--- >     sink <- getSink--- >     _ <- liftIO $ forkIO $ forever $--- >         sendSink sink $ textData (T.pack "SPAM SPAM SPAM!")--- >     sendTextData (T.pack "Hello world!")------ For safety reasons, you can only read from the socket in the 'I.WebSockets'--- monad.------ For a full example, see:------ <http://jaspervdj.be/websockets/example.html>+-------------------------------------------------------------------------------- {-# LANGUAGE ScopedTypeVariables #-} module Network.WebSockets-    ( -      -- * WebSocket type-      I.WebSocketsOptions (..)-    , I.defaultWebSocketsOptions-    , I.WebSockets-    , I.runWebSockets-    , I.runWebSocketsWith-    , I.runWebSocketsHandshake-    , I.runWebSocketsWithHandshake--      -- * Protocol versions-    , I.Protocol-    , I.TextProtocol-    , I.BinaryProtocol-    , I.Hybi00-    , I.Hybi10--      -- * A simple standalone server-    , I.runServer-    , I.runWithSocket--      -- * HTTP Types-    , I.Headers-    , I.Request (..)-    , I.RequestHttpPart (..)-    , I.RequestBody (..)-    , I.ResponseHttpPart (..)-    , I.ResponseBody (..)--      -- * WebSockets types-    , I.Message (..)-    , I.ControlMessage (..)-    , I.DataMessage (..)-    , I.WebSocketsData (..)--      -- * Handshake+    ( -- * Incoming connections and handshaking+      PendingConnection+    , pendingRequest     , acceptRequest     , rejectRequest -      -- * Various-    , I.getVersion+      -- * Main connection type+    , Connection -      -- * Receiving-    , I.receive+      -- * Options for connections+    , ConnectionOptions (..)+    , defaultConnectionOptions++      -- * Sending and receiving messages+    , receive     , receiveDataMessage     , receiveData--      -- * Sending-    , I.send+    , send+    , sendDataMessage     , sendTextData     , sendBinaryData+    , sendClose+    , sendPing -      -- * Asynchronous sending-    , I.Sink-    , I.sendSink-    , I.getSink-    , I.close-    , I.ping-    , I.pong-    , I.textData-    , I.binaryData-    , I.spawnPingThread+      -- * HTTP Types+    , Headers+    , Request (..)+    , RequestHead (..)+    , Response (..)+    , ResponseHead (..) -      -- * Error Handling-    , I.throwWsError-    , I.catchWsError-    , I.HandshakeError(..)-    , I.ConnectionError(..)+      -- * WebSocket message types+    , Message (..)+    , ControlMessage (..)+    , DataMessage (..)+    , WebSocketsData (..) -      -- * WebSockets Client-    , I.connect-    , I.connectWith-    ) where+      -- * Exceptions+    , HandshakeException (..)+    , ConnectionException (..) -import Control.Monad.Trans (liftIO) -import qualified Network.WebSockets.Client as I-import qualified Network.WebSockets.Handshake as I-import qualified Network.WebSockets.Handshake.Http as I-import qualified Network.WebSockets.Monad as I-import qualified Network.WebSockets.Protocol as I-import qualified Network.WebSockets.Protocol.Hybi00 as I-import qualified Network.WebSockets.Protocol.Hybi10 as I-import qualified Network.WebSockets.Protocol.Unsafe as Unsafe-import qualified Network.WebSockets.Socket as I-import qualified Network.WebSockets.Types as I+      -- * Running a standalone server+    , ServerApp+    , runServer --- This doesn't work this way any more. As the Protocol first has to be--- determined by the request, we can't provide this as a WebSockets action. See--- the various flavours of runWebSockets.+      -- * Running a client+    , ClientApp+    , runClient+    , runClientWith+    , runClientWithSocket+    , runClientWithStream+    ) where --- | Receive an application message. Automatically respond to control messages.-receiveDataMessage :: I.Protocol p => I.WebSockets p (I.DataMessage p)-receiveDataMessage = do-    m <- I.receive-    case m of-        (I.DataMessage am) -> return am-        (I.ControlMessage cm) -> case cm of-            I.Close _ -> I.throwWsError I.ConnectionClosed-            I.Pong _  -> do-                options <- I.getOptions-                liftIO $ I.onPong options-                receiveDataMessage-            I.Ping pl -> do-                -- Note that we are using an /unsafe/ pong here. If the -                -- underlying protocol cannot encode this pong, our thread will-                -- crash. We assume, however that the protocol /is/ able to-                -- encode the pong, since it was able to encode a ping.-                I.send $ Unsafe.pong pl-                receiveDataMessage --- | Receive a message, treating it as data transparently-receiveData :: (I.Protocol p, I.WebSocketsData a) => I.WebSockets p a-receiveData = do-    dm <- receiveDataMessage-    case dm of-        I.Text x   -> return (I.fromLazyByteString x)-        I.Binary x -> return (I.fromLazyByteString x)---- | Send a 'I.Response' to the socket immediately.-sendResponse :: I.Protocol p => I.ResponseBody -> I.WebSockets p ()-sendResponse = I.sendBuilder . I.encodeResponseBody---- | Send a text message-sendTextData :: (I.TextProtocol p, I.WebSocketsData a) => a -> I.WebSockets p ()-sendTextData = I.send . I.textData---- | Send some binary data-sendBinaryData :: (I.BinaryProtocol p, I.WebSocketsData a)-               => a -> I.WebSockets p ()-sendBinaryData = I.send . I.binaryData---- | Reject a request, sending a 400 (Bad Request) to the client and throwing a--- RequestRejected (HandshakeError)-rejectRequest :: I.Protocol p-              => I.Request -> String -> I.WebSockets p a-rejectRequest req reason = failHandshakeWith $ I.RequestRejected req reason--failHandshakeWith :: forall p a. I.Protocol p-                  => I.HandshakeError -> I.WebSockets p a-failHandshakeWith err = do-    sendResponse $ I.responseError (undefined :: p) err-    I.throwWsError err---- | Accept a request. After this, you can start sending and receiving data.-acceptRequest :: I.Protocol p => I.Request -> I.WebSockets p ()-acceptRequest = sendResponse . I.requestResponse+--------------------------------------------------------------------------------+import           Network.WebSockets.Client+import           Network.WebSockets.Connection+import           Network.WebSockets.Http+import           Network.WebSockets.Server+import           Network.WebSockets.Types

src/Network/WebSockets/Client.hs view

@@ -2,54 +2,58 @@ -- | This part of the library provides you with utilities to create WebSockets -- clients (in addition to servers). module Network.WebSockets.Client-    ( connect-    , connectWith-    , connectWithSocket+    ( ClientApp+    , runClient+    , runClientWith+    , runClientWithSocket+    , runClientWithStream     ) where   ---------------------------------------------------------------------------------import           Control.Applicative               ((<$>))-import           Control.Monad.Trans               (liftIO)-import           Data.ByteString                   (ByteString)-import qualified Data.ByteString.Char8             as BC-import           Data.Enumerator                   (Iteratee, ($$))-import qualified Data.Enumerator                   as E-import qualified Data.Text                         as T-import qualified Data.Text.Encoding                as T-import qualified Network.Socket                    as S-import qualified Network.Socket.Enumerator         as SE+import qualified Blaze.ByteString.Builder      as Builder+import           Control.Exception             (finally)+import qualified Data.ByteString               as B+import qualified Data.Text                     as T+import qualified Data.Text.Encoding            as T+import qualified Network.Socket                as S+import qualified System.IO.Streams             as Streams+import qualified System.IO.Streams.Attoparsec  as Streams   ---------------------------------------------------------------------------------import           Network.WebSockets.Handshake.Http-import           Network.WebSockets.Monad+import           Network.WebSockets.Connection+import           Network.WebSockets.Http import           Network.WebSockets.Protocol-import           Network.WebSockets.Socket         (iterSocket)+import           Network.WebSockets.Types   ---------------------------------------------------------------------------------connect :: Protocol p-        => String          -- ^ Host-        -> Int             -- ^ Port-        -> String          -- ^ Path-        -> WebSockets p a  -- ^ Client application-        -> IO a-connect host port path ws =-    connectWith host port path Nothing Nothing ws+-- | A client application interacting with a single server. Once this 'IO'+-- action finished, the underlying socket is closed automatically.+type ClientApp a = Connection -> IO a   ---------------------------------------------------------------------------------connectWith :: Protocol p-            => String          -- ^ Host-            -> Int             -- ^ Port-            -> String          -- ^ Path-            -> Maybe String    -- ^ Origin, if Nothing then server interprets-                               --   connection as not coming from a browser.-            -> Maybe [String]  -- ^ Protocol List-            -> WebSockets p a  -- ^ Client application-            -> IO a-connectWith host port path origin wsProtocols app = do+-- TODO: Maybe this should all be strings+runClient :: String       -- ^ Host+          -> Int          -- ^ Port+          -> String       -- ^ Path+          -> ClientApp a  -- ^ Client application+          -> IO a+runClient host port path ws =+    runClientWith host port path defaultConnectionOptions [] ws+++--------------------------------------------------------------------------------+runClientWith :: String             -- ^ Host+              -> Int                -- ^ Port+              -> String             -- ^ Path+              -> ConnectionOptions  -- ^ Options+              -> Headers            -- ^ Custom headers to send+              -> ClientApp a        -- ^ Client application+              -> IO a+runClientWith host port path opts customHeaders app = do     -- Create and connect socket     let hints = S.defaultHints                     {S.addrFamily = S.AF_INET, S.addrSocketType = S.Stream}@@ -58,48 +62,61 @@     S.connect sock (S.addrAddress $ head addrInfos)      -- Connect WebSocket and run client-    res <- connectWithSocket sock host path origin wsProtocols app+    res <- finally+        (runClientWithSocket sock host path opts customHeaders app)+        (S.sClose sock)      -- Clean up-    S.sClose sock     return res   ---------------------------------------------------------------------------------connectWithSocket :: Protocol p-                  => S.Socket        -- ^ Socket-                  -> String          -- ^ Host-                  -> String          -- ^ Path-                  -> Maybe String    -- ^ Origin, if Nothing then server-                                     --   interprets connection as not coming-                                     --   from a browser.-                  -> Maybe [String]  -- ^ Protocol List-                  -> WebSockets p a  -- ^ Client application-                  -> IO a-connectWithSocket sock host path origin wsProtocols app = do-    -- Create the request-    request <- createRequest protocol bHost bPath bOrigin bWsProtocols False--    -- Connect to server-    E.run_ $ SE.enumSocket 4096 sock $$ (iter request) $ iterSocket sock+runClientWithStream+    :: (Streams.InputStream B.ByteString, Streams.OutputStream B.ByteString)+    -- ^ Stream+    -> String+    -- ^ Host+    -> String+    -- ^ Path+    -> ConnectionOptions+    -- ^ Connection options+    -> Headers+    -- ^ Custom headers to send+    -> ClientApp a+    -- ^ Client application+    -> IO a+runClientWithStream (sIn, sOut) host path opts customHeaders app = do+    -- Create the request and send it+    request     <- createRequest protocol bHost bPath False customHeaders+    bOut        <- Streams.builderStream sOut+    Streams.write (Just $ encodeRequestHead request) bOut+    Streams.write (Just Builder.flush)               bOut+    response     <- Streams.parseFromStream decodeResponseHead sIn+    -- Note that we pattern match to evaluate the result here+    Response _ _ <- return $ finishResponse protocol request response+    mIn          <- decodeMessages protocol sIn+    mOut         <- encodeMessages protocol ClientConnection bOut+    app Connection+        { connectionOptions  = opts+        , connectionType     = ClientConnection+        , connectionProtocol = protocol+        , connectionIn       = mIn+        , connectionOut      = mOut+        }   where-    protocol      = head implementations-    iter request  = runWebSocketsClient protocol request app-    bHost         = T.encodeUtf8 $ T.pack host-    bPath         = T.encodeUtf8 $ T.pack path-    bOrigin       = T.encodeUtf8 . T.pack <$> origin-    bWsProtocols  = map BC.pack <$> wsProtocols+    protocol = defaultProtocol  -- TODO+    bHost    = T.encodeUtf8 $ T.pack host+    bPath    = T.encodeUtf8 $ T.pack path   ---------------------------------------------------------------------------------runWebSocketsClient :: Protocol p-                    => p-                    -> RequestHttpPart-                    -> WebSockets p a-                    -> Iteratee ByteString IO ()-                    -> Iteratee ByteString IO a-runWebSocketsClient protocol request ws outIter = do-    liftIO $ makeBuilderSender outIter $ encodeRequestHttpPart request-    response <- receiveIteratee decodeResponse-    _        <- finishResponse protocol request response-    runWebSocketsWith' defaultWebSocketsOptions protocol True ws outIter+runClientWithSocket :: S.Socket           -- ^ Socket+                    -> String             -- ^ Host+                    -> String             -- ^ Path+                    -> ConnectionOptions  -- ^ Options+                    -> Headers            -- ^ Custom headers to send+                    -> ClientApp a        -- ^ Client application+                    -> IO a+runClientWithSocket sock host path opts customHeaders app = do+    stream <- Streams.socketToStreams sock+    runClientWithStream stream host path opts customHeaders app

+ src/Network/WebSockets/Connection.hs view

@@ -0,0 +1,190 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Connection+    ( PendingConnection (..)+    , acceptRequest+    , rejectRequest++    , Connection (..)++    , ConnectionOptions (..)+    , defaultConnectionOptions++    , receive+    , receiveDataMessage+    , receiveData+    , send+    , sendDataMessage+    , sendTextData+    , sendBinaryData+    , sendClose+    , sendPing+    ) where+++--------------------------------------------------------------------------------+import           Blaze.ByteString.Builder    (Builder)+import qualified Blaze.ByteString.Builder    as Builder+import           Control.Exception           (throw)+import qualified Data.ByteString             as B+import           Data.List                   (find)+import           System.IO.Streams           (InputStream, OutputStream)+import qualified System.IO.Streams           as Streams+++--------------------------------------------------------------------------------+import           Network.WebSockets.Http+import           Network.WebSockets.Protocol+import           Network.WebSockets.Types+++--------------------------------------------------------------------------------+-- | A new client connected to the server. We haven't accepted the connection+-- yet, though.+data PendingConnection = PendingConnection+    { pendingOptions  :: ConnectionOptions+    -- ^ Options, passed as-is to the 'Connection'+    , pendingRequest  :: RequestHead+    -- ^ Useful for e.g. inspecting the request path.+    , pendingOnAccept :: Connection -> IO ()+    -- ^ One-shot callback fired when a connection is accepted, i.e., *after*+    -- the accepting response is sent to the client.+    , pendingIn       :: InputStream B.ByteString+    -- ^ Input stream+    , pendingOut      :: OutputStream Builder+    -- ^ Output stream+    }+++--------------------------------------------------------------------------------+-- | Utility+sendResponse :: PendingConnection -> Response -> IO ()+sendResponse pc rsp = do+    Streams.write (Just (encodeResponse rsp)) (pendingOut pc)+    Streams.write (Just Builder.flush)        (pendingOut pc)+++--------------------------------------------------------------------------------+acceptRequest :: PendingConnection -> IO Connection+acceptRequest pc = case find (flip compatible request) protocols of+    Nothing       -> do+        sendResponse pc $ response400 versionHeader ""+        throw NotSupported+    Just protocol -> do+        let response = finishRequest protocol request+        sendResponse pc response+        msgIn  <- decodeMessages protocol (pendingIn pc)+        msgOut <- encodeMessages protocol ServerConnection (pendingOut pc)+        let connection = Connection+                { connectionOptions  = pendingOptions pc+                , connectionType     = ServerConnection+                , connectionProtocol = protocol+                , connectionIn       = msgIn+                , connectionOut      = msgOut+                }++        pendingOnAccept pc connection+        return connection+  where+    request       = pendingRequest pc+    versionHeader = [("Sec-WebSocket-Version",+        B.intercalate ", " $ concatMap headerVersions protocols)]+++--------------------------------------------------------------------------------+rejectRequest :: PendingConnection -> B.ByteString -> IO ()+rejectRequest pc message = sendResponse pc $ response400 [] message+++--------------------------------------------------------------------------------+data Connection = Connection+    { connectionOptions  :: ConnectionOptions+    , connectionType     :: ConnectionType+    , connectionProtocol :: Protocol+    , connectionIn       :: InputStream Message+    , connectionOut      :: OutputStream Message+    }+++--------------------------------------------------------------------------------+data ConnectionOptions = ConnectionOptions+    { connectionOnPong :: IO ()+    }+++--------------------------------------------------------------------------------+defaultConnectionOptions :: ConnectionOptions+defaultConnectionOptions = ConnectionOptions+    { connectionOnPong = return ()+    }+++--------------------------------------------------------------------------------+receive :: Connection -> IO Message+receive conn = do+    mmsg <- Streams.read (connectionIn conn)+    case mmsg of+        Nothing  -> throw ConnectionClosed+        Just msg -> return msg+++--------------------------------------------------------------------------------+-- | Receive an application message. Automatically respond to control messages.+receiveDataMessage :: Connection -> IO DataMessage+receiveDataMessage conn = do+    msg <- receive conn+    case msg of+        DataMessage am    -> return am+        ControlMessage cm -> case cm of+            Close _   -> throw ConnectionClosed+            Pong _    -> do+                connectionOnPong (connectionOptions conn)+                receiveDataMessage conn+            Ping pl   -> do+                send conn (ControlMessage (Pong pl))+                receiveDataMessage conn+++--------------------------------------------------------------------------------+-- | Receive a message, converting it to whatever format is needed.+receiveData :: WebSocketsData a => Connection -> IO a+receiveData conn = do+    dm <- receiveDataMessage conn+    case dm of+        Text x   -> return (fromLazyByteString x)+        Binary x -> return (fromLazyByteString x)+++--------------------------------------------------------------------------------+send :: Connection -> Message -> IO ()+send conn msg = Streams.write (Just msg) (connectionOut conn)+++--------------------------------------------------------------------------------+-- | Send a 'DataMessage'+sendDataMessage :: Connection -> DataMessage -> IO ()+sendDataMessage conn = send conn . DataMessage+++--------------------------------------------------------------------------------+-- | Send a message as text+sendTextData :: WebSocketsData a => Connection -> a -> IO ()+sendTextData conn = sendDataMessage conn . Text . toLazyByteString+++--------------------------------------------------------------------------------+-- | Send a message as binary data+sendBinaryData :: WebSocketsData a => Connection -> a -> IO ()+sendBinaryData conn = sendDataMessage conn . Binary . toLazyByteString+++--------------------------------------------------------------------------------+-- | Send a friendly close message+sendClose :: WebSocketsData a => Connection -> a -> IO ()+sendClose conn = send conn . ControlMessage . Close . toLazyByteString+++--------------------------------------------------------------------------------+-- | Send a ping+sendPing :: WebSocketsData a => Connection -> a -> IO ()+sendPing conn = send conn . ControlMessage . Ping . toLazyByteString

− src/Network/WebSockets/Handshake.hs

@@ -1,37 +0,0 @@--- | Implementation of the WebSocket handshake-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}-module Network.WebSockets.Handshake-    ( HandshakeError (..)-    , handshake-    , responseError-    ) where--import Data.List (find)--import qualified Data.ByteString as B-import qualified Data.Enumerator as E--import Network.WebSockets.Handshake.Http-import Network.WebSockets.Protocol---- | Receives and checks the client handshake. If no suitable protocol is found--- (or the client sends garbage), a 'HandshakeError' will be thrown.-handshake :: (Monad m, Protocol p)-          => RequestHttpPart-          -> E.Iteratee B.ByteString m (Request, p)-handshake rhp = case find (flip supported rhp) implementations of-    Nothing -> E.throwError NotSupported-    Just p  -> do-        rq <- finishRequest p rhp-        return (rq, p)---- | Respond to errors encountered during handshake. First argument may be--- bottom.-responseError :: forall p. Protocol p => p -> HandshakeError -> ResponseBody-responseError _ err = response400 $ case err of-    -- TODO: fix-    NotSupported -> versionHeader  -- Version negotiation-    _            -> []-  where-    versionHeader = [("Sec-WebSocket-Version",-        B.intercalate ", " $ concatMap headerVersions (implementations :: [p]))]

− src/Network/WebSockets/Handshake/Http.hs

@@ -1,211 +0,0 @@--- | Module dealing with HTTP: request data types, encoding and decoding...-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}-module Network.WebSockets.Handshake.Http-    ( Headers-    , Request (..)-    , RequestHttpPart (..)-    , RequestBody (..)-    , ResponseHttpPart (..)-    , ResponseBody (..)-    , HandshakeError (..)-    , getSecWebSocketVersion--    , encodeRequestHttpPart-    , encodeRequestBody-    , decodeRequest--    , encodeResponseHttpPart-    , encodeResponseBody-    , decodeResponse--    , response101-    , response400--    , getRequestHeader-    , getResponseHeader-    ) where--import Data.Dynamic (Typeable)-import Data.Monoid (mappend, mconcat)-import Control.Applicative (pure, (<$>), (<*>), (*>), (<*))-import Control.Exception (Exception)-import Control.Monad.Error (Error (..))--import Data.ByteString (ByteString)-import Data.ByteString.Char8 ()-import Data.ByteString.Internal (c2w)-import qualified Blaze.ByteString.Builder as Builder-import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder-import qualified Data.Attoparsec as A-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.CaseInsensitive as CI-import qualified Data.Enumerator as E---- | Request headers-type Headers = [(CI.CI B.ByteString, B.ByteString)]---- | Full request type, including the response to it-data Request = Request-    { requestPath     :: !B.ByteString-    , requestHeaders  :: Headers-    , requestResponse :: ResponseBody-    } deriving (Show)---- | (Internally used) HTTP headers and requested path.-data RequestHttpPart = RequestHttpPart-    { requestHttpPath    :: !B.ByteString-    , requestHttpHeaders :: Headers-    , requestHttpSecure  :: Bool-    } deriving (Eq, Show)---- | A request with a body-data RequestBody = RequestBody RequestHttpPart B.ByteString-    deriving (Show)---- | Response to a 'Request'-data ResponseHttpPart = ResponseHttpPart-    { responseHttpCode    :: !Int-    , responseHttpMessage :: !B.ByteString-    , responseHttpHeaders :: Headers-    } deriving (Show)---- | A response including a body-data ResponseBody = ResponseBody ResponseHttpPart B.ByteString-    deriving (Show)---- | Error in case of failed handshake. Will be thrown as an iteratee--- exception. ('Error' condition).------ TODO: This should probably be in the Handshake module, and is solely here to--- prevent a cyclic dependency.-data HandshakeError-    -- | We don't have a match for the protocol requested by the client.-    -- todo: version parameter-    = NotSupported-    -- | The request was somehow invalid (missing headers or wrong security-    -- token)-    | MalformedRequest RequestHttpPart String-    -- | The servers response was somehow invalid (missing headers or wrong-    -- security token)-    | MalformedResponse ResponseHttpPart String-    -- | The request was well-formed, but the library user rejected it.-    -- (e.g. "unknown path")-    | RequestRejected Request String-    -- | for example "EOF came too early" (which is actually a parse error)-    -- or for your own errors. (like "unknown path"?)-    | OtherHandshakeError String-    deriving (Show, Typeable)--instance Error HandshakeError where-    strMsg = OtherHandshakeError--instance Exception HandshakeError---- | Get the @Sec-WebSocket-Version@ header-getSecWebSocketVersion :: RequestHttpPart -> Maybe B.ByteString-getSecWebSocketVersion p = lookup "Sec-WebSocket-Version" (requestHttpHeaders p)---- | RequestHttpPart encoder-encodeRequestHttpPart :: RequestHttpPart -> Builder.Builder-encodeRequestHttpPart (RequestHttpPart path headers _) =-    Builder.copyByteString "GET "      `mappend`-    Builder.copyByteString path        `mappend`-    Builder.copyByteString " HTTP/1.1" `mappend`-    Builder.fromByteString "\r\n"      `mappend`-    mconcat (map header headers)       `mappend`-    Builder.copyByteString "\r\n"-  where-    header (k, v) = mconcat $ map Builder.copyByteString-        [CI.original k, ": ", v, "\r\n"]---- | RequestBody encoder-encodeRequestBody :: RequestBody -> Builder.Builder-encodeRequestBody (RequestBody httpPart body) =-    encodeRequestHttpPart httpPart `mappend` Builder.copyByteString body---- | Parse an initial request-decodeRequest :: Bool -> A.Parser RequestHttpPart-decodeRequest isSecure = RequestHttpPart-    <$> requestLine-    <*> A.manyTill header newline-    <*> pure isSecure-  where-    space   = A.word8 (c2w ' ')-    newline = A.string "\r\n"--    requestLine = A.string "GET" *> space *> A.takeWhile1 (/= c2w ' ')-        <* space-        <* A.string "HTTP/1.1" <* newline--    header = (,)-        <$> (CI.mk <$> A.takeWhile1 (/= c2w ':'))-        <*  A.string ": "-        <*> A.takeWhile (/= c2w '\r')-        <*  newline---- | Encode an HTTP upgrade response-encodeResponseHttpPart :: ResponseHttpPart -> Builder.Builder-encodeResponseHttpPart (ResponseHttpPart code msg headers) =-    Builder.copyByteString "HTTP/1.1 " `mappend`-    Builder.fromString (show code)     `mappend`-    Builder.fromChar ' '               `mappend`-    Builder.fromByteString msg         `mappend`-    Builder.fromByteString "\r\n"      `mappend`-    mconcat (map header headers)       `mappend`-    Builder.copyByteString "\r\n"-  where-    header (k, v) = mconcat $ map Builder.copyByteString-        [CI.original k, ": ", v, "\r\n"]--encodeResponseBody :: ResponseBody -> Builder.Builder-encodeResponseBody (ResponseBody httpPart body) =-    encodeResponseHttpPart httpPart `mappend` Builder.copyByteString body---- | An upgrade response-response101 :: Headers -> B.ByteString -> ResponseBody-response101 headers = ResponseBody-    (ResponseHttpPart 101 "WebSocket Protocol Handshake"-        (("Upgrade", "websocket") : ("Connection", "Upgrade") : headers))---- | Bad request----response400 :: Headers -> ResponseBody-response400 headers =-    ResponseBody (ResponseHttpPart 400 "Bad Request" headers) ""---- | HTTP response parser-decodeResponse :: A.Parser ResponseHttpPart-decodeResponse = ResponseHttpPart-    <$> fmap (read . BC.unpack) code-    <*> message-    <*> A.manyTill header newline-  where-    space = A.word8 (c2w ' ')-    newline = A.string "\r\n"--    code = A.string "HTTP/1.1" *> space *> A.takeWhile1 (/= c2w ' ') <* space-    message = A.takeWhile1 (/= c2w '\r') <* newline-    header = (,)-        <$> (CI.mk <$> A.takeWhile1 (/= c2w ':'))-        <*  A.string ": "-        <*> A.takeWhile (/= c2w '\r')-        <*  newline--getRequestHeader :: Monad m-                 => RequestHttpPart-                 -> CI.CI ByteString-                 -> E.Iteratee ByteString m ByteString-getRequestHeader rq key = case lookup key (requestHttpHeaders rq) of-    Just t  -> return t-    Nothing -> E.throwError $ MalformedRequest rq $ -        "Header missing: " ++ BC.unpack (CI.original key)--getResponseHeader :: Monad m-                  => ResponseHttpPart-                  -> CI.CI ByteString-                  -> E.Iteratee ByteString m ByteString-getResponseHeader rsp key = case lookup key (responseHttpHeaders rsp) of-    Just t  -> return t-    Nothing -> E.throwError $ MalformedResponse rsp $ -        "Header missing: " ++ BC.unpack (CI.original key)

+ src/Network/WebSockets/Http.hs view

@@ -0,0 +1,243 @@+--------------------------------------------------------------------------------+-- | Module dealing with HTTP: request data types, encoding and decoding...+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings  #-}+module Network.WebSockets.Http+    ( Headers+    , RequestHead (..)+    , Request (..)+    , ResponseHead (..)+    , Response (..)+    , HandshakeException (..)++    , encodeRequestHead+    , encodeRequest+    , decodeRequestHead++    , encodeResponseHead+    , encodeResponse+    , decodeResponseHead+    , decodeResponse++    , response101+    , response400++    , getRequestHeader+    , getResponseHeader+    , getRequestSecWebSocketVersion+    ) where+++--------------------------------------------------------------------------------+import qualified Blaze.ByteString.Builder           as Builder+import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder+import           Control.Applicative                (pure, (*>), (<$>), (<*),+                                                     (<*>))+import           Control.Exception                  (Exception, throw)+import           Control.Monad.Error                (Error (..))+import qualified Data.Attoparsec                    as A+import           Data.ByteString                    (ByteString)+import qualified Data.ByteString                    as B+import           Data.ByteString.Char8              ()+import qualified Data.ByteString.Char8              as BC+import           Data.ByteString.Internal           (c2w)+import qualified Data.CaseInsensitive               as CI+import           Data.Dynamic                       (Typeable)+import           Data.Monoid                        (mappend, mconcat)+++--------------------------------------------------------------------------------+-- | Request headers+type Headers = [(CI.CI ByteString, ByteString)]+++--------------------------------------------------------------------------------+-- | An HTTP request. The request body is not yet read.+data RequestHead = RequestHead+    { requestPath    :: !B.ByteString+    , requestHeaders :: Headers+    , requestSecure  :: Bool+    } deriving (Show)+++--------------------------------------------------------------------------------+-- | A request with a body+data Request = Request RequestHead B.ByteString+    deriving (Show)+++--------------------------------------------------------------------------------+-- | HTTP response, without body.+data ResponseHead = ResponseHead+    { responseCode    :: !Int+    , responseMessage :: !B.ByteString+    , responseHeaders :: Headers+    } deriving (Show)+++--------------------------------------------------------------------------------+-- | A response including a body+data Response = Response ResponseHead B.ByteString+    deriving (Show)+++--------------------------------------------------------------------------------+-- | Error in case of failed handshake. Will be thrown as an 'Exception'.+--+-- TODO: This should probably be in the Handshake module, and is solely here to+-- prevent a cyclic dependency.+data HandshakeException+    -- | We don't have a match for the protocol requested by the client.+    -- todo: version parameter+    = NotSupported+    -- | The request was somehow invalid (missing headers or wrong security+    -- token)+    | MalformedRequest RequestHead String+    -- | The servers response was somehow invalid (missing headers or wrong+    -- security token)+    | MalformedResponse ResponseHead String+    -- | The request was well-formed, but the library user rejected it.+    -- (e.g. "unknown path")+    | RequestRejected Request String+    -- | for example "EOF came too early" (which is actually a parse error)+    -- or for your own errors. (like "unknown path"?)+    | OtherHandshakeException String+    deriving (Show, Typeable)+++--------------------------------------------------------------------------------+instance Error HandshakeException where+    strMsg = OtherHandshakeException+++--------------------------------------------------------------------------------+instance Exception HandshakeException+++--------------------------------------------------------------------------------+encodeRequestHead :: RequestHead -> Builder.Builder+encodeRequestHead (RequestHead path headers _) =+    Builder.copyByteString "GET "      `mappend`+    Builder.copyByteString path        `mappend`+    Builder.copyByteString " HTTP/1.1" `mappend`+    Builder.fromByteString "\r\n"      `mappend`+    mconcat (map header headers)       `mappend`+    Builder.copyByteString "\r\n"+  where+    header (k, v) = mconcat $ map Builder.copyByteString+        [CI.original k, ": ", v, "\r\n"]+++--------------------------------------------------------------------------------+encodeRequest :: Request -> Builder.Builder+encodeRequest (Request head' body) =+    encodeRequestHead head' `mappend` Builder.copyByteString body+++--------------------------------------------------------------------------------+-- | Parse an initial request+decodeRequestHead :: Bool -> A.Parser RequestHead+decodeRequestHead isSecure = RequestHead+    <$> requestLine+    <*> A.manyTill decodeHeaderLine newline+    <*> pure isSecure+  where+    space   = A.word8 (c2w ' ')+    newline = A.string "\r\n"++    requestLine = A.string "GET" *> space *> A.takeWhile1 (/= c2w ' ')+        <* space+        <* A.string "HTTP/1.1" <* newline+++--------------------------------------------------------------------------------+-- | Encode an HTTP upgrade response+encodeResponseHead :: ResponseHead -> Builder.Builder+encodeResponseHead (ResponseHead code msg headers) =+    Builder.copyByteString "HTTP/1.1 " `mappend`+    Builder.fromString (show code)     `mappend`+    Builder.fromChar ' '               `mappend`+    Builder.fromByteString msg         `mappend`+    Builder.fromByteString "\r\n"      `mappend`+    mconcat (map header headers)       `mappend`+    Builder.copyByteString "\r\n"+  where+    header (k, v) = mconcat $ map Builder.copyByteString+        [CI.original k, ": ", v, "\r\n"]+++--------------------------------------------------------------------------------+encodeResponse :: Response -> Builder.Builder+encodeResponse (Response head' body) =+    encodeResponseHead head' `mappend` Builder.copyByteString body+++--------------------------------------------------------------------------------+-- | An upgrade response+response101 :: Headers -> B.ByteString -> Response+response101 headers = Response+    (ResponseHead 101 "WebSocket Protocol Handshake"+        (("Upgrade", "websocket") : ("Connection", "Upgrade") : headers))+++--------------------------------------------------------------------------------+-- | Bad request+response400 :: Headers -> B.ByteString -> Response+response400 headers = Response (ResponseHead 400 "Bad Request" headers)+++--------------------------------------------------------------------------------+-- | HTTP response parser+decodeResponseHead :: A.Parser ResponseHead+decodeResponseHead = ResponseHead+    <$> fmap (read . BC.unpack) code+    <*> message+    <*> A.manyTill decodeHeaderLine newline+  where+    space = A.word8 (c2w ' ')+    newline = A.string "\r\n"++    code = A.string "HTTP/1.1" *> space *> A.takeWhile1 (/= c2w ' ') <* space+    message = A.takeWhile1 (/= c2w '\r') <* newline+++--------------------------------------------------------------------------------+decodeResponse :: A.Parser Response+decodeResponse = Response <$> decodeResponseHead <*> A.takeByteString+++--------------------------------------------------------------------------------+getRequestHeader :: RequestHead+                 -> CI.CI ByteString+                 -> ByteString+getRequestHeader rq key = case lookup key (requestHeaders rq) of+    Just t  -> t+    Nothing -> throw $ MalformedRequest rq $+        "Header missing: " ++ BC.unpack (CI.original key)+++--------------------------------------------------------------------------------+getResponseHeader :: ResponseHead+                  -> CI.CI ByteString+                  -> ByteString+getResponseHeader rsp key = case lookup key (responseHeaders rsp) of+    Just t  -> t+    Nothing -> throw $ MalformedResponse rsp $+        "Header missing: " ++ BC.unpack (CI.original key)+++--------------------------------------------------------------------------------+-- | Get the @Sec-WebSocket-Version@ header+getRequestSecWebSocketVersion :: RequestHead -> Maybe B.ByteString+getRequestSecWebSocketVersion p =+    lookup "Sec-WebSocket-Version" (requestHeaders p)+++--------------------------------------------------------------------------------+decodeHeaderLine :: A.Parser (CI.CI ByteString, ByteString)+decodeHeaderLine = (,)+    <$> (CI.mk <$> A.takeWhile1 (/= c2w ':'))+    <*  A.word8 (c2w ':')+    <*  A.option (c2w ' ') (A.word8 (c2w ' '))+    <*> A.takeWhile (/= c2w '\r')+    <*  A.string "\r\n"

+ src/Network/WebSockets/Hybi13.hs view

@@ -0,0 +1,239 @@+--------------------------------------------------------------------------------+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Hybi13+    ( headerVersions+    , finishRequest+    , finishResponse+    , encodeMessages+    , decodeMessages+    , createRequest++      -- Internal (used for testing)+    , encodeFrame+    ) where+++--------------------------------------------------------------------------------+import qualified Blaze.ByteString.Builder              as B+import           Control.Applicative                   (pure, (<$>))+import           Control.Exception                     (throw)+import           Control.Monad                         (liftM)+import           Data.Attoparsec                       (anyWord8)+import qualified Data.Attoparsec                       as A+import           Data.Binary.Get                       (getWord16be,+                                                        getWord64be, runGet)+import           Data.Bits                             ((.&.), (.|.))+import           Data.ByteString                       (ByteString)+import qualified Data.ByteString.Base64                as B64+import           Data.ByteString.Char8                 ()+import qualified Data.ByteString.Lazy                  as BL+import           Data.Digest.Pure.SHA                  (bytestringDigest, sha1)+import           Data.Int                              (Int64)+import           Data.IORef+import           Data.Monoid                           (mappend, mconcat,+                                                        mempty)+import           Data.Tuple                            (swap)+import           System.Entropy                        as R+import qualified System.IO.Streams                     as Streams+import qualified System.IO.Streams.Attoparsec          as Streams+import           System.Random                         (RandomGen, newStdGen)+++--------------------------------------------------------------------------------+import           Network.WebSockets.Http+import           Network.WebSockets.Hybi13.Demultiplex+import           Network.WebSockets.Hybi13.Mask+import           Network.WebSockets.Types+++--------------------------------------------------------------------------------+headerVersions :: [ByteString]+headerVersions = ["13"]+++--------------------------------------------------------------------------------+finishRequest :: RequestHead+              -> Response+finishRequest reqHttp =+    let !key     = getRequestHeader reqHttp "Sec-WebSocket-Key"+        !hash    = hashKey key+        !encoded = B64.encode hash+    in response101 [("Sec-WebSocket-Accept", encoded)] ""+++--------------------------------------------------------------------------------+finishResponse :: RequestHead+               -> ResponseHead+               -> Response+finishResponse request response+    -- Response message should be one of+    --+    -- - WebSocket Protocol Handshake+    -- - Switching Protocols+    --+    -- But we don't check it for now+    | responseCode response /= 101  = throw $ MalformedResponse response+        "Wrong response status or message."+    | responseHash /= challengeHash = throw $ MalformedResponse response+        "Challenge and response hashes do not match."+    | otherwise                     =+        Response response ""+  where+    key           = getRequestHeader  request  "Sec-WebSocket-Key"+    responseHash  = getResponseHeader response "Sec-WebSocket-Accept"+    challengeHash = B64.encode $ hashKey key+++--------------------------------------------------------------------------------+encodeMessage :: RandomGen g => ConnectionType -> g -> Message -> (g, B.Builder)+encodeMessage conType gen msg = (gen', builder `mappend` B.flush)+  where+    mkFrame      = Frame True False False False+    (mask, gen') = case conType of+        ServerConnection -> (Nothing, gen)+        ClientConnection -> randomMask gen+    builder      = encodeFrame mask $ case msg of+        (ControlMessage (Close pl)) -> mkFrame CloseFrame  pl+        (ControlMessage (Ping pl))  -> mkFrame PingFrame   pl+        (ControlMessage (Pong pl))  -> mkFrame PongFrame   pl+        (DataMessage (Text pl))     -> mkFrame TextFrame   pl+        (DataMessage (Binary pl))   -> mkFrame BinaryFrame pl+++--------------------------------------------------------------------------------+encodeMessages :: ConnectionType+               -> Streams.OutputStream B.Builder+               -> IO (Streams.OutputStream Message)+encodeMessages conType bStream = do+    genRef <- newIORef =<< newStdGen+    Streams.lockingOutputStream =<< Streams.makeOutputStream (next genRef)+  where+    next :: RandomGen g => IORef g -> Maybe Message -> IO ()+    next _      Nothing    = return ()+    next genRef (Just msg) = do+        build <- atomicModifyIORef genRef $ \s -> encodeMessage conType s msg+        Streams.write (Just build) bStream+++--------------------------------------------------------------------------------+encodeFrame :: Mask -> Frame -> B.Builder+encodeFrame mask f = B.fromWord8 byte0 `mappend`+    B.fromWord8 byte1 `mappend` len `mappend` maskbytes `mappend`+    B.fromLazyByteString (maskPayload mask (framePayload f))+  where+    byte0  = fin .|. rsv1 .|. rsv2 .|. rsv3 .|. opcode+    fin    = if frameFin f  then 0x80 else 0x00+    rsv1   = if frameRsv1 f then 0x40 else 0x00+    rsv2   = if frameRsv2 f then 0x20 else 0x00+    rsv3   = if frameRsv3 f then 0x10 else 0x00+    opcode = case frameType f of+        ContinuationFrame -> 0x00+        TextFrame         -> 0x01+        BinaryFrame       -> 0x02+        CloseFrame        -> 0x08+        PingFrame         -> 0x09+        PongFrame         -> 0x0a++    (maskflag, maskbytes) = case mask of+        Nothing -> (0x00, mempty)+        Just m  -> (0x80, B.fromByteString m)++    byte1 = maskflag .|. lenflag+    len'  = BL.length (framePayload f)+    (lenflag, len)+        | len' < 126     = (fromIntegral len', mempty)+        | len' < 0x10000 = (126, B.fromWord16be (fromIntegral len'))+        | otherwise      = (127, B.fromWord64be (fromIntegral len'))+++--------------------------------------------------------------------------------+decodeMessages :: Streams.InputStream ByteString+               -> IO (Streams.InputStream Message)+decodeMessages bsStream = do+    dmRef <- newIORef emptyDemultiplexState+    Streams.makeInputStream $ next dmRef+  where+    next dmRef = do+        frame <- Streams.parseFromStream parseFrame bsStream+        m     <- atomicModifyIORef dmRef $ \s -> swap $ demultiplex s frame+        maybe (next dmRef) (return . Just) m+++--------------------------------------------------------------------------------+-- | Parse a frame+parseFrame :: A.Parser Frame+parseFrame = do+    byte0 <- anyWord8+    let fin    = byte0 .&. 0x80 == 0x80+        rsv1   = byte0 .&. 0x40 == 0x40+        rsv2   = byte0 .&. 0x20 == 0x20+        rsv3   = byte0 .&. 0x10 == 0x10+        opcode = byte0 .&. 0x0f++    let ft = case opcode of+            0x00 -> ContinuationFrame+            0x01 -> TextFrame+            0x02 -> BinaryFrame+            0x08 -> CloseFrame+            0x09 -> PingFrame+            0x0a -> PongFrame+            _    -> error "Unknown opcode"++    byte1 <- anyWord8+    let mask = byte1 .&. 0x80 == 0x80+        lenflag = fromIntegral (byte1 .&. 0x7f)++    len <- case lenflag of+        126 -> fromIntegral . runGet' getWord16be <$> A.take 2+        127 -> fromIntegral . runGet' getWord64be <$> A.take 8+        _   -> return lenflag++    masker <- maskPayload <$> if mask then Just <$> A.take 4 else pure Nothing++    chunks <- take64 len++    return $ Frame fin rsv1 rsv2 rsv3 ft (masker $ BL.fromChunks chunks)+  where+    runGet' g = runGet g . BL.fromChunks . return++    take64 :: Int64 -> A.Parser [ByteString]+    take64 n+        | n <= 0    = return []+        | otherwise = do+            let n' = min intMax n+            chunk <- A.take (fromIntegral n')+            (chunk :) <$> take64 (n - n')+      where+        intMax :: Int64+        intMax = fromIntegral (maxBound :: Int)+++--------------------------------------------------------------------------------+hashKey :: ByteString -> ByteString+hashKey key = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid+  where+    guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"+    lazy = BL.fromChunks . return+    unlazy = mconcat . BL.toChunks+++--------------------------------------------------------------------------------+createRequest :: ByteString+              -> ByteString+              -> Bool+              -> Headers+              -> IO RequestHead+createRequest hostname path secure customHeaders = do+    key <- B64.encode `liftM`  getEntropy 16+    return $ RequestHead path (headers key ++ customHeaders) secure+  where+    headers key =+        [ ("Host"                   , hostname     )+        , ("Connection"             , "Upgrade"    )+        , ("Upgrade"                , "websocket"  )+        , ("Sec-WebSocket-Key"      , key          )+        , ("Sec-WebSocket-Version"  , versionNumber)+        ]++    versionNumber = head headerVersions

+ src/Network/WebSockets/Hybi13/Demultiplex.hs view

@@ -0,0 +1,105 @@+--------------------------------------------------------------------------------+-- | Demultiplexing of frames into messages+{-# LANGUAGE DeriveDataTypeable #-}+module Network.WebSockets.Hybi13.Demultiplex+    ( FrameType (..)+    , Frame (..)+    , DemultiplexState+    , emptyDemultiplexState+    , demultiplex+    ) where+++--------------------------------------------------------------------------------+import           Blaze.ByteString.Builder (Builder)+import qualified Blaze.ByteString.Builder as B+import           Control.Exception        (Exception, throw)+import qualified Data.ByteString.Lazy     as BL+import           Data.Monoid              (mappend)+import           Data.Typeable            (Typeable)+++--------------------------------------------------------------------------------+import           Network.WebSockets.Types+++--------------------------------------------------------------------------------+-- | A low-level representation of a WebSocket packet+data Frame = Frame+    { frameFin     :: !Bool+    , frameRsv1    :: !Bool+    , frameRsv2    :: !Bool+    , frameRsv3    :: !Bool+    , frameType    :: !FrameType+    , framePayload :: !BL.ByteString+    } deriving (Eq, Show)+++--------------------------------------------------------------------------------+-- | The type of a frame. Not all types are allowed for all protocols.+data FrameType+    = ContinuationFrame+    | TextFrame+    | BinaryFrame+    | CloseFrame+    | PingFrame+    | PongFrame+    deriving (Eq, Show)+++--------------------------------------------------------------------------------+-- | Thrown if the client sends invalid multiplexed data+data DemultiplexException = DemultiplexException+    deriving (Show, Typeable)+++--------------------------------------------------------------------------------+instance Exception DemultiplexException+++--------------------------------------------------------------------------------+-- | Internal state used by the demultiplexer+newtype DemultiplexState = DemultiplexState+    { unDemultiplexState :: Maybe (FrameType, Builder)+    }+++--------------------------------------------------------------------------------+emptyDemultiplexState :: DemultiplexState+emptyDemultiplexState = DemultiplexState Nothing+++--------------------------------------------------------------------------------+demultiplex :: DemultiplexState+            -> Frame+            -> (Maybe Message, DemultiplexState)+demultiplex state (Frame fin _ _ _ tp pl) = case tp of+    -- Return control messages immediately, they have no influence on the state+    CloseFrame  -> (Just (ControlMessage (Close pl)), state)+    PingFrame   -> (Just (ControlMessage (Ping pl)), state)+    PongFrame   -> (Just (ControlMessage (Pong pl)), state)+    -- If we're dealing with a continuation...+    ContinuationFrame -> case unDemultiplexState state of+        -- We received a continuation but we don't have any state. Let's ignore+        -- this fragment...+        Nothing -> (Nothing, DemultiplexState Nothing)+        -- Append the payload to the state+        -- TODO: protect against overflows+        Just (amt, b)+            | not fin   -> (Nothing, DemultiplexState (Just (amt, b')))+            | otherwise -> case amt of+                TextFrame   -> (Just (DataMessage (Text m)), e)+                BinaryFrame -> (Just (DataMessage (Binary m)), e)+                _           -> throw DemultiplexException+          where+            b' = b `mappend` plb+            m = B.toLazyByteString b'+    TextFrame+        | fin       -> (Just (DataMessage (Text pl)), e)+        | otherwise -> (Nothing, DemultiplexState (Just (TextFrame, plb)))+    BinaryFrame+        | fin       -> (Just (DataMessage (Binary pl)), e)+        | otherwise -> (Nothing, DemultiplexState (Just (BinaryFrame, plb)))+  where+    e = emptyDemultiplexState+    plb = B.fromLazyByteString pl

+ src/Network/WebSockets/Hybi13/Mask.hs view

@@ -0,0 +1,46 @@+--------------------------------------------------------------------------------+-- | Masking of fragmes using a simple XOR algorithm+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Network.WebSockets.Hybi13.Mask+    ( Mask+    , maskPayload+    , randomMask+    ) where+++--------------------------------------------------------------------------------+import           Data.Bits            (shiftR, xor)+import qualified Data.ByteString      as B+import qualified Data.ByteString.Lazy as BL+import           System.Random        (RandomGen, random)+++--------------------------------------------------------------------------------+-- | ByteString should be exactly 4 bytes long+type Mask = Maybe B.ByteString+++--------------------------------------------------------------------------------+-- | Apply mask+maskPayload :: Mask -> BL.ByteString -> BL.ByteString+maskPayload Nothing     = id+maskPayload (Just mask) = snd . BL.mapAccumL f 0+  where+    len     = B.length mask+    f !i !c =+        let i' = (i + 1) `mod` len+            m  = mask `B.index` i+        in (i', m `xor` c)+++--------------------------------------------------------------------------------+-- | Create a random mask+randomMask :: forall g. RandomGen g => g -> (Mask, g)+randomMask gen = (Just (B.pack [b1, b2, b3, b4]), gen')+  where+    (!int, !gen') = random gen :: (Int, g)+    !b1           = fromIntegral $ int `mod` 0x100+    !b2           = fromIntegral $ int `shiftR` 8  `mod` 0x100+    !b3           = fromIntegral $ int `shiftR` 16 `mod` 0x100+    !b4           = fromIntegral $ int `shiftR` 24 `mod` 0x100

− src/Network/WebSockets/Internal.hs

@@ -1,8 +0,0 @@--- | This module exports some extra functions. However, note that these--- utilities are primarily meant for internal use, and can change between minor--- releases.-module Network.WebSockets.Internal-    ( S.iterSocket-    ) where--import qualified Network.WebSockets.Socket as S

− src/Network/WebSockets/Monad.hs

@@ -1,263 +0,0 @@--- | Provides a simple, clean monad to write websocket servers in-{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, OverloadedStrings,-        NoMonomorphismRestriction, Rank2Types, ScopedTypeVariables #-}-module Network.WebSockets.Monad-    ( WebSocketsOptions (..)-    , defaultWebSocketsOptions-    , WebSockets (..)-    , runWebSockets-    , runWebSocketsWith-    , runWebSocketsHandshake-    , runWebSocketsWithHandshake-    , runWebSocketsWith'-    , receive-    , sendBuilder-    , send-    , Sink-    , sendSink-    , getSink-    , getOptions-    , getProtocol-    , getVersion-    , throwWsError-    , catchWsError-    , spawnPingThread-    , receiveIteratee-    , makeBuilderSender-    ) where--import Control.Applicative (Applicative, (<$>))-import Control.Concurrent (forkIO, threadDelay)-import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar)-import Control.Exception (Exception (..), SomeException, throw)-import Control.Monad (forever)-import Control.Monad.Reader (ReaderT, ask, runReaderT)-import Control.Monad.Trans (MonadIO, lift, liftIO)-import Data.Foldable (forM_)-import System.Random (newStdGen)--import Blaze.ByteString.Builder (Builder)-import Data.ByteString (ByteString)-import Data.Enumerator (Enumerator, Iteratee, ($$), (>>==), (=$))-import qualified Blaze.ByteString.Builder as BB-import qualified Data.Attoparsec as A-import qualified Data.ByteString.Lazy as BL-import qualified Data.Attoparsec.Enumerator as AE-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL--import Network.WebSockets.Handshake-import Network.WebSockets.Handshake.Http-import Network.WebSockets.Protocol-import Network.WebSockets.Types---- | Options for the WebSocket program-data WebSocketsOptions = WebSocketsOptions-    { onPong       :: IO ()-    }---- | Default options-defaultWebSocketsOptions :: WebSocketsOptions-defaultWebSocketsOptions = WebSocketsOptions-    { onPong       = return ()-    }---- | Environment in which the 'WebSockets' monad actually runs-data WebSocketsEnv p = WebSocketsEnv-    { envOptions     :: WebSocketsOptions-    , envSendBuilder :: Builder -> IO ()-    , envSink        :: Sink p-    , envProtocol    :: p-    }---- | Used for asynchronous sending.-newtype Sink p = Sink-    { unSink :: MVar (E.Iteratee (Message p) IO ())-    } deriving (Eq)---- | The monad in which you can write WebSocket-capable applications-newtype WebSockets p a = WebSockets-    { unWebSockets :: ReaderT (WebSocketsEnv p) (Iteratee (Message p) IO) a-    } deriving (Applicative, Functor, Monad, MonadIO)---- | Receives the initial client handshake, then behaves like 'runWebSockets'.-runWebSocketsHandshake :: Protocol p-                       => Bool-                       -> (Request -> WebSockets p a)-                       -> Iteratee ByteString IO ()-                       -> Iteratee ByteString IO a-runWebSocketsHandshake = runWebSocketsWithHandshake defaultWebSocketsOptions---- | Receives the initial client handshake, then behaves like--- 'runWebSocketsWith'.-runWebSocketsWithHandshake :: Protocol p-                           => WebSocketsOptions-                           -> Bool-                           -> (Request -> WebSockets p a)-                           -> Iteratee ByteString IO ()-                           -> Iteratee ByteString IO a-runWebSocketsWithHandshake opts isSecure goWs outIter = do-    httpReq <- receiveIteratee $ decodeRequest isSecure-    runWebSocketsWith opts httpReq goWs outIter---- | Run a 'WebSockets' application on an 'Enumerator'/'Iteratee' pair, given--- that you (read: your web server) has already received the HTTP part of the--- initial request. If not, you might want to use 'runWebSocketsWithHandshake'--- instead.------ If the handshake failed, throws a 'HandshakeError'. Otherwise, executes the--- supplied continuation. You should still send a response to the client--- yourself.-runWebSockets :: Protocol p-              => RequestHttpPart-              -> (Request -> WebSockets p a)-              -> Iteratee ByteString IO ()-              -> Iteratee ByteString IO a-runWebSockets = runWebSocketsWith defaultWebSocketsOptions---- | Version of 'runWebSockets' which allows you to specify custom options-runWebSocketsWith :: forall p a. Protocol p-                  => WebSocketsOptions-                  -> RequestHttpPart-                  -> (Request -> WebSockets p a)-                  -> Iteratee ByteString IO ()-                  -> Iteratee ByteString IO a-runWebSocketsWith opts httpReq goWs outIter = E.catchError ok $ \e -> do-    -- If handshake went bad, send response-    forM_ (fromException e) $ \he ->-        let builder = encodeResponseBody $ responseError (undefined :: p) he-        in liftIO $ makeBuilderSender outIter builder-    -- Re-throw error-    E.throwError e-  where-    -- Perform handshake, call runWebSocketsWith'-    ok = do-        (rq, p) <- handshake httpReq-        runWebSocketsWith' opts p False (goWs rq) outIter--runWebSocketsWith' :: Protocol p-                   => WebSocketsOptions          -- ^ Options-                   -> p                          -- ^ Protocol-                   -> Bool                       -- ^ Need to mask-                   -> WebSockets p a             -- ^ App-                   -> Iteratee ByteString IO ()  -- ^ Out iteratee-                   -> Iteratee ByteString IO a   -- ^ Resulting iteratee-runWebSocketsWith' opts proto mask ws outIter = do-    -- Create sink with a random source-    gen <- liftIO newStdGen-    let sinkIter =-            encodeMessages proto mask gen =$ builderToByteString =$ outIter-    sink <- Sink <$> liftIO (newMVar sinkIter)--    let sender = makeBuilderSender outIter-        env    = WebSocketsEnv opts sender sink proto-        iter   = runReaderT (unWebSockets ws) env--    decodeMessages proto =$ iter--makeBuilderSender :: MonadIO m => Iteratee ByteString m b -> Builder -> m ()-makeBuilderSender outIter x = do-    ok <- E.run $ singleton x $$ builderToByteString $$ outIter-    case ok of-        Left err -> throw err-        Right _  -> return ()---- | @spawnPingThread n@ spawns a thread which sends a ping every @n@ seconds--- (if the protocol supports it). To be called after having sent the response.-spawnPingThread :: BinaryProtocol p => Int -> WebSockets p ()-spawnPingThread i = do-    sink <- getSink-    _ <- liftIO $ forkIO $ forever $ do-        -- An ugly hack here. We first sleep before sending the first-        -- ping, so the ping (hopefully) doesn't interfere with the-        -- intitial request/response.-        threadDelay (i * 1000 * 1000)  -- seconds-        sendSink sink $ ping ("Hi" :: ByteString)-    return ()---- | Receive arbitrary data.-receiveIteratee :: A.Parser a -> Iteratee ByteString IO a-receiveIteratee parser = do-    eof <- E.isEOF-    if eof-        then E.throwError ConnectionClosed-        else wrappingParseError . AE.iterParser $ parser---- | Execute an iteratee, wrapping attoparsec-enumeratee's ParseError into the--- ParseError constructor (which is a ConnectionError).-wrappingParseError :: (Monad m) => Iteratee a m b -> Iteratee a m b-wrappingParseError = flip E.catchError $ \e -> E.throwError $-    maybe e (toException . ParseError) $ fromException e---- | Receive a message-receive :: Protocol p => WebSockets p (Message p)-receive = liftIteratee $ do-    mmsg <- EL.head-    case mmsg of-        Nothing  -> E.throwError ConnectionClosed-        Just msg -> return msg---- | Send an arbitrary 'Builder'-sendBuilder :: Builder -> WebSockets p ()-sendBuilder builder = WebSockets $ do-    sb <- envSendBuilder <$> ask-    liftIO $ sb builder---- | Low-level sending with an arbitrary 'T.Message'-send :: Protocol p => Message p -> WebSockets p ()-send msg = getSink >>= \sink -> liftIO $ sendSink sink msg---- | Send a message to a sink. Might generate an exception if the underlying--- connection is closed.-sendSink :: Sink p -> Message p -> IO ()-sendSink sink msg = modifyMVar_ (unSink sink) $ \iter -> do-    step <- E.runIteratee $ singleton msg $$ iter-    case step of-        E.Error err -> throw err-        _           -> return $! E.returnI step---- | In case the user of the library wants to do asynchronous sending to the--- socket, he can extract a 'Sink' and pass this value around, for example,--- to other threads.-getSink :: Protocol p => WebSockets p (Sink p)-getSink = WebSockets $ envSink <$> ask--singleton :: Monad m => a -> Enumerator a m b-singleton c = E.checkContinue0 $ \_ f -> f (E.Chunks [c]) >>== E.returnI---- TODO: Figure out why Blaze.ByteString.Enumerator.builderToByteString doesn't--- work, then inform Simon or send a patch.-builderToByteString :: Monad m => E.Enumeratee Builder ByteString m a-builderToByteString = EL.concatMap $ BL.toChunks . BB.toLazyByteString---- | Get the current configuration-getOptions :: WebSockets p WebSocketsOptions-getOptions = WebSockets $ ask >>= return . envOptions---- | Get the underlying protocol-getProtocol :: WebSockets p p-getProtocol = WebSockets $ envProtocol <$> ask---- | Find out the 'WebSockets' version used at runtime-getVersion :: Protocol p => WebSockets p String-getVersion = version <$> getProtocol---- | Throw an iteratee error in the WebSockets monad-throwWsError :: (Exception e) => e -> WebSockets p a-throwWsError = liftIteratee . E.throwError---- | Catch an iteratee error in the WebSockets monad-catchWsError :: WebSockets p a-             -> (SomeException -> WebSockets p a)-             -> WebSockets p a-catchWsError act c = WebSockets $ do-    env <- ask-    let it  = peelWebSockets env $ act-        cit = peelWebSockets env . c-    lift $ it `E.catchError` cit-  where-    peelWebSockets env = flip runReaderT env . unWebSockets---- | Lift an Iteratee computation to WebSockets-liftIteratee :: Iteratee (Message p) IO a -> WebSockets p a-liftIteratee = WebSockets . lift

src/Network/WebSockets/Protocol.hs view

@@ -1,100 +1,85 @@+-------------------------------------------------------------------------------- -- | Wrapper for supporting multiple protocol versions {-# LANGUAGE ExistentialQuantification #-} module Network.WebSockets.Protocol     ( Protocol (..)-    , TextProtocol-    , BinaryProtocol-    , close-    , ping-    , pong-    , textData-    , binaryData+    , defaultProtocol+    , protocols+    , compatible+    , headerVersions+    , finishRequest+    , finishResponse+    , encodeMessages+    , decodeMessages+    , createRequest     ) where -import Blaze.ByteString.Builder (Builder)-import System.Random (RandomGen)-import qualified Data.ByteString as B-import qualified Data.Enumerator as E -import Network.WebSockets.Types-import Network.WebSockets.Handshake.Http-import qualified Network.WebSockets.Protocol.Unsafe as Unsafe+--------------------------------------------------------------------------------+import           Blaze.ByteString.Builder  (Builder)+import           Data.ByteString           (ByteString)+import qualified Data.ByteString           as B+import qualified System.IO.Streams         as Streams -class Protocol p where-    -- | Unique identifier for us.-    version         :: p -> String -    -- | Version accepted in the "Sec-WebSocket-Version " header. This is-    -- usually not the same, or derivable from "version", e.g. for hybi10, it's-    -- "7", "8" or "17".-    headerVersions  :: p -> [B.ByteString]+--------------------------------------------------------------------------------+import           Network.WebSockets.Http+import qualified Network.WebSockets.Hybi13 as Hybi13+import           Network.WebSockets.Types -    -- | Determine if the protocol is compatible with a requested version. A-    -- default implementation exists which uses the @headerVersions@ of the-    -- protocol.-    supported       :: p -> RequestHttpPart -> Bool-    supported p h   = case getSecWebSocketVersion h of-        Just v -> v `elem` headerVersions p-        _      -> False -    -- | Encodes messages to binary 'Builder's. Takes a random source so it is-    -- able to do masking of frames (needed in some cases).-    encodeMessages  :: (Monad m, RandomGen g)-                    => p     -- ^ Protocol-                    -> Bool  -- ^ Mask messages-                    -> g     -- ^ Random source-                    -> E.Enumeratee (Message p) Builder m a+--------------------------------------------------------------------------------+data Protocol+    = Hybi13+    deriving (Show) -    -- | Decodes messages from binary 'B.ByteString's.-    decodeMessages  :: Monad m => p -> E.Enumeratee B.ByteString (Message p) m a -    -- | Create a @Request@ that can be sent to the websockets server to open-    -- the connection.-    createRequest   :: p-                    -> B.ByteString         -- ^ Hostname of the server.-                    -> B.ByteString         -- ^ Path-                    -> Maybe B.ByteString   -- ^ Origin where we are connecting from.-                    -> Maybe [B.ByteString] -- ^ Protocols list.-                    -> Bool                 -- ^ Is the connection secure, i.e. wss.-                    -> IO RequestHttpPart   -- ^ HTTP request that can be sent to the-                                            --   to the server to initiate the connection.+--------------------------------------------------------------------------------+defaultProtocol :: Protocol+defaultProtocol = Hybi13 -    -- | Parse and validate the rest of the request. For hybi10, this is just-    -- validation, but hybi00 also needs to fetch a "security token"-    ---    -- In case of failure, this function may throw a 'HandshakeError'.-    -- be amended with the RequestHttpPart for the user)-    finishRequest   :: Monad m-                    => p -> RequestHttpPart-                    -> E.Iteratee B.ByteString m Request -    -- | Parse and validate the handshake response received from the server.-    finishResponse :: Monad m-                   => p -> RequestHttpPart -> ResponseHttpPart-                   -> E.Iteratee B.ByteString m ResponseBody+--------------------------------------------------------------------------------+protocols :: [Protocol]+protocols = [Hybi13] -    -- | Implementations of the specification-    implementations :: [p] -class Protocol p => TextProtocol p-class TextProtocol p => BinaryProtocol p+--------------------------------------------------------------------------------+headerVersions :: Protocol -> [ByteString]+headerVersions Hybi13 = Hybi13.headerVersions --- | Construct a close message-close :: (TextProtocol p, WebSocketsData a) => a -> Message p-close = Unsafe.close --- | Construct a ping message-ping :: (BinaryProtocol p, WebSocketsData a) => a -> Message p-ping = Unsafe.ping+--------------------------------------------------------------------------------+compatible :: Protocol -> RequestHead -> Bool+compatible protocol req = case getRequestSecWebSocketVersion req of+    Just v -> v `elem` headerVersions protocol+    _      -> True  -- Whatever? --- | Construct a pong message-pong :: (BinaryProtocol p, WebSocketsData a) => a -> Message p-pong = Unsafe.pong --- | Construct a text message-textData :: (TextProtocol p, WebSocketsData a) => a -> Message p-textData = Unsafe.textData+--------------------------------------------------------------------------------+finishRequest :: Protocol -> RequestHead -> Response+finishRequest Hybi13 = Hybi13.finishRequest --- | Construct a binary message-binaryData :: (BinaryProtocol p, WebSocketsData a) => a -> Message p-binaryData = Unsafe.binaryData++--------------------------------------------------------------------------------+finishResponse :: Protocol -> RequestHead -> ResponseHead -> Response+finishResponse Hybi13 = Hybi13.finishResponse+++--------------------------------------------------------------------------------+encodeMessages :: Protocol -> ConnectionType+               -> Streams.OutputStream Builder+               -> IO (Streams.OutputStream Message)+encodeMessages Hybi13 = Hybi13.encodeMessages+++--------------------------------------------------------------------------------+decodeMessages :: Protocol -> Streams.InputStream B.ByteString+               -> IO (Streams.InputStream Message)+decodeMessages Hybi13 = Hybi13.decodeMessages+++--------------------------------------------------------------------------------+createRequest :: Protocol -> B.ByteString -> B.ByteString -> Bool -> Headers+              -> IO RequestHead+createRequest Hybi13 = Hybi13.createRequest

− src/Network/WebSockets/Protocol/Hybi00.hs

@@ -1,28 +0,0 @@-{-# LANGUAGE ExistentialQuantification, OverloadedStrings #-}-module Network.WebSockets.Protocol.Hybi00-       ( Hybi00_ (..)-       , Hybi00-       ) where--import Data.Enumerator ((=$))-import Data.Enumerator.List as EL-import Network.WebSockets.Protocol-import Network.WebSockets.Protocol.Hybi00.Internal-import Network.WebSockets.Protocol.Hybi10.Internal-import Network.WebSockets.Protocol.Unsafe--data Hybi00 = forall p. Protocol p => Hybi00 p--instance Protocol Hybi00 where-    version        (Hybi00 p)     = version p-    headerVersions (Hybi00 p)     = headerVersions p-    supported      (Hybi00 p) h   = supported p h-    encodeMessages (Hybi00 p) m g =-        (EL.map castMessage =$) . encodeMessages p m g-    decodeMessages (Hybi00 p)     = (decodeMessages p =$) . EL.map castMessage-    createRequest  (Hybi00 p)     = createRequest p-    finishRequest  (Hybi00 p)     = finishRequest p-    finishResponse (Hybi00 p)     = finishResponse p-    implementations               = [Hybi00 Hybi10_, Hybi00 Hybi00_]--instance TextProtocol Hybi00

− src/Network/WebSockets/Protocol/Hybi00/Internal.hs

@@ -1,100 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-module Network.WebSockets.Protocol.Hybi00.Internal-       ( Hybi00_ (..)-       ) where--import Control.Applicative ((<|>))-import Data.Char (isDigit)--import Data.Binary (encode)-import Data.ByteString.Lazy.Char8 ()-import Data.Digest.Pure.MD5 (md5)-import Data.Int (Int32)-import qualified Blaze.ByteString.Builder as BB-import qualified Data.Attoparsec as A-import qualified Data.Attoparsec.Enumerator as A-import qualified Data.ByteString as B-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy.Char8 ()-import qualified Data.ByteString.Lazy as BL--import Network.WebSockets.Handshake.Http-import Network.WebSockets.Protocol-import Network.WebSockets.Types--data Hybi00_ = Hybi00_--instance Protocol Hybi00_ where-    version        Hybi00_     = "hybi00"-    headerVersions Hybi00_     = []  -- The client will elide it-    supported      Hybi00_ h   = getSecWebSocketVersion h == Nothing-    encodeMessages Hybi00_ _ _ = EL.map encodeMessage-    decodeMessages Hybi00_     = E.sequence (A.iterParser parseMessage)-    createRequest  Hybi00_     = error "createRequest Hybi00_"-    finishRequest  Hybi00_     = handshakeHybi00-    finishResponse Hybi00_     = error "finishResponse Hybi00_"-    implementations            = [Hybi00_]--instance TextProtocol Hybi00_--encodeMessage :: Message p -> BB.Builder-encodeMessage (DataMessage (Text pl))    =-    BB.fromLazyByteString $ "\0" `BL.append` pl `BL.append` "\255"-encodeMessage (ControlMessage (Close _)) =-    BB.fromLazyByteString  "\255\0"-encodeMessage msg                        = error $-    "Network.WebSockets.Protocol.Hybi00.encodeFrame: unsupported message: " ++-    show msg--parseMessage :: A.Parser (Message p)-parseMessage = parseText <|> parseClose-  where-    parseText = do-        _ <- A.word8 0x00-        utf8string <- A.manyTill A.anyWord8 (A.try $ A.word8 0xff)-        return $ DataMessage $ Text $ BL.pack utf8string--    parseClose = do-        _ <- A.word8 0xff-        _ <- A.word8 0x00-        return $ ControlMessage $ Close ""--divBySpaces :: String -> Maybe Int32-divBySpaces str-    | spaces == 0 = Nothing-    | otherwise   = Just . fromIntegral $ number `div` spaces-  where-    number = read $ filter isDigit str :: Integer-    spaces = fromIntegral . length $ filter (== ' ') str--handshakeHybi00 :: Monad m-                => RequestHttpPart-                -> E.Iteratee B.ByteString m Request-handshakeHybi00 reqHttp@(RequestHttpPart path h isSecure) = do-    keyPart3 <- A.iterParser $ A.take 8-    keyPart1 <- numberFromToken =<< getHeader "Sec-WebSocket-Key1"-    keyPart2 <- numberFromToken =<< getHeader "Sec-WebSocket-Key2"--    let key = B.concat . BL.toChunks . encode . md5 $ BL.concat-                [keyPart1, keyPart2, BL.fromChunks [keyPart3]]--    host   <- getHeader "Host"-    -- todo: origin right? (also applies to hybi10)-    origin <- getHeader "Origin"-    let schema = if isSecure then "wss://" else "ws://"-    let response = response101-            [ ("Sec-WebSocket-Location", B.concat [schema, host, path])-            , ("Sec-WebSocket-Origin", origin)-            ]-            key--    return $ Request path h response-  where-    getHeader = getRequestHeader reqHttp-    numberFromToken token = case divBySpaces (BC.unpack token) of-        Just n  -> return $ encode n-        Nothing -> E.throwError $ MalformedRequest reqHttp-            "Security token does not contain enough spaces"

− src/Network/WebSockets/Protocol/Hybi10.hs

@@ -1,27 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-module Network.WebSockets.Protocol.Hybi10-    ( Hybi10-    ) where--import Data.Enumerator ((=$))-import Data.Enumerator.List as EL-import Network.WebSockets.Protocol-import Network.WebSockets.Protocol.Hybi10.Internal-import Network.WebSockets.Protocol.Unsafe--data Hybi10 = forall p. Protocol p => Hybi10 p--instance Protocol Hybi10 where-    version        (Hybi10 p)     = version p-    headerVersions (Hybi10 p)     = headerVersions p-    supported      (Hybi10 p) h   = supported p h-    encodeMessages (Hybi10 p) m g =-        (EL.map castMessage =$) . encodeMessages p m g-    decodeMessages (Hybi10 p)     = (decodeMessages p =$) . EL.map castMessage-    createRequest  (Hybi10 p)     = createRequest p-    finishRequest  (Hybi10 p)     = finishRequest p-    finishResponse (Hybi10 p)     = finishResponse p-    implementations               = [Hybi10 Hybi10_]--instance TextProtocol Hybi10-instance BinaryProtocol Hybi10

− src/Network/WebSockets/Protocol/Hybi10/Demultiplex.hs

@@ -1,77 +0,0 @@--- | Demultiplexing of frames into messages-module Network.WebSockets.Protocol.Hybi10.Demultiplex-    ( FrameType (..)-    , Frame (..)-    , DemultiplexState-    , emptyDemultiplexState-    , demultiplex-    ) where--import Blaze.ByteString.Builder (Builder)-import Data.Monoid (mappend)-import qualified Blaze.ByteString.Builder as B-import qualified Data.ByteString.Lazy as BL--import Network.WebSockets.Types---- | A low-level representation of a WebSocket packet-data Frame = Frame-    { frameFin     :: !Bool-    , frameRsv1    :: !Bool-    , frameRsv2    :: !Bool-    , frameRsv3    :: !Bool-    , frameType    :: !FrameType-    , framePayload :: !BL.ByteString-    } deriving (Eq, Show)---- | The type of a frame. Not all types are allowed for all protocols.-data FrameType-    = ContinuationFrame-    | TextFrame-    | BinaryFrame-    | CloseFrame-    | PingFrame-    | PongFrame-    deriving (Eq, Show)---- | Internal state used by the demultiplexer-newtype DemultiplexState = DemultiplexState-    { unDemultiplexState :: Maybe (FrameType, Builder)-    }--emptyDemultiplexState :: DemultiplexState-emptyDemultiplexState = DemultiplexState Nothing--demultiplex :: DemultiplexState-            -> Frame-            -> (Maybe (Message p), DemultiplexState)-demultiplex state (Frame fin _ _ _ tp pl) = case tp of-    -- Return control messages immediately, they have no influence on the state-    CloseFrame  -> (Just (ControlMessage (Close pl)), state)-    PingFrame   -> (Just (ControlMessage (Ping pl)), state)-    PongFrame   -> (Just (ControlMessage (Pong pl)), state)-    -- If we're dealing with a continuation...-    ContinuationFrame -> case unDemultiplexState state of-        -- We received a continuation but we don't have any state. Let's ignore-        -- this fragment...-        Nothing -> (Nothing, DemultiplexState Nothing)-        -- Append the payload to the state-        -- TODO: protect against overflows-        Just (amt, b)-            | not fin   -> (Nothing, DemultiplexState (Just (amt, b')))-            | otherwise -> case amt of-                TextFrame   -> (Just (DataMessage (Text m)), e)-                BinaryFrame -> (Just (DataMessage (Binary m)), e)-                _           -> error "Demultiplex.demultiplex: Internal error"-          where-            b' = b `mappend` plb-            m = B.toLazyByteString b'-    TextFrame-        | fin       -> (Just (DataMessage (Text pl)), e)-        | otherwise -> (Nothing, DemultiplexState (Just (TextFrame, plb)))-    BinaryFrame-        | fin       -> (Just (DataMessage (Binary pl)), e)-        | otherwise -> (Nothing, DemultiplexState (Just (BinaryFrame, plb)))-  where-    e = emptyDemultiplexState-    plb = B.fromLazyByteString pl

− src/Network/WebSockets/Protocol/Hybi10/Internal.hs

@@ -1,215 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Network.WebSockets.Protocol.Hybi10.Internal-    ( Hybi10_ (..)-    , encodeFrameHybi10-    ) where--import Control.Applicative (pure, (<$>))-import Control.Monad (liftM)-import Data.Bits ((.&.), (.|.))-import Data.Maybe (maybeToList)-import Data.Monoid (mempty, mappend, mconcat)-import System.Random (RandomGen)--import Data.Attoparsec (anyWord8)-import Data.Binary.Get (runGet, getWord16be, getWord64be)-import Data.ByteString (ByteString, intercalate)-import Data.ByteString.Char8 ()-import Data.Digest.Pure.SHA (bytestringDigest, sha1)-import Data.Enumerator ((=$))-import Data.Int (Int64)-import qualified Blaze.ByteString.Builder as B-import qualified Data.Attoparsec as A-import qualified Data.Attoparsec.Enumerator as A-import qualified Data.ByteString.Base64 as B64-import qualified Data.ByteString.Lazy as BL-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL--import Network.WebSockets.Handshake.Http-import Network.WebSockets.Protocol-import Network.WebSockets.Protocol.Hybi10.Demultiplex-import Network.WebSockets.Protocol.Hybi10.Mask-import Network.WebSockets.Types--import System.Entropy as R--data Hybi10_ = Hybi10_--instance Protocol Hybi10_ where-    version        Hybi10_   = "hybi10"-    headerVersions Hybi10_   = ["13", "8", "7"]-    encodeMessages Hybi10_ m = EL.mapAccum (encodeMessageHybi10 m)-    decodeMessages Hybi10_   = decodeMessagesHybi10-    createRequest  Hybi10_   = createRequestHybi10-    finishRequest  Hybi10_   = handshakeHybi10-    finishResponse Hybi10_   = finishResponseHybi10-    implementations          = [Hybi10_]--instance TextProtocol Hybi10_-instance BinaryProtocol Hybi10_--encodeMessageHybi10 :: RandomGen g => Bool -> g -> Message p -> (g, B.Builder)-encodeMessageHybi10 needMask gen msg = (gen', builder)-  where-    mkFrame = Frame True False False False-    (mask, gen') = if needMask then randomMask gen else (Nothing, gen)-    builder      = encodeFrameHybi10 mask $ case msg of-        (ControlMessage (Close pl)) -> mkFrame CloseFrame  pl-        (ControlMessage (Ping pl))  -> mkFrame PingFrame   pl-        (ControlMessage (Pong pl))  -> mkFrame PongFrame   pl-        (DataMessage (Text pl))     -> mkFrame TextFrame   pl-        (DataMessage (Binary pl))   -> mkFrame BinaryFrame pl---- | Encode a frame-encodeFrameHybi10 :: Mask -> Frame -> B.Builder-encodeFrameHybi10 mask f = B.fromWord8 byte0 `mappend`-    B.fromWord8 byte1 `mappend` len `mappend` maskbytes `mappend`-    B.fromLazyByteString (maskPayload mask (framePayload f))-  where-    byte0  = fin .|. rsv1 .|. rsv2 .|. rsv3 .|. opcode-    fin    = if frameFin f  then 0x80 else 0x00-    rsv1   = if frameRsv1 f then 0x40 else 0x00-    rsv2   = if frameRsv2 f then 0x20 else 0x00-    rsv3   = if frameRsv3 f then 0x10 else 0x00-    opcode = case frameType f of-        ContinuationFrame -> 0x00-        TextFrame         -> 0x01-        BinaryFrame       -> 0x02-        CloseFrame        -> 0x08-        PingFrame         -> 0x09-        PongFrame         -> 0x0a--    (maskflag, maskbytes) = case mask of-        Nothing -> (0x00, mempty)-        Just m  -> (0x80, B.fromByteString m)--    byte1 = maskflag .|. lenflag-    len'  = BL.length (framePayload f)-    (lenflag, len)-        | len' < 126     = (fromIntegral len', mempty)-        | len' < 0x10000 = (126, B.fromWord16be (fromIntegral len'))-        | otherwise      = (127, B.fromWord64be (fromIntegral len'))--decodeMessagesHybi10 :: Monad m => E.Enumeratee ByteString (Message p) m a-decodeMessagesHybi10 =-    (E.sequence (A.iterParser parseFrame) =$) . demultiplexEnum--demultiplexEnum :: Monad m => E.Enumeratee Frame (Message p) m a-demultiplexEnum = EL.concatMapAccum step emptyDemultiplexState-  where-    step s f = let (m, s') = demultiplex s f in (s', maybeToList m)---- | Parse a frame-parseFrame :: A.Parser Frame-parseFrame = do-    byte0 <- anyWord8-    let fin    = byte0 .&. 0x80 == 0x80-        rsv1   = byte0 .&. 0x40 == 0x40-        rsv2   = byte0 .&. 0x20 == 0x20-        rsv3   = byte0 .&. 0x10 == 0x10-        opcode = byte0 .&. 0x0f--    let ft = case opcode of-            0x00 -> ContinuationFrame-            0x01 -> TextFrame-            0x02 -> BinaryFrame-            0x08 -> CloseFrame-            0x09 -> PingFrame-            0x0a -> PongFrame-            _    -> error "Unknown opcode"--    byte1 <- anyWord8-    let mask = byte1 .&. 0x80 == 0x80-        lenflag = fromIntegral (byte1 .&. 0x7f)--    len <- case lenflag of-        126 -> fromIntegral . runGet' getWord16be <$> A.take 2-        127 -> fromIntegral . runGet' getWord64be <$> A.take 8-        _   -> return lenflag--    masker <- maskPayload <$> if mask then Just <$> A.take 4 else pure Nothing--    chunks <- take64 len--    return $ Frame fin rsv1 rsv2 rsv3 ft (masker $ BL.fromChunks chunks)-  where-    runGet' g = runGet g . BL.fromChunks . return--    take64 :: Int64 -> A.Parser [ByteString]-    take64 n-        | n <= 0    = return []-        | otherwise = do-            let n' = min intMax n-            chunk <- A.take (fromIntegral n')-            (chunk :) <$> take64 (n - n')-      where-        intMax :: Int64-        intMax = fromIntegral (maxBound :: Int)--handshakeHybi10 :: Monad m-                => RequestHttpPart-                -> E.Iteratee ByteString m Request-handshakeHybi10 reqHttp@(RequestHttpPart path h _) = do-    key <- getRequestHeader reqHttp "Sec-WebSocket-Key"-    let hash = hashKeyHybi10 key-    let encoded = B64.encode hash-    return $ Request path h $ response101 [("Sec-WebSocket-Accept", encoded)] ""--createRequestHybi10 :: ByteString-                    -> ByteString-                    -> Maybe ByteString-                    -> Maybe [ByteString]-                    -> Bool-                    -> IO RequestHttpPart-createRequestHybi10 hostname path origin protocols secure = do-    key <- B64.encode `liftM`  getEntropy 16-    return $ RequestHttpPart path (headers key) secure-  where-    headers key = [("Host"                   , hostname     )-                  ,("Connection"             , "Upgrade"    )-                  ,("Upgrade"                , "websocket"  )-                  ,("Sec-WebSocket-Key"      , key          )-                  ,("Sec-WebSocket-Version"  , versionNumber)-                  ] ++ protocolHeader protocols-                    ++ originHeader origin--    originHeader (Just o)    = [("Origin"                , o                  )]-    originHeader Nothing     = []--    protocolHeader (Just ps) = [("Sec-WebSocket-Protocol", intercalate ", " ps)]-    protocolHeader Nothing   = []--    versionNumber = head . headerVersions $ Hybi10_--finishResponseHybi10 :: Monad m-                     => RequestHttpPart-                     -> ResponseHttpPart-                     -> E.Iteratee ByteString m ResponseBody-finishResponseHybi10 request response = do-    -- Response message should be one of-    ---    -- - WebSocket Protocol Handshake-    -- - Switching Protocols-    ---    -- But we don't check it for now-    if responseHttpCode response /= 101-        then throw "Wrong response status or message."-        else do-            key          <- getRequestHeader  request  "Sec-WebSocket-Key"-            responseHash <- getResponseHeader response "Sec-WebSocket-Accept"--            let challengeHash = B64.encode $ hashKeyHybi10 key-            if responseHash /= challengeHash-                then throw "Challenge and response hashes do not match."-                else return $ ResponseBody response ""-  where-    throw msg = E.throwError $ MalformedResponse response msg---hashKeyHybi10 :: ByteString -> ByteString-hashKeyHybi10 key = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid-  where-    guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"-    lazy = BL.fromChunks . return-    unlazy = mconcat . BL.toChunks

− src/Network/WebSockets/Protocol/Hybi10/Mask.hs

@@ -1,36 +0,0 @@--- | Masking of fragmes using a simple XOR algorithm-{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}-module Network.WebSockets.Protocol.Hybi10.Mask-    ( Mask-    , maskPayload-    , randomMask-    ) where--import Data.Bits (shiftR, xor)-import System.Random (RandomGen, random)--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL---- | ByteString should be exactly 4 bytes long-type Mask = Maybe B.ByteString---- | Apply mask-maskPayload :: Mask -> BL.ByteString -> BL.ByteString-maskPayload Nothing     = id-maskPayload (Just mask) = snd . BL.mapAccumL f 0-  where-    len = B.length mask-    f !i !c = let i' = (i + 1) `mod` len-                  m = mask `B.index` i-              in (i', m `xor` c)---- | Create a random mask-randomMask :: forall g. RandomGen g => g -> (Mask, g)-randomMask gen = (Just (B.pack [b1, b2, b3, b4]), gen')-  where-    (!int, !gen') = random gen :: (Int, g)-    !b1           = fromIntegral $ int `mod` 0x100-    !b2           = fromIntegral $ int `shiftR` 8  `mod` 0x100-    !b3           = fromIntegral $ int `shiftR` 16 `mod` 0x100-    !b4           = fromIntegral $ int `shiftR` 24 `mod` 0x100

− src/Network/WebSockets/Protocol/Unsafe.hs

@@ -1,35 +0,0 @@-module Network.WebSockets.Protocol.Unsafe-    ( castMessage-    , close-    , ping-    , pong-    , textData-    , binaryData-    ) where--import Network.WebSockets.Types--castMessage :: Message p1 -> Message p2-castMessage (ControlMessage m) = ControlMessage $ case m of-    Close b -> Close b-    Ping b  -> Ping b-    Pong b  -> Pong b-castMessage (DataMessage m)    = DataMessage $ case m of-    Text b   -> Text b-    Binary b -> Binary b-{-# INLINE castMessage #-}--close :: WebSocketsData a => a -> Message p-close = ControlMessage . Close . toLazyByteString--ping :: WebSocketsData a => a -> Message p-ping = ControlMessage . Ping . toLazyByteString--pong :: WebSocketsData a => a -> Message p-pong = ControlMessage . Pong . toLazyByteString--textData :: WebSocketsData a => a -> Message p-textData = DataMessage . Text . toLazyByteString--binaryData :: WebSocketsData a => a -> Message p-binaryData = DataMessage . Binary . toLazyByteString

+ src/Network/WebSockets/Server.hs view

@@ -0,0 +1,81 @@+--------------------------------------------------------------------------------+-- | This provides a simple stand-alone server for 'WebSockets' applications.+-- Note that in production you want to use a real webserver such as snap or+-- warp.+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Server+    ( ServerApp+    , runServer+    , runServerWith+    ) where+++--------------------------------------------------------------------------------+import           Control.Concurrent            (forkIO)+import           Control.Exception             (finally)+import           Control.Monad                 (forever)+import           Network.Socket                (Socket)+import qualified Network.Socket                as S+import qualified System.IO.Streams.Attoparsec  as Streams+import qualified System.IO.Streams.Builder     as Streams+import qualified System.IO.Streams.Network     as Streams+++--------------------------------------------------------------------------------+import           Network.WebSockets.Connection+import           Network.WebSockets.Http+++--------------------------------------------------------------------------------+-- | WebSockets application that can be ran by a server. Once this 'IO' action+-- finishes, the underlying socket is closed automatically.+type ServerApp = PendingConnection -> IO ()+++--------------------------------------------------------------------------------+-- | Provides a simple server. This function blocks forever. Note that this+-- is merely provided for quick-and-dirty standalone applications, for real+-- applications, you should use a real server.+runServer :: String     -- ^ Address to bind+          -> Int        -- ^ Port to listen on+          -> ServerApp  -- ^ Application+          -> IO ()      -- ^ Never returns+runServer host port app = runServerWith host port defaultConnectionOptions app+++--------------------------------------------------------------------------------+-- | A version of 'runServer' which allows you to customize some options.+runServerWith :: String -> Int -> ConnectionOptions -> ServerApp -> IO ()+runServerWith host port opts app = S.withSocketsDo $ do+    sock  <- S.socket S.AF_INET S.Stream S.defaultProtocol+    _     <- S.setSocketOption sock S.ReuseAddr 1+    host' <- S.inet_addr host+    S.bindSocket sock (S.SockAddrInet (fromIntegral port) host')+    S.listen sock 5+    _ <- forever $ do+        -- TODO: top level handle+        (conn, _) <- S.accept sock+        _         <- forkIO $ finally (runApp conn opts app) (S.sClose conn)+        return ()+    S.sClose sock+++--------------------------------------------------------------------------------+runApp :: Socket+       -> ConnectionOptions+       -> ServerApp+       -> IO ()+runApp socket opts app = do+    (sIn, sOut) <- Streams.socketToStreams socket+    bOut        <- Streams.builderStream sOut+    -- TODO: we probably want to send a 40x if the request is bad?+    request     <- Streams.parseFromStream (decodeRequestHead False) sIn+    let pc = PendingConnection+                { pendingOptions  = opts+                , pendingRequest  = request+                , pendingOnAccept = \_ -> return ()+                , pendingIn       = sIn+                , pendingOut      = bOut+                }++    app pc

− src/Network/WebSockets/Socket.hs

@@ -1,76 +0,0 @@--- | Simple module which provides the low-level socket handling in case you want--- to write a stand-alone 'WebSockets' application.-{-# LANGUAGE OverloadedStrings #-}-module Network.WebSockets.Socket-    ( runServer-    , runWithSocket-    , iterSocket-    ) where--import Control.Concurrent (forkIO)-import Control.Exception (SomeException, handle)-import Control.Monad (forever)-import Control.Monad.Trans (liftIO)--import Data.ByteString (ByteString)-import Data.Enumerator (Iteratee, ($$))-import Network.Socket (Socket)-import qualified Data.Enumerator as E-import qualified Network.Socket as S-import qualified Network.Socket.ByteString as SB-import qualified Network.Socket.Enumerator as SE--import Network.WebSockets.Handshake.Http-import Network.WebSockets.Monad-import Network.WebSockets.Protocol-import Network.WebSockets.Types---- | Provides a simple server. This function blocks forever. Note that this--- is merely provided for quick-and-dirty standalone applications, for real--- applications, you should use a real server.-runServer :: Protocol p-          => String                        -- ^ Address to bind to-          -> Int                           -- ^ Port to listen on-          -> (Request -> WebSockets p ())  -- ^ Application to serve-          -> IO ()                         -- ^ Never returns-runServer host port ws = S.withSocketsDo $ do-    sock <- S.socket S.AF_INET S.Stream S.defaultProtocol-    _ <- S.setSocketOption sock S.ReuseAddr 1-    host' <- S.inet_addr host-    S.bindSocket sock (S.SockAddrInet (fromIntegral port) host')-    S.listen sock 5-    handle (closeSock sock) $ forever $ do-        (conn, _) <- S.accept sock-        -- Voodoo fix: set this to True as soon as we notice the connection was-        -- closed. Will prevent iterSocket' from even trying to send anything.-        -- Without it, we got many "Couldn't decode text frame as UTF8" errors-        -- in the browser (although the payload is definitely UTF8).-        -- killRef <- newIORef False-        _ <- forkIO $ runWithSocket conn ws >> return ()-        return ()-  where-    closeSock :: Socket -> SomeException -> IO ()-    closeSock sock _ = S.sClose sock---- | This function wraps 'runWebSockets' in order to provide a simple API for--- stand-alone servers.-runWithSocket :: Protocol p-              => Socket -> (Request -> WebSockets p a) -> IO a-runWithSocket s ws = do-    r <- E.run $ SE.enumSocket 4096 s $$ runWebSocketsWithHandshake-        defaultWebSocketsOptions False ws (iterSocket s)-    S.sClose s-    either (error . show) return r---- | Create an iterator which writes to a socket. Throws a 'ConnectionClosed'--- exception if the user attempts to write to a closed socket.-iterSocket :: Socket -> Iteratee ByteString IO ()-iterSocket s = E.continue go-  where-    go (E.Chunks []) = E.continue go-    go (E.Chunks cs) = do-        b <- liftIO $ S.sIsWritable s-        if b-            then E.tryIO (SB.sendMany s cs) >> E.continue go-            else E.throwError ConnectionClosed-    go E.EOF         = E.continue go

src/Network/WebSockets/Types.hs view

@@ -1,3 +1,4 @@+-------------------------------------------------------------------------------- -- | Primary types {-# LANGUAGE DeriveDataTypeable #-} module Network.WebSockets.Types@@ -6,54 +7,55 @@     , DataMessage (..)     , WebSocketsData (..) -    , ConnectionError (..)+    , HandshakeException (..)+    , ConnectionException (..)++    , ConnectionType (..)     ) where -import Control.Exception (Exception(..))-import Data.Typeable (Typeable) -import qualified Data.Attoparsec.Enumerator as AE-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL+--------------------------------------------------------------------------------+import           Control.Exception       (Exception (..))+import qualified Data.ByteString         as B+import qualified Data.ByteString.Lazy    as BL+import qualified Data.Text               as T+import qualified Data.Text.Lazy          as TL import qualified Data.Text.Lazy.Encoding as TL+import           Data.Typeable           (Typeable) --- | The connection couldn't be established or broke down unexpectedly. thrown--- as an iteratee exception.-data ConnectionError-    -- | The client sent malformed data.-    = ParseError AE.ParseError-    -- | the client closed the connection while-    -- we were trying to receive some data.-    ---    -- todo: Also want this for sending.-    | ConnectionClosed              -    deriving (Show, Typeable) -instance Exception ConnectionError+--------------------------------------------------------------------------------+import           Network.WebSockets.Http ++-------------------------------------------------------------------------------- -- | The kind of message a server application typically deals with-data Message p-    = ControlMessage (ControlMessage p)-    | DataMessage    (DataMessage p)+data Message+    = ControlMessage ControlMessage+    | DataMessage DataMessage     deriving (Eq, Show) ++-------------------------------------------------------------------------------- -- | Different control messages-data ControlMessage p+data ControlMessage     = Close BL.ByteString     | Ping BL.ByteString     | Pong BL.ByteString     deriving (Eq, Show) ++-------------------------------------------------------------------------------- -- | For an end-user of this library, dealing with 'Frame's would be a bit -- low-level. This is why define another type on top of it, which represents -- data for the application layer.-data DataMessage p+data DataMessage     = Text BL.ByteString     | Binary BL.ByteString     deriving (Eq, Show) ++-------------------------------------------------------------------------------- -- | In order to have an even more high-level API, we define a typeclass for -- values the user can receive from and send to the socket. A few warnings -- apply:@@ -71,18 +73,47 @@     fromLazyByteString :: BL.ByteString -> a     toLazyByteString   :: a -> BL.ByteString ++-------------------------------------------------------------------------------- instance WebSocketsData BL.ByteString where     fromLazyByteString = id     toLazyByteString   = id ++-------------------------------------------------------------------------------- instance WebSocketsData B.ByteString where     fromLazyByteString = B.concat . BL.toChunks     toLazyByteString   = BL.fromChunks . return ++-------------------------------------------------------------------------------- instance WebSocketsData TL.Text where     fromLazyByteString = TL.decodeUtf8     toLazyByteString   = TL.encodeUtf8 ++-------------------------------------------------------------------------------- instance WebSocketsData T.Text where     fromLazyByteString = T.concat . TL.toChunks . fromLazyByteString     toLazyByteString   = toLazyByteString . TL.fromChunks . return+++--------------------------------------------------------------------------------+-- | The connection couldn't be established or broke down unexpectedly. thrown+-- as an iteratee exception.+data ConnectionException+    -- | the client unexpectedly closed the connection while we were trying to+    -- receive some data.+    --+    -- todo: Also want this for sending.+    = ConnectionClosed+    deriving (Show, Typeable)+++--------------------------------------------------------------------------------+instance Exception ConnectionException+++--------------------------------------------------------------------------------+data ConnectionType = ServerConnection | ClientConnection+    deriving (Eq, Ord, Show)

− src/Network/WebSockets/Util/PubSub.hs

@@ -1,79 +0,0 @@--- | This is a simple utility module to implement a publish-subscribe pattern.--- Note that this only allows communication in a single direction: pusing data--- from the server to connected clients (browsers).------ Usage:------ * Create a new 'PubSub' handle using 'newPubSub'------ * Subscribe your clients using the 'subscribe' call------ * Push new updates from the server using the 'publish' call----{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}-module Network.WebSockets.Util.PubSub-    ( PubSub-    , newPubSub-    , publish-    , subscribe-    ) where--import Control.Applicative ((<$>))-import Control.Exception (IOException, handle)-import Control.Monad (foldM, forever)-import Control.Monad.Trans (liftIO)-import Data.IntMap (IntMap)-import Data.List (foldl')-import qualified Control.Concurrent.MVar as MV--import qualified Data.IntMap as IM--import Network.WebSockets--data PubSub_ p = PubSub_-    { pubSubNextId :: Int-    , pubSubSinks  :: IntMap (Sink p)-    }--addClient :: Sink p -> PubSub_ p -> (PubSub_ p, Int)-addClient sink (PubSub_ nid sinks) =-    (PubSub_ (nid + 1) (IM.insert nid sink sinks), nid)--removeClient :: Int -> PubSub_ p -> PubSub_ p-removeClient ref ps = ps {pubSubSinks = IM.delete ref (pubSubSinks ps)}---- | A handle which keeps track of subscribed clients-newtype PubSub p = PubSub (MV.MVar (PubSub_ p))---- | Create a new 'PubSub' handle, with no clients initally connected-newPubSub :: IO (PubSub p)-newPubSub = PubSub <$> MV.newMVar PubSub_-    { pubSubNextId  = 0-    , pubSubSinks  = IM.empty-    }---- | Broadcast a message to all connected clients-publish :: PubSub p -> Message p -> IO ()-publish (PubSub mvar) msg = MV.modifyMVar_ mvar $ \pubSub -> do-    -- Take care to detect and remove broken clients-    broken <- foldM publish' [] (IM.toList $ pubSubSinks pubSub)-    return $ foldl' (\p b -> removeClient b p) pubSub broken-  where-    -- Publish the message to a single client, add it to the broken list if an-    -- IOException occurs-    publish' broken (i, s) =-        handle (\(_ :: IOException) -> return (i : broken)) $ do-            sendSink s msg-            return broken---- | Blocks forever-subscribe :: Protocol p => PubSub p -> WebSockets p ()-subscribe (PubSub mvar) = do-    sink <- getSink-    ref  <- liftIO $ MV.modifyMVar mvar $ return . addClient sink-    catchWsError loop $ const $ liftIO $-        MV.modifyMVar_ mvar $ return . removeClient ref-  where-    loop = forever $ do-        _ <- receiveDataMessage-        return ()

tests/haskell/TestSuite.hs view

@@ -1,14 +1,19 @@-import Test.Framework (defaultMain)+--------------------------------------------------------------------------------+import           Test.Framework                     (defaultMain) -import qualified Network.WebSockets.Tests-import qualified Network.WebSockets.Handshake.Http.Tests++-------------------------------------------------------------------------------- import qualified Network.WebSockets.Handshake.Tests-import qualified Network.WebSockets.Socket.Tests+import qualified Network.WebSockets.Http.Tests+import qualified Network.WebSockets.Server.Tests+import qualified Network.WebSockets.Tests ++-------------------------------------------------------------------------------- main :: IO () main = defaultMain-    [ Network.WebSockets.Tests.tests-    , Network.WebSockets.Handshake.Http.Tests.tests-    , Network.WebSockets.Handshake.Tests.tests-    , Network.WebSockets.Socket.Tests.tests+    [ Network.WebSockets.Handshake.Tests.tests+    , Network.WebSockets.Http.Tests.tests+    , Network.WebSockets.Server.Tests.tests+    , Network.WebSockets.Tests.tests     ]

websockets.cabal view

@@ -1,5 +1,5 @@ Name:    websockets-Version: 0.7.4.1+Version: 0.8.0.0  Synopsis:   A sensible and clean way to write WebSocket-capable servers in Haskell.@@ -7,10 +7,11 @@ Description:  This library allows you to write WebSocket-capable servers.  .- See an example: <http://jaspervdj.be/websockets/example.html>.+ An example server:+ <https://github.com/jaspervdj/websockets/blob/master/example/server.lhs>  .- The API of the 'Network.WebSockets' module should also contain enough- information to get you started.+ An example client:+ <https://github.com/jaspervdj/websockets/blob/master/example/client.hs>  .  See also:  .@@ -45,45 +46,35 @@    Exposed-modules:     Network.WebSockets-    Network.WebSockets.Internal-    Network.WebSockets.Util.PubSub+    Network.WebSockets.Connection+    -- Network.WebSockets.Util.PubSub TODO    Other-modules:     Network.WebSockets.Client-    Network.WebSockets.Handshake-    Network.WebSockets.Handshake.Http-    Network.WebSockets.Monad+    Network.WebSockets.Http+    Network.WebSockets.Hybi13+    Network.WebSockets.Hybi13.Demultiplex+    Network.WebSockets.Hybi13.Mask     Network.WebSockets.Protocol-    Network.WebSockets.Protocol.Hybi00-    Network.WebSockets.Protocol.Hybi00.Internal-    Network.WebSockets.Protocol.Hybi10-    Network.WebSockets.Protocol.Hybi10.Demultiplex-    Network.WebSockets.Protocol.Hybi10.Internal-    Network.WebSockets.Protocol.Hybi10.Mask-    Network.WebSockets.Protocol.Unsafe-    Network.WebSockets.Socket+    Network.WebSockets.Server     Network.WebSockets.Types    Build-depends:-    attoparsec               >= 0.9    && < 0.11,-    attoparsec-enumerator    >= 0.2    && < 0.4,-    base                     >= 4      && < 5,-    base64-bytestring        >= 0.1    && < 1.1,-    binary                   >= 0.5    && < 0.8,-    blaze-builder            >= 0.3    && < 0.4,-    blaze-builder-enumerator >= 0.2    && < 0.3,-    bytestring               >= 0.9    && < 0.11,-    case-insensitive         >= 0.3    && < 1.2,-    containers               >= 0.3    && < 0.6,-    enumerator               >= 0.4.13 && < 0.5,-    mtl                      >= 2.0    && < 2.2,-    network                  >= 2.3    && < 2.5,-    network-enumerator       >= 0.1    && < 0.2,-    random                   >= 1.0    && < 1.1,-    SHA                      >= 1.5    && < 1.7,-    text                     >= 0.10   && < 0.12,-    pureMD5                  >= 0.2.2  && < 2.2,-    entropy                  >= 0.2.1  && < 0.3+    attoparsec        >= 0.9    && < 0.11,+    base              >= 4      && < 5,+    base64-bytestring >= 0.1    && < 1.1,+    binary            >= 0.5    && < 0.8,+    blaze-builder     >= 0.3    && < 0.4,+    bytestring        >= 0.9    && < 0.11,+    case-insensitive  >= 0.3    && < 1.2,+    containers        >= 0.3    && < 0.6,+    io-streams        >= 1.1    && < 1.2,+    mtl               >= 2.0    && < 2.2,+    network           >= 2.3    && < 2.5,+    random            >= 1.0    && < 1.1,+    SHA               >= 1.5    && < 1.7,+    text              >= 0.10   && < 0.12,+    entropy           >= 0.2.1  && < 0.3  Test-suite websockets-tests   Type:           exitcode-stdio-1.0@@ -98,25 +89,21 @@     test-framework-hunit       >= 0.2 && < 0.4,     test-framework-quickcheck2 >= 0.2 && < 0.4,     -- Copied from regular dependencies...-    attoparsec               >= 0.9    && < 0.11,-    attoparsec-enumerator    >= 0.2    && < 0.4,-    base                     >= 4      && < 5,-    base64-bytestring        >= 0.1    && < 1.1,-    binary                   >= 0.5    && < 0.8,-    blaze-builder            >= 0.3    && < 0.4,-    blaze-builder-enumerator >= 0.2    && < 0.3,-    bytestring               >= 0.9    && < 0.11,-    case-insensitive         >= 0.3    && < 1.2,-    containers               >= 0.3    && < 0.6,-    enumerator               >= 0.4.13 && < 0.5,-    mtl                      >= 2.0    && < 2.2,-    network                  >= 2.3    && < 2.5,-    network-enumerator       >= 0.1    && < 0.2,-    random                   >= 1.0    && < 1.1,-    SHA                      >= 1.5    && < 1.7,-    text                     >= 0.10   && < 0.12,-    pureMD5                  >= 0.2.2  && < 2.2,-    entropy                  >= 0.2.1  && < 0.3+    attoparsec        >= 0.9    && < 0.11,+    base              >= 4      && < 5,+    base64-bytestring >= 0.1    && < 1.1,+    binary            >= 0.5    && < 0.8,+    blaze-builder     >= 0.3    && < 0.4,+    bytestring        >= 0.9    && < 0.11,+    case-insensitive  >= 0.3    && < 1.2,+    containers        >= 0.3    && < 0.6,+    io-streams        >= 1.1    && < 1.2,+    mtl               >= 2.0    && < 2.2,+    network           >= 2.3    && < 2.5,+    random            >= 1.0    && < 1.1,+    SHA               >= 1.5    && < 1.7,+    text              >= 0.10   && < 0.12,+    entropy           >= 0.2.1  && < 0.3  Source-repository head   Type:     git