twentefp-websockets (empty) → 0.1.0.0
raw patch · 13 files changed
+1541/−0 lines, 13 filesdep +SHAdep +attoparsecdep +basesetup-changed
Dependencies added: SHA, attoparsec, base, base64-bytestring, binary, blaze-builder, bytestring, case-insensitive, containers, entropy, io-streams, mtl, network, random, text
Files
- LICENCE +30/−0
- Setup.hs +2/−0
- src/Network/WebSockets.hs +71/−0
- src/Network/WebSockets/Client.hs +125/−0
- src/Network/WebSockets/Connection.hs +295/−0
- src/Network/WebSockets/Http.hs +255/−0
- src/Network/WebSockets/Hybi13.hs +241/−0
- src/Network/WebSockets/Hybi13/Demultiplex.hs +117/−0
- src/Network/WebSockets/Hybi13/Mask.hs +46/−0
- src/Network/WebSockets/Protocol.hs +85/−0
- src/Network/WebSockets/Server.hs +81/−0
- src/Network/WebSockets/Types.hs +129/−0
- twentefp-websockets.cabal +64/−0
+ LICENCE view
@@ -0,0 +1,30 @@+Copyright Jasper Van der Jeugt, 2011 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Siniša Biđin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ src/Network/WebSockets.hs view
@@ -0,0 +1,71 @@+-------------------------------------------------------------------------------- +{-# LANGUAGE ScopedTypeVariables #-} +module Network.WebSockets + ( -- * Incoming connections and handshaking + makeSocket + , closeSocket + , PendingConnection + , makePendingConnection + , pendingRequest + , AcceptRequest(..) + , acceptRequest + , acceptRequestWith + , rejectRequest + + -- * Main connection type + , Connection + + -- * Options for connections + , ConnectionOptions (..) + , defaultConnectionOptions + + -- * Sending and receiving messages + , receive + , receiveDataMessage + , receiveData + , send + , sendDataMessage + , sendTextData + , sendBinaryData + , sendClose + , sendPing + + -- * HTTP Types + , Headers + , Request (..) + , RequestHead (..) + , getRequestSubprotocols + , Response (..) + , ResponseHead (..) + + -- * WebSocket message types + , Message (..) + , ControlMessage (..) + , DataMessage (..) + , WebSocketsData (..) + + -- * Exceptions + , HandshakeException (..) + , ConnectionException (..) + + + -- * Running a standalone server + , ServerApp + , runServer + , runServerWith + + -- * Running a client + , ClientApp + , runClient + , runClientWith + , runClientWithSocket + , runClientWithStream + ) where + + +-------------------------------------------------------------------------------- +import Network.WebSockets.Client +import Network.WebSockets.Connection +import Network.WebSockets.Http +import Network.WebSockets.Server +import Network.WebSockets.Types
+ src/Network/WebSockets/Client.hs view
@@ -0,0 +1,125 @@+-------------------------------------------------------------------------------- +-- | This part of the library provides you with utilities to create WebSockets +-- clients (in addition to servers). +module Network.WebSockets.Client + ( ClientApp + , runClient + , runClientWith + , runClientWithSocket + , runClientWithStream + ) where + + +-------------------------------------------------------------------------------- +import qualified Blaze.ByteString.Builder as Builder +import Control.Exception (finally) +import qualified Data.ByteString as B +import Data.IORef (newIORef) +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.Connection +import Network.WebSockets.Http +import Network.WebSockets.Protocol +import Network.WebSockets.Types + + +-------------------------------------------------------------------------------- +-- | 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 + + +-------------------------------------------------------------------------------- +-- 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} + addrInfos <- S.getAddrInfo (Just hints) (Just host) (Just $ show port) + sock <- S.socket S.AF_INET S.Stream S.defaultProtocol + + -- Connect WebSocket and run client + res <- finally + (S.connect sock (S.addrAddress $ head addrInfos) >> + runClientWithSocket sock host path opts customHeaders app) + (S.sClose sock) + + -- Clean up + return res + + +-------------------------------------------------------------------------------- +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 + sentRef <- newIORef False + app Connection + { connectionOptions = opts + , connectionType = ClientConnection + , connectionProtocol = protocol + , connectionIn = mIn + , connectionOut = mOut + , connectionSentClose = sentRef + } + where + protocol = defaultProtocol -- TODO + bHost = T.encodeUtf8 $ T.pack host + bPath = T.encodeUtf8 $ T.pack path + + +-------------------------------------------------------------------------------- +runClientWithSocket :: S.Socket -- ^ Socket + -> String -- ^ Host + -> String -- ^ Path + -> ConnectionOptions -- ^ Options + -> Headers -- ^ Custom headers to send + -> ClientApp a -- ^ Client application + -> IO a +runClientWithSocket sock host path opts customHeaders app = do + stream <- Streams.socketToStreams sock + runClientWithStream stream host path opts customHeaders app
+ src/Network/WebSockets/Connection.hs view
@@ -0,0 +1,295 @@+-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +module Network.WebSockets.Connection + ( makeSocket + , closeSocket + , PendingConnection (..) + , makePendingConnection + , AcceptRequest(..) + , acceptRequest + , acceptRequestWith + , rejectRequest + + , Connection (..) + + , ConnectionOptions (..) + , defaultConnectionOptions + + , receive + , receiveDataMessage + , receiveData + , send + , sendDataMessage + , sendTextData + , sendBinaryData + , sendClose + , sendCloseCode + , sendPing + ) where + + +-------------------------------------------------------------------------------- +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder as Builder +import Control.Exception (throw) +import Control.Monad (unless) +import qualified Data.ByteString as B +import Data.List (find) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Word (Word16) +import System.IO.Streams (InputStream, OutputStream) +import qualified System.IO.Streams as Streams +import qualified System.IO.Streams.Attoparsec as Streams +import Network.Socket (Socket) +import qualified Network.Socket as S + + +-------------------------------------------------------------------------------- +import Network.WebSockets.Http +import Network.WebSockets.Protocol +import Network.WebSockets.Types + + + +-------------------------------------------------------------------------------- +-- | Create a standardized socket. Should only be used for a quick and dirty solution! +-- Should be preceded by the call Network.Socket.withSocketsDo + +makeSocket :: String -> Int -> IO Socket +makeSocket host port = 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 + return sock + +-------------------------------------------------------------------------------- +-- | Closes a socket. This function serves as a quick utility to close a socket and +-- as a reminder that you need to close sockets made by makeSocket. +closeSocket :: Socket -> IO () +closeSocket sock = S.sClose sock + +-------------------------------------------------------------------------------- +-- | 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 + } + +-------------------------------------------------------------------------------- +-- | Use data from the socket to create a Pending Connection. This is a blocking +-- function. It tries to first accept a connection before creating a pending +-- connection. Then you are able to choose if you want to accept the connection +-- or not. +makePendingConnection :: Socket -> IO PendingConnection +makePendingConnection sock = do + (conn, _) <- S.accept sock + (sIn, sOut) <- Streams.socketToStreams conn + 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 = defaultConnectionOptions + , pendingRequest = request + , pendingOnAccept = \_ -> return () + , pendingIn = sIn + , pendingOut = bOut + } + return pc + +-------------------------------------------------------------------------------- +data AcceptRequest = AcceptRequest + { acceptSubprotocol :: Maybe B.ByteString + -- ^ The subprotocol to speak with the client. If 'pendingSubprotcols' is + -- non-empty, 'acceptSubprotocol' must be one of the subprotocols from the list. + } + + +-------------------------------------------------------------------------------- +-- | 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 = acceptRequestWith pc $ AcceptRequest Nothing + + +-------------------------------------------------------------------------------- +acceptRequestWith :: PendingConnection -> AcceptRequest -> IO Connection +acceptRequestWith pc ar = case find (flip compatible request) protocols of + Nothing -> do + sendResponse pc $ response400 versionHeader "" + throw NotSupported + Just protocol -> do + let subproto = maybe [] (\p -> [("Sec-WebSocket-Protocol", p)]) $ acceptSubprotocol ar + response = finishRequest protocol request subproto + sendResponse pc response + msgIn <- decodeMessages protocol (pendingIn pc) + msgOut <- encodeMessages protocol ServerConnection (pendingOut pc) + sentRef <- newIORef False + let connection = Connection + { connectionOptions = pendingOptions pc + , connectionType = ServerConnection + , connectionProtocol = protocol + , connectionIn = msgIn + , connectionOut = msgOut + , connectionSentClose = sentRef + } + + 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 + , connectionSentClose :: IORef Bool + -- ^ According to the RFC, both the client and the server MUST send + -- a close control message to each other. Either party can initiate + -- the first close message but then the other party must respond. Finally, + -- the server is in charge of closing the TCP connection. This IORef tracks + -- if we have sent a close message and are waiting for the peer to respond. + } + + +-------------------------------------------------------------------------------- +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. +-- +-- When the peer sends a close control message, an exception of type 'CloseRequest' +-- is thrown. The peer can send a close control message either to initiate a +-- close or in response to a close message we have sent to the peer. In either +-- case the 'CloseRequest' exception will be thrown. The RFC specifies that +-- the server is responsible for closing the TCP connection, which should happen +-- after receiving the 'CloseRequest' exception from this function. +-- +-- This will throw 'ConnectionClosed' if the TCP connection dies unexpectedly. +receiveDataMessage :: Connection -> IO DataMessage +receiveDataMessage conn = do + msg <- receive conn + case msg of + DataMessage am -> return am + ControlMessage cm -> case cm of + Close i closeMsg -> do + hasSentClose <- readIORef $ connectionSentClose conn + unless hasSentClose $ send conn msg + throw $ CloseRequest i closeMsg + 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 = do + case msg of + (ControlMessage (Close _ _)) -> writeIORef (connectionSentClose conn) True + _ -> return () + 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. Note that after sending this message, +-- you should still continue calling 'receiveDataMessage' to process any +-- in-flight messages. The peer will eventually respond with a close control +-- message of its own which will cause 'receiveDataMessage' to throw the +-- 'CloseRequest' exception. This exception is when you can finally consider +-- the connection closed. +sendClose :: WebSocketsData a => Connection -> a -> IO () +sendClose conn = sendCloseCode conn 1000 + + +-------------------------------------------------------------------------------- +-- | Send a friendly close message and close code. Similar to 'sendClose', you should +-- continue calling 'receiveDataMessage' until you receive a 'CloseRequest' exception. +-- See <http://tools.ietf.org/html/rfc6455#section-7.4> for a list of close +-- codes. +sendCloseCode :: WebSocketsData a => Connection -> Word16 -> a -> IO () +sendCloseCode conn code = + send conn . ControlMessage . Close code . toLazyByteString + + +-------------------------------------------------------------------------------- +-- | Send a ping +sendPing :: WebSocketsData a => Connection -> a -> IO () +sendPing conn = send conn . ControlMessage . Ping . toLazyByteString
+ src/Network/WebSockets/Http.hs view
@@ -0,0 +1,255 @@+-------------------------------------------------------------------------------- +-- | 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 + , getRequestSubprotocols + ) 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) + + +-------------------------------------------------------------------------------- +-- | List of subprotocols specified by the client, in order of preference. +-- If the client did not specify a list of subprotocols, this will be the +-- empty list. +getRequestSubprotocols :: RequestHead -> [B.ByteString] +getRequestSubprotocols rh = maybe [] parse mproto + where + mproto = lookup "Sec-WebSocket-Protocol" $ requestHeaders rh + parse = filter (not . B.null) . BC.splitWith (\o -> o == ',' || o == ' ') + + +-------------------------------------------------------------------------------- +decodeHeaderLine :: A.Parser (CI.CI ByteString, ByteString) +decodeHeaderLine = (,) + <$> (CI.mk <$> A.takeWhile1 (/= c2w ':')) + <* A.word8 (c2w ':') + <* A.option (c2w ' ') (A.word8 (c2w ' ')) + <*> A.takeWhile (/= c2w '\r') + <* A.string "\r\n"
+ src/Network/WebSockets/Hybi13.hs view
@@ -0,0 +1,241 @@+-------------------------------------------------------------------------------- +{-# 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 qualified Data.Attoparsec.ByteString as A +import Data.Binary.Get (getWord16be, + getWord64be, runGet) +import Data.Binary.Put (runPut, putWord16be) +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 + -> Headers + -> Response +finishRequest reqHttp headers = + let !key = getRequestHeader reqHttp "Sec-WebSocket-Key" + !hash = hashKey key + !encoded = B64.encode hash + in response101 (("Sec-WebSocket-Accept", encoded):headers) "" + + +-------------------------------------------------------------------------------- +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 code pl)) -> mkFrame CloseFrame $ + runPut (putWord16be code) `mappend` 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 <- A.anyWord8 + let fin = byte0 .&. 0x80 == 0x80 + rsv1 = byte0 .&. 0x40 == 0x40 + rsv2 = byte0 .&. 0x20 == 0x20 + rsv3 = byte0 .&. 0x10 == 0x10 + opcode = byte0 .&. 0x0f + + ft <- case opcode of + 0x00 -> return ContinuationFrame + 0x01 -> return TextFrame + 0x02 -> return BinaryFrame + 0x08 -> return CloseFrame + 0x09 -> return PingFrame + 0x0a -> return PongFrame + _ -> fail $ "Unknown opcode: " ++ show opcode + + byte1 <- A.anyWord8 + let mask = byte1 .&. 0x80 == 0x80 + lenflag = fromIntegral (byte1 .&. 0x7f) + + len <- case lenflag of + 126 -> fromIntegral . runGet' getWord16be <$> A.take 2 + 127 -> fromIntegral . runGet' getWord64be <$> A.take 8 + _ -> return lenflag + + masker <- maskPayload <$> if mask then Just <$> A.take 4 else pure Nothing + + chunks <- take64 len + + return $ Frame fin rsv1 rsv2 rsv3 ft (masker $ BL.fromChunks chunks) + where + runGet' g = runGet g . BL.fromChunks . return + + take64 :: Int64 -> A.Parser [ByteString] + take64 n + | n <= 0 = return [] + | otherwise = do + let n' = min intMax n + chunk <- A.take (fromIntegral n') + (chunk :) <$> take64 (n - n') + where + intMax :: Int64 + intMax = fromIntegral (maxBound :: Int) + + +-------------------------------------------------------------------------------- +hashKey :: ByteString -> ByteString +hashKey key = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid + where + guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" + lazy = BL.fromChunks . return + unlazy = mconcat . BL.toChunks + + +-------------------------------------------------------------------------------- +createRequest :: ByteString + -> ByteString + -> Bool + -> Headers + -> IO RequestHead +createRequest hostname path secure customHeaders = do + key <- B64.encode `liftM` getEntropy 16 + return $ RequestHead path (headers key ++ customHeaders) secure + where + headers key = + [ ("Host" , hostname ) + , ("Connection" , "Upgrade" ) + , ("Upgrade" , "websocket" ) + , ("Sec-WebSocket-Key" , key ) + , ("Sec-WebSocket-Version" , versionNumber) + ] + + versionNumber = head headerVersions
+ src/Network/WebSockets/Hybi13/Demultiplex.hs view
@@ -0,0 +1,117 @@+-------------------------------------------------------------------------------- +-- | Demultiplexing of frames into messages +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} +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 Data.Binary.Get (runGet, getWord16be) +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 (uncurry Close parsedClose)), 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 + + -- The Close frame MAY contain a body (the "Application data" portion of the + -- frame) that indicates a reason for closing, such as an endpoint shutting + -- down, an endpoint having received a frame too large, or an endpoint + -- having received a frame that does not conform to the format expected by + -- the endpoint. If there is a body, the first two bytes of the body MUST + -- be a 2-byte unsigned integer (in network byte order) representing a + -- status code with value /code/ defined in Section 7.4. + parsedClose + | BL.length pl >= 2 = (runGet getWord16be pl, BL.drop 2 pl) + | otherwise = (1000, "")
+ src/Network/WebSockets/Hybi13/Mask.hs view
@@ -0,0 +1,46 @@+-------------------------------------------------------------------------------- +-- | Masking of fragmes using a simple XOR algorithm +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Network.WebSockets.Hybi13.Mask + ( Mask + , maskPayload + , randomMask + ) where + + +-------------------------------------------------------------------------------- +import Data.Bits (shiftR, xor) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import System.Random (RandomGen, random) + + +-------------------------------------------------------------------------------- +-- | ByteString should be exactly 4 bytes long +type Mask = Maybe B.ByteString + + +-------------------------------------------------------------------------------- +-- | Apply mask +maskPayload :: Mask -> BL.ByteString -> BL.ByteString +maskPayload Nothing = id +maskPayload (Just mask) = snd . BL.mapAccumL f 0 + where + len = B.length mask + f !i !c = + let i' = (i + 1) `mod` len + m = mask `B.index` i + in (i', m `xor` c) + + +-------------------------------------------------------------------------------- +-- | Create a random mask +randomMask :: forall g. RandomGen g => g -> (Mask, g) +randomMask gen = (Just (B.pack [b1, b2, b3, b4]), gen') + where + (!int, !gen') = random gen :: (Int, g) + !b1 = fromIntegral $ int `mod` 0x100 + !b2 = fromIntegral $ int `shiftR` 8 `mod` 0x100 + !b3 = fromIntegral $ int `shiftR` 16 `mod` 0x100 + !b4 = fromIntegral $ int `shiftR` 24 `mod` 0x100
+ src/Network/WebSockets/Protocol.hs view
@@ -0,0 +1,85 @@+-------------------------------------------------------------------------------- +-- | Wrapper for supporting multiple protocol versions +{-# LANGUAGE ExistentialQuantification #-} +module Network.WebSockets.Protocol + ( Protocol (..) + , defaultProtocol + , protocols + , compatible + , headerVersions + , finishRequest + , finishResponse + , encodeMessages + , decodeMessages + , createRequest + ) where + + +-------------------------------------------------------------------------------- +import Blaze.ByteString.Builder (Builder) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified System.IO.Streams as Streams + + +-------------------------------------------------------------------------------- +import Network.WebSockets.Http +import qualified Network.WebSockets.Hybi13 as Hybi13 +import Network.WebSockets.Types + + +-------------------------------------------------------------------------------- +data Protocol + = Hybi13 + deriving (Show) + + +-------------------------------------------------------------------------------- +defaultProtocol :: Protocol +defaultProtocol = Hybi13 + + +-------------------------------------------------------------------------------- +protocols :: [Protocol] +protocols = [Hybi13] + + +-------------------------------------------------------------------------------- +headerVersions :: Protocol -> [ByteString] +headerVersions Hybi13 = Hybi13.headerVersions + + +-------------------------------------------------------------------------------- +compatible :: Protocol -> RequestHead -> Bool +compatible protocol req = case getRequestSecWebSocketVersion req of + Just v -> v `elem` headerVersions protocol + _ -> True -- Whatever? + + +-------------------------------------------------------------------------------- +finishRequest :: Protocol -> RequestHead -> Headers -> Response +finishRequest Hybi13 = Hybi13.finishRequest + + +-------------------------------------------------------------------------------- +finishResponse :: Protocol -> RequestHead -> ResponseHead -> Response +finishResponse Hybi13 = Hybi13.finishResponse + + +-------------------------------------------------------------------------------- +encodeMessages :: Protocol -> ConnectionType + -> Streams.OutputStream Builder + -> IO (Streams.OutputStream Message) +encodeMessages Hybi13 = Hybi13.encodeMessages + + +-------------------------------------------------------------------------------- +decodeMessages :: Protocol -> Streams.InputStream B.ByteString + -> IO (Streams.InputStream Message) +decodeMessages Hybi13 = Hybi13.decodeMessages + + +-------------------------------------------------------------------------------- +createRequest :: Protocol -> B.ByteString -> B.ByteString -> Bool -> Headers + -> IO RequestHead +createRequest Hybi13 = Hybi13.createRequest
+ src/Network/WebSockets/Server.hs view
@@ -0,0 +1,81 @@+-------------------------------------------------------------------------------- +-- | This provides a simple stand-alone server for 'WebSockets' applications. +-- Note that in production you want to use a real webserver such as snap or +-- warp. +{-# LANGUAGE OverloadedStrings #-} +module Network.WebSockets.Server + ( ServerApp + , runServer + , runServerWith + ) where + + +-------------------------------------------------------------------------------- +import Control.Concurrent (forkIO) +import Control.Exception (finally) +import Control.Monad (forever) +import Network.Socket (Socket) +import qualified Network.Socket as S +import qualified System.IO.Streams.Attoparsec as Streams +import qualified System.IO.Streams.Builder as Streams +import qualified System.IO.Streams.Network as Streams + + +-------------------------------------------------------------------------------- +import Network.WebSockets.Connection +import Network.WebSockets.Http + + +-------------------------------------------------------------------------------- +-- | WebSockets application that can be ran by a server. Once this 'IO' action +-- finishes, the underlying socket is closed automatically. +type ServerApp = PendingConnection -> IO () + + +-------------------------------------------------------------------------------- +-- | Provides a simple server. This function blocks forever. Note that this +-- is merely provided for quick-and-dirty standalone applications, for real +-- applications, you should use a real server. +runServer :: String -- ^ Address to bind + -> Int -- ^ Port to listen on + -> ServerApp -- ^ Application + -> IO () -- ^ Never returns +runServer host port app = runServerWith host port defaultConnectionOptions app + + +-------------------------------------------------------------------------------- +-- | A version of 'runServer' which allows you to customize some options. +runServerWith :: String -> Int -> ConnectionOptions -> ServerApp -> IO () +runServerWith host port opts app = S.withSocketsDo $ do + sock <- S.socket S.AF_INET S.Stream S.defaultProtocol + _ <- S.setSocketOption sock S.ReuseAddr 1 + host' <- S.inet_addr host + S.bindSocket sock (S.SockAddrInet (fromIntegral port) host') + S.listen sock 5 + _ <- forever $ do + -- TODO: top level handle + (conn, _) <- S.accept sock + _ <- forkIO $ finally (runApp conn opts app) (S.sClose conn) + return () + S.sClose sock + + +-------------------------------------------------------------------------------- +runApp :: Socket + -> ConnectionOptions + -> ServerApp + -> IO () +runApp socket opts app = do + (sIn, sOut) <- Streams.socketToStreams socket + bOut <- Streams.builderStream sOut + -- TODO: we probably want to send a 40x if the request is bad? + request <- Streams.parseFromStream (decodeRequestHead False) sIn + let pc = PendingConnection + { pendingOptions = opts + , pendingRequest = request + , pendingOnAccept = \_ -> return () + , pendingIn = sIn + , pendingOut = bOut + } + + app pc
+ src/Network/WebSockets/Types.hs view
@@ -0,0 +1,129 @@+-------------------------------------------------------------------------------- +-- | Primary types +{-# LANGUAGE DeriveDataTypeable #-} +module Network.WebSockets.Types + ( Message (..) + , ControlMessage (..) + , DataMessage (..) + , WebSocketsData (..) + + , HandshakeException (..) + , ConnectionException (..) + + , ConnectionType (..) + ) where + + +-------------------------------------------------------------------------------- +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) +import Data.Word (Word16) + + +-------------------------------------------------------------------------------- +import Network.WebSockets.Http + + +-------------------------------------------------------------------------------- +-- | The kind of message a server application typically deals with +data Message + = ControlMessage ControlMessage + | DataMessage DataMessage + deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +-- | Different control messages +data ControlMessage + = Close Word16 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 + = 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: +-- +-- * Natively, everything is represented as a 'BL.ByteString', so this is the +-- fastest instance +-- +-- * You should only use the 'TL.Text' or the 'T.Text' instance when you are +-- sure that the data is UTF-8 encoded (which is the case for 'Text' +-- messages). +-- +-- * Messages can be very large. If this is the case, it might be inefficient to +-- use the strict 'B.ByteString' and 'T.Text' instances. +class WebSocketsData a where + 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 + + +-------------------------------------------------------------------------------- +-- | Various exceptions that can occur while receiving or transmitting messages +data ConnectionException + -- | The peer has requested that the connection be closed, and included + -- a close code and a reason for closing. When receiving this exception, + -- no more messages can be sent. Also, the server is responsible for + -- closing the TCP connection once this exception is received. + -- + -- See <http://tools.ietf.org/html/rfc6455#section-7.4> for a list of close + -- codes. + = CloseRequest Word16 BL.ByteString + + -- | The peer unexpectedly closed the connection while we were trying to + -- receive some data. This is a violation of the websocket RFC since the + -- TCP connection should only be closed after sending and receiving close + -- control messages. + | ConnectionClosed + + deriving (Show, Typeable) + + +-------------------------------------------------------------------------------- +instance Exception ConnectionException + + +-------------------------------------------------------------------------------- +data ConnectionType = ServerConnection | ClientConnection + deriving (Eq, Ord, Show)
+ twentefp-websockets.cabal view
@@ -0,0 +1,64 @@+Name: twentefp-websockets +Version: 0.1.0.0 + +Synopsis: + A fork of the popular websockets package. It is used for the practical assignments of the University of Twente. A sensible and clean way to write WebSocket-capable servers in Haskell. + +Description: + A fork of the popular websockets package. It is used for the practical assignments of the University of Twente. + +License: BSD3 +License-file: LICENCE +Copyright: (c) 2010-2011 Siniša Biđin + (c) 2011-2013 Jasper Van der Jeugt + (c) 2011 Steffen Schuldenzucker + (c) 2011 Alex Lang +Author: Siniša Biđin <sinisa@bidin.cc> + Jasper Van der Jeugt <m@jaspervdj.be> + Steffen Schuldenzucker <steffen.schuldenzucker@googlemail.com> + Alex Lang <lang@tsurucapital.com> + Sebastiaan la Fleur <sebastiaan.la.fleur@gmail.com> +Maintainer: Sebastiaan la Fleur <sebastiaan.la.fleur@gmail.com> +Stability: experimental +Category: Network +Build-type: Simple +Cabal-version: >= 1.8 + +Library + Hs-source-dirs: src + Ghc-options: -Wall + + Exposed-modules: + Network.WebSockets + Network.WebSockets.Connection + + Other-modules: + Network.WebSockets.Client + Network.WebSockets.Http + Network.WebSockets.Hybi13 + Network.WebSockets.Hybi13.Demultiplex + Network.WebSockets.Hybi13.Mask + Network.WebSockets.Protocol + Network.WebSockets.Server + Network.WebSockets.Types + + Build-depends: + attoparsec >= 0.9 && < 0.13, + 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.3, + containers >= 0.3 && < 0.6, + io-streams >= 1.1 && < 1.2, + mtl >= 2.0 && < 2.3, + network >= 2.3 && < 2.6, + random >= 1.0 && < 1.1, + SHA >= 1.5 && < 1.7, + text >= 0.10 && < 1.2, + entropy >= 0.2.1 && < 0.4 + +Source-repository head + Type: git + Location: https://github.com/Fathardie/websockets