diff --git a/src/Network/WebSockets.hs b/src/Network/WebSockets.hs --- a/src/Network/WebSockets.hs +++ b/src/Network/WebSockets.hs @@ -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: --- --- +-------------------------------------------------------------------------------- {-# 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 diff --git a/src/Network/WebSockets/Client.hs b/src/Network/WebSockets/Client.hs --- a/src/Network/WebSockets/Client.hs +++ b/src/Network/WebSockets/Client.hs @@ -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 diff --git a/src/Network/WebSockets/Connection.hs b/src/Network/WebSockets/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Connection.hs @@ -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 diff --git a/src/Network/WebSockets/Handshake.hs b/src/Network/WebSockets/Handshake.hs deleted file mode 100644 --- a/src/Network/WebSockets/Handshake.hs +++ /dev/null @@ -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]))] diff --git a/src/Network/WebSockets/Handshake/Http.hs b/src/Network/WebSockets/Handshake/Http.hs deleted file mode 100644 --- a/src/Network/WebSockets/Handshake/Http.hs +++ /dev/null @@ -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) diff --git a/src/Network/WebSockets/Http.hs b/src/Network/WebSockets/Http.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Http.hs @@ -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" diff --git a/src/Network/WebSockets/Hybi13.hs b/src/Network/WebSockets/Hybi13.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Hybi13.hs @@ -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 diff --git a/src/Network/WebSockets/Hybi13/Demultiplex.hs b/src/Network/WebSockets/Hybi13/Demultiplex.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Hybi13/Demultiplex.hs @@ -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 diff --git a/src/Network/WebSockets/Hybi13/Mask.hs b/src/Network/WebSockets/Hybi13/Mask.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Hybi13/Mask.hs @@ -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 diff --git a/src/Network/WebSockets/Internal.hs b/src/Network/WebSockets/Internal.hs deleted file mode 100644 --- a/src/Network/WebSockets/Internal.hs +++ /dev/null @@ -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 diff --git a/src/Network/WebSockets/Monad.hs b/src/Network/WebSockets/Monad.hs deleted file mode 100644 --- a/src/Network/WebSockets/Monad.hs +++ /dev/null @@ -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 diff --git a/src/Network/WebSockets/Protocol.hs b/src/Network/WebSockets/Protocol.hs --- a/src/Network/WebSockets/Protocol.hs +++ b/src/Network/WebSockets/Protocol.hs @@ -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 diff --git a/src/Network/WebSockets/Protocol/Hybi00.hs b/src/Network/WebSockets/Protocol/Hybi00.hs deleted file mode 100644 --- a/src/Network/WebSockets/Protocol/Hybi00.hs +++ /dev/null @@ -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 diff --git a/src/Network/WebSockets/Protocol/Hybi00/Internal.hs b/src/Network/WebSockets/Protocol/Hybi00/Internal.hs deleted file mode 100644 --- a/src/Network/WebSockets/Protocol/Hybi00/Internal.hs +++ /dev/null @@ -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" diff --git a/src/Network/WebSockets/Protocol/Hybi10.hs b/src/Network/WebSockets/Protocol/Hybi10.hs deleted file mode 100644 --- a/src/Network/WebSockets/Protocol/Hybi10.hs +++ /dev/null @@ -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 diff --git a/src/Network/WebSockets/Protocol/Hybi10/Demultiplex.hs b/src/Network/WebSockets/Protocol/Hybi10/Demultiplex.hs deleted file mode 100644 --- a/src/Network/WebSockets/Protocol/Hybi10/Demultiplex.hs +++ /dev/null @@ -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 diff --git a/src/Network/WebSockets/Protocol/Hybi10/Internal.hs b/src/Network/WebSockets/Protocol/Hybi10/Internal.hs deleted file mode 100644 --- a/src/Network/WebSockets/Protocol/Hybi10/Internal.hs +++ /dev/null @@ -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 diff --git a/src/Network/WebSockets/Protocol/Hybi10/Mask.hs b/src/Network/WebSockets/Protocol/Hybi10/Mask.hs deleted file mode 100644 --- a/src/Network/WebSockets/Protocol/Hybi10/Mask.hs +++ /dev/null @@ -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 diff --git a/src/Network/WebSockets/Protocol/Unsafe.hs b/src/Network/WebSockets/Protocol/Unsafe.hs deleted file mode 100644 --- a/src/Network/WebSockets/Protocol/Unsafe.hs +++ /dev/null @@ -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 diff --git a/src/Network/WebSockets/Server.hs b/src/Network/WebSockets/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Server.hs @@ -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 diff --git a/src/Network/WebSockets/Socket.hs b/src/Network/WebSockets/Socket.hs deleted file mode 100644 --- a/src/Network/WebSockets/Socket.hs +++ /dev/null @@ -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 diff --git a/src/Network/WebSockets/Types.hs b/src/Network/WebSockets/Types.hs --- a/src/Network/WebSockets/Types.hs +++ b/src/Network/WebSockets/Types.hs @@ -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) diff --git a/src/Network/WebSockets/Util/PubSub.hs b/src/Network/WebSockets/Util/PubSub.hs deleted file mode 100644 --- a/src/Network/WebSockets/Util/PubSub.hs +++ /dev/null @@ -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 () diff --git a/tests/haskell/TestSuite.hs b/tests/haskell/TestSuite.hs --- a/tests/haskell/TestSuite.hs +++ b/tests/haskell/TestSuite.hs @@ -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 ] diff --git a/websockets.cabal b/websockets.cabal --- a/websockets.cabal +++ b/websockets.cabal @@ -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: . + An example server: + . - The API of the 'Network.WebSockets' module should also contain enough - information to get you started. + An example client: + . 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