websockets 0.3.1.1 → 0.4.0.0
raw patch · 17 files changed
+1080/−500 lines, 17 filesdep +containersdep +pureMD5
Dependencies added: containers, pureMD5
Files
- LICENCE +1/−1
- src/Network/WebSockets.hs +176/−96
- src/Network/WebSockets/Decode.hs +0/−86
- src/Network/WebSockets/Demultiplex.hs +3/−1
- src/Network/WebSockets/Encode.hs +0/−106
- src/Network/WebSockets/Handshake.hs +39/−49
- src/Network/WebSockets/Handshake/Http.hs +125/−0
- src/Network/WebSockets/Handshake/ShyIterParser.hs +40/−0
- src/Network/WebSockets/Mask.hs +10/−0
- src/Network/WebSockets/Monad.hs +211/−77
- src/Network/WebSockets/Protocol.hs +63/−0
- src/Network/WebSockets/Protocol/Hybi00.hs +117/−0
- src/Network/WebSockets/Protocol/Hybi10.hs +146/−0
- src/Network/WebSockets/Protocol/Unsafe.hs +24/−0
- src/Network/WebSockets/Socket.hs +54/−34
- src/Network/WebSockets/Types.hs +43/−27
- websockets.cabal +28/−23
LICENCE view
@@ -1,4 +1,4 @@-Copyright Siniša Biđin, 2010+Copyright Jasper Van der Jeugt, 2011 All rights reserved.
src/Network/WebSockets.hs view
@@ -1,34 +1,84 @@ -- | How do you use this library? Here's how: ----- * Get an enumerator/iteratee pair from your favorite web server, or use--- 'I.runServer' to set up a simple standalone server.+-- 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. ----- * Read the 'I.Request' using 'receiveRequest'. Inspect its path and the--- perform the initial 'H.handshake'. This yields a 'I.Response' which you can--- send back using 'sendResponse'. The WebSocket is now ready.+-- 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: ----- There are (informally) three ways in which you can use the library:+-- > {-# 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 ... ----- * The most simple case: You don't care about the internal representation of--- the messages. In this case, use the 'I.WebSocketsData' typeclass:--- 'receiveData', 'sendTextData' and 'sendBinaryData' will be useful.+-- You can now start using the socket for sending and receiving data. But what's+-- with the @p@ in @WebSockets p ()@? ----- * You have some protocol, and it is well-specified in which cases the client--- should send text messages, and in which cases the client should send binary--- messages. In this case, you can use the 'receiveDataMessage' and--- 'sendDataMessage' methods.+-- 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. ----- * You need to write a more low-level server in which you have control over--- control frames (e.g. ping/pong). In this case, you can use the--- 'receiveMessage' and 'sendMessage' methods.+-- 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.getSender'--- method is provided.+-- to the websocket from different threads. To this end, the 'I.getSink' method+-- is provided. The next example spawns a thread which continuously spams the+-- client in another thread: --+-- > import Control.Concurrent (forkIO)+-- > import Control.Monad (forever)+-- > import Control.Monad.Trans (liftIO)+-- > import Network.WebSockets+-- > import qualified Data.Text as T+-- > +-- > spam :: TextProtocol p => WebSockets p ()+-- > spam = do+-- > sink <- getSink+-- > _ <- liftIO $ forkIO $ forever $+-- > sendSink sink $ textData (T.pack "SPAM SPAM SPAM!")+-- > sendTextData (T.pack "Hello world!")+--+-- For safety reasons, you can only read from the socket in the 'I.WebSockets'+-- monad.+-- -- For a full example, see: ----- <http://github.com/jaspervdj/websockets/tree/master/example>+-- <http://jaspervdj.be/websockets/example.html>+{-# LANGUAGE ScopedTypeVariables #-} module Network.WebSockets ( -- * WebSocket type@@ -37,13 +87,23 @@ , 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 -- * Types , I.Headers+ , I.RequestHttpPart (..) , I.Request (..) , I.Response (..) , I.FrameType (..)@@ -53,121 +113,141 @@ , I.DataMessage (..) , I.WebSocketsData (..) - -- * Initial handshake- , H.HandshakeError (..)- , receiveRequest- , sendResponse- , H.handshake+ -- * Handshake+ , acceptRequest+ , rejectRequest - -- * Sending and receiving+ -- * Various+ , I.getVersion++ -- * Receiving , receiveFrame- , sendFrame- , receiveMessage- , sendMessage+ , receive , receiveDataMessage- , sendDataMessage , receiveData++ -- * Sending+ , sendFrame+ , I.send , sendTextData , sendBinaryData - -- * Advanced sending- , E.Encoder- , I.Sender- , I.send- , I.getSender- , E.response- , E.frame- , E.message- , E.controlMessage- , E.dataMessage- , E.textData- , E.binaryData+ -- * Asynchronous sending+ , I.Sink+ , I.sendSink+ , I.getSink+ , I.close+ , I.ping+ , I.pong+ , I.textData+ , I.binaryData+ , I.spawnPingThread++ -- * Error Handling+ , I.throwWsError+ , I.catchWsError+ , I.HandshakeError(..)+ , I.ConnectionError(..) ) where import Control.Monad.State (put, get) import Control.Monad.Trans (liftIO) -import qualified Network.WebSockets.Decode as D import qualified Network.WebSockets.Demultiplex as I-import qualified Network.WebSockets.Encode as E-import qualified Network.WebSockets.Handshake as H+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 --- | Read a 'I.Request' from the socket. Blocks until one is received and--- returns 'Nothing' if the socket has been closed.-receiveRequest :: I.WebSockets (Maybe I.Request)-receiveRequest = I.receive D.request---- | Send a 'I.Response' to the socket immediately.-sendResponse :: I.Response -> I.WebSockets ()-sendResponse = I.send E.response+-- 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. --- | Read a 'I.Frame' from the socket. Blocks until a frame is received and--- returns 'Nothing' if the socket has been closed.+-- | Read a 'I.Frame' from the socket. Blocks until a frame is received. If the+-- socket is closed, throws 'ConnectionClosed' (a 'ConnectionError') -- -- Note that a typical library user will want to use something like -- 'receiveByteStringData' instead.-receiveFrame :: I.WebSockets (Maybe I.Frame)-receiveFrame = I.receive D.frame---- | A low-level function to send an arbitrary frame over the wire.-sendFrame :: I.Frame -> I.WebSockets ()-sendFrame = I.send E.frame+receiveFrame :: I.Protocol p => I.WebSockets p I.Frame+receiveFrame = do+ proto <- I.getProtocol+ I.receiveWith $ I.decodeFrame proto -- | Receive a message-receiveMessage :: I.WebSockets (Maybe I.Message)-receiveMessage = I.WebSockets $ do- mf <- I.unWebSockets receiveFrame- case mf of- Nothing -> return Nothing- Just f -> do- s <- get- let (msg, s') = I.demultiplex s f- put s'- case msg of- Nothing -> I.unWebSockets receiveMessage- Just m -> return (Just m)---- | Send a message-sendMessage :: I.Message -> I.WebSockets ()-sendMessage = I.send E.message+receive :: I.Protocol p => I.WebSockets p (I.Message p)+receive = I.WebSockets $ do+ f <- I.unWebSockets receiveFrame+ s <- get+ let (msg, s') = I.demultiplex s f+ put s'+ case msg of+ Nothing -> I.unWebSockets receive+ Just m -> return m -- | Receive an application message. Automatically respond to control messages.-receiveDataMessage :: I.WebSockets (Maybe I.DataMessage)+receiveDataMessage :: I.Protocol p => I.WebSockets p (I.DataMessage p) receiveDataMessage = do- mm <- receiveMessage- case mm of- Nothing -> return Nothing- Just (I.DataMessage am) -> return (Just am)- Just (I.ControlMessage cm) -> case cm of- I.Close _ -> return Nothing+ m <- 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- I.send E.controlMessage (I.Pong pl)+ -- 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 --- | Send an application-level message.-sendDataMessage :: I.DataMessage -> I.WebSockets ()-sendDataMessage = I.send E.dataMessage- -- | Receive a message, treating it as data transparently-receiveData :: I.WebSocketsData a => I.WebSockets (Maybe a)+receiveData :: (I.Protocol p, I.WebSocketsData a) => I.WebSockets p a receiveData = do dm <- receiveDataMessage case dm of- Nothing -> return Nothing- Just (I.Text x) -> return (Just $ I.fromLazyByteString x)- Just (I.Binary x) -> return (Just $ I.fromLazyByteString x)+ 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.Response -> I.WebSockets p ()+sendResponse response = I.sendWith I.encodeResponse response++-- | A low-level function to send an arbitrary frame over the wire.+sendFrame :: I.Protocol p => I.Frame -> I.WebSockets p ()+sendFrame frame = do+ proto <- I.getProtocol+ I.sendWith (I.encodeFrame proto) frame+ -- | Send a text message-sendTextData :: I.WebSocketsData a => a -> I.WebSockets ()-sendTextData = I.send E.textData+sendTextData :: (I.TextProtocol p, I.WebSocketsData a) => a -> I.WebSockets p ()+sendTextData = I.send . I.textData -- | Send some binary data-sendBinaryData :: I.WebSocketsData a => a -> I.WebSockets ()-sendBinaryData = I.send E.binaryData+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
− src/Network/WebSockets/Decode.hs
@@ -1,86 +0,0 @@--- | Provides parsers for the WebSocket protocol. Uses the attoparsec library.-{-# LANGUAGE BangPatterns, OverloadedStrings, PatternGuards #-}-module Network.WebSockets.Decode- ( request- , frame- ) where--import Control.Applicative (pure, (<$>), (<*>), (*>), (<*))-import Data.Bits ((.&.))--import Data.Attoparsec (Parser, anyWord8, string, takeWhile1, word8)-import Data.Attoparsec.Combinator (manyTill)-import Data.Binary.Get (runGet, getWord16be, getWord64be)-import Data.ByteString (ByteString)-import Data.ByteString.Char8 ()-import Data.ByteString.Internal (c2w)-import Data.Int (Int64)-import qualified Data.Attoparsec as A-import qualified Data.ByteString.Lazy as BL-import qualified Data.CaseInsensitive as CI--import Network.WebSockets.Mask-import Network.WebSockets.Types---- | Parse an initial request-request :: Parser Request-request = Request- <$> requestLine- <*> manyTill header newline- where- space = word8 (c2w ' ')- newline = string "\r\n"-- requestLine = string "GET" *> space *> takeWhile1 (/= c2w ' ')- <* space- <* string "HTTP/1.1" <* newline-- header = (,)- <$> (CI.mk <$> takeWhile1 (/= c2w ':'))- <* string ": "- <*> takeWhile1 (/= c2w '\r')- <* newline---- | Parse a frame-frame :: Parser Frame-frame = do- byte0 <- anyWord8- let fin = byte0 .&. 0x80 == 0x80- 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 ft (masker $ BL.fromChunks chunks)- where- runGet' g = runGet g . BL.fromChunks . return-- take64 :: Int64 -> 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)
src/Network/WebSockets/Demultiplex.hs view
@@ -19,7 +19,9 @@ emptyDemultiplexState :: DemultiplexState emptyDemultiplexState = DemultiplexState Nothing -demultiplex :: DemultiplexState -> Frame -> (Maybe Message, DemultiplexState)+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)
− src/Network/WebSockets/Encode.hs
@@ -1,106 +0,0 @@--- | Encoding of types to the WebSocket protocol. We always encode to--- 'B.Builder' values.-{-# LANGUAGE OverloadedStrings #-}-module Network.WebSockets.Encode- ( Encoder- , response- , frame- , message- , controlMessage- , close- , ping- , pong- , dataMessage- , textData- , binaryData- ) where--import Data.Bits ((.|.))-import Data.Monoid (mappend, mempty, mconcat)--import Data.ByteString.Char8 ()-import qualified Blaze.ByteString.Builder as B-import qualified Blaze.ByteString.Builder.Char.Utf8 as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.CaseInsensitive as CI--import Network.WebSockets.Mask-import Network.WebSockets.Types---- | The inverse of a parser-type Encoder a = Mask -> a -> B.Builder---- | Encode an HTTP upgrade response-response :: Encoder Response-response _ (Response code msg headers) =- B.copyByteString "HTTP/1.1 " `mappend` B.fromString (show code) `mappend`- B.fromChar ' ' `mappend` B.fromByteString msg `mappend`- B.fromByteString "\r\n" `mappend`- mconcat (map header headers) `mappend` B.copyByteString "\r\n"- where- header (k, v) = mconcat $ map B.copyByteString- [CI.original k, ": ", v, "\r\n"]---- | Encode a frame-frame :: Encoder Frame-frame mask f = B.fromWord8 byte0 `mappend` B.fromWord8 byte1 `mappend`- len `mappend` maskbytes `mappend`- B.fromLazyByteString (maskPayload mask (framePayload f))- where- byte0 = fin .|. opcode- fin = if frameFin f then 0x80 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'))---- | Encode a message-message :: Encoder Message-message mask msg = case msg of- ControlMessage m -> controlMessage mask m- DataMessage m -> dataMessage mask m---- | Encode a control message-controlMessage :: Encoder ControlMessage-controlMessage mask msg = frame mask $ case msg of- Close pl -> Frame True CloseFrame pl- Ping pl -> Frame True PingFrame pl- Pong pl -> Frame True PongFrame pl---- | Encode a close message-close :: WebSocketsData a => Encoder a-close mask = controlMessage mask . Close . toLazyByteString---- | Encode a ping message-ping :: WebSocketsData a => Encoder a-ping mask = controlMessage mask . Ping . toLazyByteString---- | Encode a pong message-pong :: WebSocketsData a => Encoder a-pong mask = controlMessage mask . Pong . toLazyByteString---- | Encode an application message-dataMessage :: Encoder DataMessage-dataMessage mask msg = frame mask $ case msg of- Text pl -> Frame True TextFrame pl- Binary pl -> Frame True BinaryFrame pl--textData :: WebSocketsData a => Encoder a-textData mask = dataMessage mask . Text . toLazyByteString--binaryData :: WebSocketsData a => Encoder a-binaryData mask = dataMessage mask . Binary . toLazyByteString
src/Network/WebSockets/Handshake.hs view
@@ -1,60 +1,50 @@ -- | Implementation of the WebSocket handshake-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} module Network.WebSockets.Handshake ( HandshakeError (..)- , handshake- , response101- , response400+ , responseError+ , tryFinishRequest ) where -import Data.Monoid (mappend, mconcat)-import Control.Monad.Error (Error (..), throwError)--import Data.Digest.Pure.SHA (bytestringDigest, sha1)-import qualified Data.ByteString.Base64 as B64-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as BL-import qualified Data.CaseInsensitive as CI+import qualified Data.ByteString as B +import Network.WebSockets.Handshake.Http+import Network.WebSockets.Protocol import Network.WebSockets.Types --- | Error in case of failed handshake.-data HandshakeError = HandshakeError String- deriving (Show)--instance Error HandshakeError where- noMsg = HandshakeError "Handshake error"- strMsg = HandshakeError---- | Provides the logic for the initial handshake defined in the WebSocket--- protocol. This function will provide you with a 'Response' which accepts and--- upgrades the received 'Request'. Once this 'Response' is sent, you can start--- sending and receiving actual application data.+-- | Receives and checks the client handshake.+-- +-- * If this fails, we encountered a syntax error while processing the client's+-- request. That is very bad.+-- +-- * If it returns @Left@, we either don't support the protocol requested by+-- the client ('NotSupported') or the data the client sent doesn't match the+-- protocol ('MalformedRequest') ----- In the case of a malformed request, a 'HandshakeError' is returned.-handshake :: Request -> Either HandshakeError Response-handshake (Request _ headers) = do- key <- getHeader "Sec-WebSocket-Key"- let hash = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid- let encoded = B64.encode hash-- return $ response101 [("Sec-WebSocket-Accept", encoded)]+-- * Otherwise, we are guaranteed that the client handshake is valid and have+-- generated a response ready to be sent back.+--+tryFinishRequest :: Protocol p+ => RequestHttpPart+ -> Decoder p (Either HandshakeError (Request, p))+tryFinishRequest httpReq = tryInOrder implementations+ -- NOTE that the protocols are tried in order, the first one first. So that+ -- should be the latest one. (only matters if we have overlaps in specs,+ -- though) where- guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"- lazy = BL.fromChunks . return- unlazy = mconcat . BL.toChunks- getHeader k = case lookup k headers of- Just t -> return t- Nothing -> throwError $- HandshakeError $ "Header missing: " ++ BC.unpack (CI.original k)---- | An upgrade response-response101 :: Headers -> Response-response101 headers = Response 101 "WebSocket Protocol Handshake" $- ("Upgrade", "WebSocket") :- ("Connection", "Upgrade") :- headers+ tryInOrder [] = return . Left $ NotSupported+ tryInOrder (p : ps) = finishRequest p httpReq >>= \res -> case res of+ (Left NotSupported) -> tryInOrder ps+ (Left e) -> return (Left e)+ (Right req) -> return . Right $ (req, p) --- | Bad request-response400 :: Headers -> Response-response400 headers = Response 400 "Bad Request" headers+-- | Respond to errors encountered during handshake. First argument may be+-- bottom.+responseError :: forall p. Protocol p => p -> HandshakeError -> Response+responseError _ err = response400 $ case err of+ -- TODO: fix+ NotSupported -> versionHeader -- Version negotiation+ _ -> []+ where+ versionHeader = [("Sec-WebSocket-Version",+ B.intercalate ", " $ map headerVersion (implementations :: [p]))]
+ src/Network/WebSockets/Handshake/Http.hs view
@@ -0,0 +1,125 @@+-- | Module dealing with HTTP: request data types, encoding and decoding...+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+module Network.WebSockets.Handshake.Http+ ( Headers+ , RequestHttpPart (..)+ , Request (..)+ , Response (..)+ , HandshakeError (..)+ , decodeRequest+ , encodeResponse+ , response101+ , response400+ ) where++import Data.Dynamic (Typeable)+import Data.Monoid (mappend, mconcat)+import Control.Applicative ((<$>), (<*>), (*>), (<*))+import Control.Exception (Exception)+import Control.Monad.Error (Error (..))++import Data.Attoparsec (string, takeWhile1, word8)+import Data.Attoparsec.Combinator (manyTill)+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.ByteString as B+import qualified Data.CaseInsensitive as CI++import Network.WebSockets.Types++-- | Request headers+type Headers = [(CI.CI B.ByteString, B.ByteString)]++-- | (Internally used) HTTP headers and requested path.+data RequestHttpPart = RequestHttpPart+ { requestHttpPath :: !B.ByteString+ , requestHttpHeaders :: Headers+ } deriving (Eq, Show)++-- | Full request type+data Request = Request+ { requestPath :: !B.ByteString+ , requestHeaders :: Headers+ , requestResponse :: Response+ }+ deriving (Show)++-- | Response to a 'Request'+data Response = Response+ { responseCode :: !Int+ , responseMessage :: !B.ByteString+ , responseHeaders :: Headers+ , responseBody :: 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 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++-- | Parse an initial request+decodeRequest :: Decoder p RequestHttpPart+decodeRequest = RequestHttpPart+ <$> requestLine+ <*> manyTill header newline+ where+ space = word8 (c2w ' ')+ newline = string "\r\n"++ requestLine = string "GET" *> space *> takeWhile1 (/= c2w ' ')+ <* space+ <* string "HTTP/1.1" <* newline++ header = (,)+ <$> (CI.mk <$> takeWhile1 (/= c2w ':'))+ <* string ": "+ <*> takeWhile1 (/= c2w '\r')+ <* newline++-- | Encode an HTTP upgrade response+encodeResponse :: Encoder p Response+encodeResponse _ (Response code msg headers body) =+ 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" `mappend`+ Builder.copyByteString body -- (body is empty except for version -00)+ where+ header (k, v) = mconcat $ map Builder.copyByteString+ [CI.original k, ": ", v, "\r\n"]++-- | An upgrade response+response101 :: Headers -> B.ByteString -> Response+response101 headers body = Response 101 "WebSocket Protocol Handshake"+ (("Upgrade", "WebSocket") : ("Connection", "Upgrade") : headers)+ body++-- | Bad request+--+response400 :: Headers -> Response+response400 headers = Response 400 "Bad Request" headers ""
+ src/Network/WebSockets/Handshake/ShyIterParser.hs view
@@ -0,0 +1,40 @@+module Network.WebSockets.Handshake.ShyIterParser+ ( shyIterParser+ ) where++import Data.Attoparsec.Enumerator (ParseError(..))+import qualified Data.Attoparsec as A+import qualified Data.ByteString as B+import qualified Data.Enumerator as E++-- | Behaves almost the same as the 'iterParser' function from the+-- attoparsec-enumerator package, with the exception that, while the iteratee+-- created by 'iterParser' always starts in a 'Continue' state, this one will+-- only ask for more data if the underlying parser needs it. That's important+-- because e.g. network connection will block and wait for more data on a+-- 'Continue'. For messages or frames the problem will not occur as we know the+-- length of the payload and therefore can determine EOF (= end of the frame+-- here).+--+-- We use parsers that don't take data for validation in Protocols.Hybi10+shyIterParser :: (Monad m) => A.Parser a -> E.Iteratee B.ByteString m a+shyIterParser p = parseLoop (A.parse p) [B.empty]+ -- feed empty to the parse *once*.+ where+ -- from here: copied from attoparsec-enumerator-0.2.0.4+ step parse (E.Chunks xs) = parseLoop parse (notEmpty xs)+ step parse E.EOF = case A.feed (parse B.empty) B.empty of+ A.Done _ a -> E.yield a E.EOF+ A.Partial _ -> err [] "iterParser: divergent parser"+ A.Fail _ ctx msg -> err ctx msg++ parseLoop parse [] = E.continue (step parse)+ parseLoop parse (x:xs) = case parse x of+ A.Done extra a -> E.yield a $ if B.null extra+ then E.Chunks xs+ else E.Chunks (extra:xs)+ A.Partial parse' -> parseLoop parse' xs+ A.Fail _ ctx msg -> err ctx msg++ err ctx msg = E.throwError (ParseError ctx msg)+ notEmpty = filter (not . B.null)
src/Network/WebSockets/Mask.hs view
@@ -3,9 +3,13 @@ module Network.WebSockets.Mask ( Mask , maskPayload+ , randomMask ) where +import Control.Applicative ((<$>))+import Control.Monad (replicateM) import Data.Bits (xor)+import System.Random (randomRIO) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL@@ -22,3 +26,9 @@ f !i !c = let i' = (i + 1) `mod` len m = mask `B.index` i in (i', m `xor` c)++-- | Create a random mask+randomMask :: IO Mask+randomMask = Just . B.pack <$> replicateM 4 randomByte+ where+ randomByte = fromIntegral <$> randomRIO (0x00 :: Int, 0xff)
src/Network/WebSockets/Monad.hs view
@@ -1,138 +1,272 @@ -- | Provides a simple, clean monad to write websocket servers in-{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings,+ NoMonomorphismRestriction, Rank2Types, ScopedTypeVariables #-} module Network.WebSockets.Monad ( WebSocketsOptions (..) , defaultWebSocketsOptions , WebSockets (..) , runWebSockets , runWebSocketsWith- , receive+ , runWebSocketsHandshake+ , runWebSocketsWithHandshake+ , runWebSocketsWith'+ , receiveWith+ , sendWith , send- , Sender- , getSender+ , Sink+ , sendSink+ , getSink , getOptions+ , getProtocol+ , getVersion+ , throwWsError+ , catchWsError+ , spawnPingThread ) where -import Control.Applicative ((<$>))-import Control.Concurrent.MVar (newMVar, takeMVar, putMVar)+import Control.Applicative (Applicative, (<$>)) import Control.Concurrent (forkIO, threadDelay)-import Control.Monad (forever, replicateM)+import Control.Concurrent.MVar (newMVar, withMVar)+import Control.Exception (Exception (..), SomeException, throw)+import Control.Monad (forever) import Control.Monad.Reader (ReaderT, ask, runReaderT)-import Control.Monad.State (StateT, evalStateT)+import Control.Monad.State (StateT, evalStateT, get) import Control.Monad.Trans (MonadIO, lift, liftIO)-import System.Random (randomRIO) import Blaze.ByteString.Builder (Builder) import Blaze.ByteString.Builder.Enumerator (builderToByteString)-import Data.Attoparsec (Parser)-import Data.Attoparsec.Enumerator (iterParser) import Data.ByteString (ByteString)-import Data.Enumerator ( Iteratee, Stream (..), checkContinue0, isEOF, returnI- , run, ($$), (>>==)- )-import qualified Data.ByteString as B+import Data.Enumerator (Enumerator, Iteratee, ($$), (>>==))+import qualified Data.Attoparsec.Enumerator as AE+import qualified Data.Enumerator as E import Network.WebSockets.Demultiplex (DemultiplexState, emptyDemultiplexState)-import Network.WebSockets.Encode (Encoder)-import qualified Network.WebSockets.Encode as E+import Network.WebSockets.Handshake+import Network.WebSockets.Handshake.Http+import Network.WebSockets.Handshake.ShyIterParser+import Network.WebSockets.Mask+import Network.WebSockets.Protocol+import Network.WebSockets.Types as T -- | Options for the WebSocket program data WebSocketsOptions = WebSocketsOptions { onPong :: IO ()- , pingInterval :: Maybe Int } -- | Default options defaultWebSocketsOptions :: WebSocketsOptions defaultWebSocketsOptions = WebSocketsOptions { onPong = return ()- , pingInterval = Just 10 } -- | Environment in which the 'WebSockets' monad actually runs-data WebSocketsEnv = WebSocketsEnv WebSocketsOptions (Builder -> IO ())+data WebSocketsEnv p = WebSocketsEnv+ { options :: WebSocketsOptions+ , sendBuilder :: Builder -> IO ()+ , protocol :: p+ } -- | The monad in which you can write WebSocket-capable applications-newtype WebSockets a = WebSockets- { unWebSockets :: ReaderT WebSocketsEnv+newtype WebSockets p a = WebSockets+ { unWebSockets :: ReaderT (WebSocketsEnv p) (StateT DemultiplexState (Iteratee ByteString IO)) a- } deriving (Functor, Monad, MonadIO)+ } deriving (Applicative, Functor, Monad, MonadIO) --- | Run a 'WebSockets' application on an 'Enumerator'/'Iteratee' pair.-runWebSockets :: WebSockets a+-- | Receives the initial client handshake, then behaves like 'runWebSockets'.+runWebSocketsHandshake :: Protocol p+ => (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+ -> (Request -> WebSockets p a)+ -> Iteratee ByteString IO ()+ -> Iteratee ByteString IO a+runWebSocketsWithHandshake opts goWs outIter = do+ httpReq <- receiveIteratee decodeRequest+ 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 :: WebSocketsOptions- -> WebSockets a+runWebSocketsWith :: forall p a. Protocol p+ => WebSocketsOptions+ -> RequestHttpPart+ -> (Request -> WebSockets p a) -> Iteratee ByteString IO () -> Iteratee ByteString IO a-runWebSocketsWith options ws outIter = do+runWebSocketsWith opts httpReq goWs outIter = do+ mreq <- receiveIterateeShy $ tryFinishRequest httpReq+ case mreq of+ (Left err) -> do+ sendIteratee encodeResponse (responseError proto err) outIter+ E.throwError err+ (Right (r, p)) -> runWebSocketsWith' opts p (goWs r) outIter+ where+ proto :: p+ proto = undefined++runWebSocketsWith' :: Protocol p+ => WebSocketsOptions+ -> p+ -> WebSockets p a+ -> Iteratee ByteString IO ()+ -> Iteratee ByteString IO a+runWebSocketsWith' opts proto ws outIter = do sendLock <- liftIO $ newMVar () + let sender = makeSend sendLock- env = WebSocketsEnv options sender- state = runReaderT (unWebSockets ws') env+ env = WebSocketsEnv opts sender proto+ state = runReaderT (unWebSockets ws) env iter = evalStateT state emptyDemultiplexState-- iter where- makeSend sendLock x = do- () <- takeMVar sendLock- _ <- run $ singleton x $$ builderToByteString $$ outIter- putMVar sendLock ()+ makeSend sendLock x = withMVar sendLock $ \_ ->+ builderSender outIter x - singleton c = checkContinue0 $ \_ f -> f (Chunks [c]) >>== returnI+-- | @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 () - -- Spawn a ping thread first- ws' = spawnPingThread >> ws+-- | Receive some data from the socket, using a user-supplied parser.+receiveWith :: Decoder p a -> WebSockets p a+receiveWith = liftIteratee . receiveIteratee --- | Spawn a thread which sends a ping every few seconds, according to the--- options set-spawnPingThread :: WebSockets ()-spawnPingThread = do- sender <- getSender- options <- getOptions- case pingInterval options of- Nothing -> return ()- Just i -> do- _ <- 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- sender E.ping ("Hi" :: ByteString)- return ()+-- todo: move some stuff to another module. "Decode"? --- | Receive some data from the socket, using a user-supplied parser.-receive :: Parser a -> WebSockets (Maybe a)-receive parser = WebSockets $ lift $ lift $ do- eof <- isEOF- if eof then return Nothing else fmap Just (iterParser parser)+-- | Underlying iteratee version of 'receiveWith'.+receiveIteratee :: Decoder p a -> Iteratee ByteString IO a+receiveIteratee parser = do+ eof <- E.isEOF+ if eof+ then E.throwError ConnectionClosed+ else wrappingParseError . AE.iterParser $ parser --- | Low-level sending with an arbitrary 'Encoder'-send :: Encoder a -> a -> WebSockets ()-send encoder x = do- sender <- getSender- liftIO $ sender encoder x+-- | Like receiveIteratee, but if the supplied parser is happy with no input,+-- we don't supply any more. This is very, very important when we have parsers+-- that don't necessarily read data, like hybi10's completeRequest.+receiveIterateeShy :: Decoder p a -> Iteratee ByteString IO a+receiveIterateeShy parser = wrappingParseError $ shyIterParser parser --- | For asynchronous sending-type Sender a = Encoder a -> a -> IO ()+-- | 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 +sendIteratee :: Encoder p a -> a+ -> Iteratee ByteString IO ()+ -> Iteratee ByteString IO ()+sendIteratee enc resp outIter = do+ liftIO $ mkSend (builderSender outIter) enc resp++-- | Low-leven sending with an arbitrary 'Encoder'+sendWith :: Encoder p a -> a -> WebSockets p ()+sendWith encoder x = WebSockets $ do+ send' <- sendBuilder <$> ask+ liftIO $ mkSend send' encoder x++-- | Low-level sending with an arbitrary 'T.Message'+send :: Protocol p => T.Message p -> WebSockets p ()+send msg = getSink >>= \sink -> liftIO $ sendSink sink msg++-- | Used for asynchronous sending.+newtype Sink p = Sink {unSink :: Message p -> IO ()}++-- | Send a message to a sink. Might generate an exception if the underlying+-- connection is closed.+sendSink :: Sink p -> Message p -> IO ()+sendSink = unSink+ -- | In case the user of the library wants to do asynchronous sending to the--- socket, he can extract a 'Sender' and pass this value around, for example,+-- socket, he can extract a 'Sink' and pass this value around, for example, -- to other threads.-getSender :: WebSockets (Sender a)-getSender = WebSockets $ do- WebSocketsEnv _ send' <- ask- return $ \encoder x -> do- bytes <- replicateM 4 (liftIO randomByte)- send' (encoder (Just (B.pack bytes)) x)+getSink :: Protocol p => WebSockets p (Sink p)+getSink = WebSockets $ do+ proto <- unWebSockets getProtocol+ send' <- sendBuilder <$> ask+ return $ Sink $ mkSend send' $ encodeMessage $ encodeFrame proto where- randomByte = fromIntegral <$> randomRIO (0x00 :: Int, 0xff)+ -- TODO: proper multiplexing?+ encodeMessage frame mask msg = frame mask $ case msg of+ (ControlMessage (Close pl)) -> Frame True CloseFrame pl+ (ControlMessage (Ping pl)) -> Frame True PingFrame pl+ (ControlMessage (Pong pl)) -> Frame True PongFrame pl+ (DataMessage (Text pl)) -> Frame True TextFrame pl+ (DataMessage (Binary pl)) -> Frame True BinaryFrame pl +-- TODO: rename to mkEncodedSender?+mkSend :: (Builder -> IO ()) -> Encoder p a -> a -> IO ()+mkSend send' encoder x = do+ mask <- randomMask+ send' $ encoder mask x++singleton :: Monad m => a -> Enumerator a m b+singleton c = E.checkContinue0 $ \_ f -> f (E.Chunks [c]) >>== E.returnI++builderSender :: MonadIO m => Iteratee ByteString m b -> Builder -> m ()+builderSender outIter x = do+ ok <- E.run $ singleton x $$ builderToByteString $$ outIter+ case ok of+ Left err -> throw err+ Right _ -> return ()+ -- | Get the current configuration-getOptions :: WebSockets WebSocketsOptions-getOptions = WebSockets $ ask >>= \(WebSocketsEnv options _) -> return options+getOptions :: WebSockets p WebSocketsOptions+getOptions = WebSockets $ ask >>= return . options++-- | Get the underlying protocol+getProtocol :: WebSockets p p+getProtocol = WebSockets $ protocol <$> 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+ state <- get+ let it = peelWebSockets state env $ act+ cit = peelWebSockets state env . c+ lift . lift $ it `E.catchError` cit+ where+ peelWebSockets state env =+ flip evalStateT state . flip runReaderT env . unWebSockets++-- | Lift an Iteratee computation to WebSockets+liftIteratee :: Iteratee ByteString IO a -> WebSockets p a+liftIteratee = WebSockets . lift . lift
+ src/Network/WebSockets/Protocol.hs view
@@ -0,0 +1,63 @@+-- | Wrapper for supporting multiple protocol versions+{-# LANGUAGE ExistentialQuantification #-}+module Network.WebSockets.Protocol+ ( Protocol (..)+ , TextProtocol+ , BinaryProtocol+ , close+ , ping+ , pong+ , textData+ , binaryData+ ) where++import qualified Data.ByteString as B++import Network.WebSockets.Types+import Network.WebSockets.Handshake.Http+import qualified Network.WebSockets.Protocol.Unsafe as Unsafe++class Protocol p where+ -- | Unique identifier for us.+ version :: p -> String++ -- | Version as used in the "Sec-WebSocket-Version " header. This is usually+ -- not the same, or derivable from "version", e.g. for hybi10, it's "8".+ headerVersion :: p -> B.ByteString++ encodeFrame :: p -> Encoder p Frame+ decodeFrame :: p -> Decoder p Frame++ -- | Parse and validate the rest of the request. For hybi10, this is just+ -- validation, but hybi00 also needs to fetch a "security token"+ --+ -- Todo: Maybe we should introduce our own simplified error type here. (to+ -- be amended with the RequestHttpPart for the user)+ finishRequest :: p -> RequestHttpPart+ -> Decoder p (Either HandshakeError Request)++ -- | Implementations of the specification+ implementations :: [p]++class Protocol p => TextProtocol p+class TextProtocol p => BinaryProtocol p++-- | 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++-- | 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++-- | Construct a binary message+binaryData :: (BinaryProtocol p, WebSocketsData a) => a -> Message p+binaryData = Unsafe.binaryData
+ src/Network/WebSockets/Protocol/Hybi00.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE ExistentialQuantification, OverloadedStrings #-}+module Network.WebSockets.Protocol.Hybi00+ ( Hybi00_ (..)+ , Hybi00+ ) where++import Control.Applicative ((<|>))+import Control.Monad.Error (ErrorT (..), MonadError, throwError)+import Control.Monad.Trans (lift)+import Data.Char (isDigit)++import Data.Binary (encode)+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.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.CaseInsensitive as CI++import Network.WebSockets.Handshake.Http+import Network.WebSockets.Protocol+import Network.WebSockets.Types+import Network.WebSockets.Protocol.Hybi10 (Hybi10_ (..))++data Hybi00_ = Hybi00_++instance Protocol Hybi00_ where+ version Hybi00_ = "hybi00"+ headerVersion Hybi00_ = "0" -- but the client will elide it+ encodeFrame Hybi00_ = encodeFrameHybi00+ decodeFrame Hybi00_ = decodeFrameHybi00+ finishRequest Hybi00_ = runErrorT . handshakeHybi00+ implementations = [Hybi00_]++instance TextProtocol Hybi00_++encodeFrameHybi00 :: Encoder p Frame+encodeFrameHybi00 _ (Frame True TextFrame pl) =+ BB.fromLazyByteString $ "\0" `BL.append` pl `BL.append` "\255"+encodeFrameHybi00 _ (Frame _ CloseFrame _) =+ BB.fromLazyByteString "\255\0"+ -- TODO: prevent the user from doing this using type tags+encodeFrameHybi00 _ _ = error "Not supported"++decodeFrameHybi00 :: Decoder p Frame+decodeFrameHybi00 = decodeTextFrame <|> decodeCloseFrame+ where+ decodeTextFrame = do+ _ <- A.word8 0x00+ utf8string <- A.manyTill A.anyWord8 (A.try $ A.word8 0xff)+ return $ Frame True TextFrame $ BL.pack utf8string++ decodeCloseFrame = do+ _ <- A.word8 0xff+ _ <- A.word8 0x00+ return $ Frame True CloseFrame ""++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 :: RequestHttpPart+ -> ErrorT HandshakeError A.Parser Request+handshakeHybi00 reqHttp@(RequestHttpPart path h) = do+ -- _ <- lift . A.word8 $ fromIntegral 0x0d+ -- _ <- lift . A.word8 $ fromIntegral 0x0a++ case getHeader "Sec-WebSocket-Version" of+ Left _ -> return ()+ Right "0" -> return ()+ Right _ -> throwError NotSupported++ keyPart3 <- lift $ 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 response = response101+ [ ("Sec-WebSocket-Location", B.concat ["ws://", host, path])+ , ("Sec-WebSocket-Origin", origin)+ ]+ key++ return $ Request path h response+ where+ getHeader k = case lookup k h of+ Just t -> return t+ Nothing -> throwError $ MalformedRequest reqHttp $+ "Header missing: " ++ BC.unpack (CI.original k)++ numberFromToken token = case divBySpaces (BC.unpack token) of+ Just n -> return $ encode n+ Nothing -> throwError $ MalformedRequest reqHttp+ "Security token does not contain enough spaces"++data Hybi00 = forall p. Protocol p => Hybi00 p++instance Protocol Hybi00 where+ version (Hybi00 p) = version p+ headerVersion (Hybi00 p) = headerVersion p+ encodeFrame (Hybi00 p) = encodeFrame p+ decodeFrame (Hybi00 p) = decodeFrame p+ finishRequest (Hybi00 p) = finishRequest p+ implementations = [Hybi00 Hybi00_, Hybi00 Hybi10_]++instance TextProtocol Hybi00
+ src/Network/WebSockets/Protocol/Hybi10.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE ExistentialQuantification, OverloadedStrings #-}+module Network.WebSockets.Protocol.Hybi10+ ( Hybi10_ (..)+ , Hybi10+ ) where++import Control.Applicative (pure, (<$>))+import Data.Bits ((.&.), (.|.))+import Data.Monoid (mempty)++import Data.Attoparsec (anyWord8)+import Data.Binary.Get (runGet, getWord16be, getWord64be)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 ()+import Data.Int (Int64)+import qualified Blaze.ByteString.Builder as B+import qualified Data.Attoparsec as A+import qualified Data.ByteString.Lazy as BL+import Data.Digest.Pure.SHA (bytestringDigest, sha1)+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Char8 as BC+import qualified Data.CaseInsensitive as CI+import Control.Monad.Error (throwError)+import Data.Monoid (mappend, mconcat)++import Network.WebSockets.Handshake.Http+import Network.WebSockets.Mask+import Network.WebSockets.Protocol+import Network.WebSockets.Types++data Hybi10_ = Hybi10_++instance Protocol Hybi10_ where+ version Hybi10_ = "hybi10"+ headerVersion Hybi10_ = "8"+ encodeFrame Hybi10_ = encodeFrameHybi10+ decodeFrame Hybi10_ = decodeFrameHybi10+ finishRequest Hybi10_ = handshakeHybi10+ implementations = [Hybi10_]++instance TextProtocol Hybi10_+instance BinaryProtocol Hybi10_++-- | Parse a frame+decodeFrameHybi10 :: Decoder p Frame+decodeFrameHybi10 = do+ byte0 <- anyWord8+ let fin = byte0 .&. 0x80 == 0x80+ 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 ft (masker $ BL.fromChunks chunks)+ where+ runGet' g = runGet g . BL.fromChunks . return++ take64 :: Int64 -> Decoder p [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)++-- | Encode a frame+encodeFrameHybi10 :: Encoder p Frame+encodeFrameHybi10 mask f = B.fromWord8 byte0 `mappend`+ B.fromWord8 byte1 `mappend` len `mappend` maskbytes `mappend`+ B.fromLazyByteString (maskPayload mask (framePayload f))+ where+ byte0 = fin .|. opcode+ fin = if frameFin f then 0x80 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'))+++handshakeHybi10 :: RequestHttpPart -> Decoder p (Either HandshakeError Request)+handshakeHybi10 reqHttp@(RequestHttpPart path h) = return $ do+ case getHeader "Sec-WebSocket-Version" of+ Right "8" -> return ()+ _ -> throwError NotSupported+ key <- getHeader "Sec-WebSocket-Key"+ let hash = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid+ let encoded = B64.encode hash+ return $ Request path h $ response101 [("Sec-WebSocket-Accept", encoded)] ""+ where+ guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"+ lazy = BL.fromChunks . return+ unlazy = mconcat . BL.toChunks+ getHeader k = case lookup k h of+ Just t -> return t+ Nothing -> throwError $+ MalformedRequest reqHttp $ + "Header missing: " ++ BC.unpack (CI.original k)++data Hybi10 = forall p. Protocol p => Hybi10 p++instance Protocol Hybi10 where+ version (Hybi10 p) = version p+ headerVersion (Hybi10 p) = headerVersion p+ encodeFrame (Hybi10 p) = encodeFrame p+ decodeFrame (Hybi10 p) = decodeFrame p+ finishRequest (Hybi10 p) = finishRequest p+ implementations = [Hybi10 Hybi10_]++instance TextProtocol Hybi10+instance BinaryProtocol Hybi10
+ src/Network/WebSockets/Protocol/Unsafe.hs view
@@ -0,0 +1,24 @@+module Network.WebSockets.Protocol.Unsafe+ ( close+ , ping+ , pong+ , textData+ , binaryData+ ) where++import Network.WebSockets.Types++close :: WebSocketsData a => a -> Message p+close = ControlMessage . Close . toLazyByteString++ping :: WebSocketsData a => a -> Message p+ping = ControlMessage . Ping . toLazyByteString++pong :: WebSocketsData a => a -> Message p+pong = ControlMessage . Pong . toLazyByteString++textData :: WebSocketsData a => a -> Message p+textData = DataMessage . Text . toLazyByteString++binaryData :: WebSocketsData a => a -> Message p+binaryData = DataMessage . Binary . toLazyByteString
src/Network/WebSockets/Socket.hs view
@@ -4,62 +4,82 @@ module Network.WebSockets.Socket ( runServer , runWithSocket+ , receiveEnum+ , sendIter ) where +import Prelude hiding (catch)+ import Control.Concurrent (forkIO)+import Control.Exception (SomeException, catch) import Control.Monad (forever) import Control.Monad.Trans (liftIO) -import Network.Socket ( Family (..), SockAddr (..), Socket- , SocketOption (ReuseAddr), SocketType (..)- , accept, bindSocket, defaultProtocol, inet_addr, listen- , sClose, setSocketOption, socket, withSocketsDo- )-import Network.Socket.ByteString (recv, sendMany)- import Data.ByteString (ByteString)-import Data.Enumerator ( Enumerator, Iteratee (..), Stream (..)- , checkContinue0, continue, run, yield, (>>==), ($$)- )+import Data.Enumerator (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 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 :: String -- ^ Address to bind to- -> Int -- ^ Port to listen on- -> WebSockets () -- ^ Application to serve- -> IO () -- ^ Never returns-runServer host port ws = withSocketsDo $ do- sock <- socket AF_INET Stream defaultProtocol- _ <- setSocketOption sock ReuseAddr 1- host' <- inet_addr host- bindSocket sock (SockAddrInet (fromIntegral port) host')- listen sock 5- forever $ do- (conn, _) <- accept sock- _ <- forkIO $ runWithSocket conn ws+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+ flip catch (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 sendIter' 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 :: Socket -> WebSockets a -> IO a+runWithSocket :: Protocol p+ => Socket -> (Request -> WebSockets p a) -> IO a runWithSocket s ws = do- r <- run $ receiveEnum s $$ runWebSockets ws (sendIter s)- sClose s+ r <- E.run $ receiveEnum s $$+ runWebSocketsWithHandshake defaultWebSocketsOptions ws (sendIter s)+ S.sClose s either (error . show) return r +-- | Create an enumerator which reads from a socket and yields the chunks receiveEnum :: Socket -> Enumerator ByteString IO a-receiveEnum s = checkContinue0 $ \loop f -> do- b <- liftIO $ recv s 4096+receiveEnum s = E.checkContinue0 $ \loop f -> do+ b <- liftIO $ SB.recv s 4096 if b == ""- then continue f- else f (Chunks [b]) >>== loop+ then E.continue f+ else f (E.Chunks [b]) >>== loop +-- | Create an iterator which writes to a socket sendIter :: Socket -> Iteratee ByteString IO ()-sendIter s = continue go+sendIter s = E.continue go where- go (Chunks []) = continue go- go (Chunks cs) = liftIO (sendMany s cs) >> continue go- go EOF = yield () EOF+ 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.yield () E.EOF
src/Network/WebSockets/Types.hs view
@@ -1,47 +1,63 @@++{-# LANGUAGE DeriveDataTypeable #-}+ -- | Primary types module Network.WebSockets.Types- ( Headers- , Request (..)- , Response (..)+ ( Decoder+ , Encoder+ , FrameType (..) , Frame (..) , Message (..) , ControlMessage (..) , DataMessage (..) , WebSocketsData (..)++ , ConnectionError (..) ) where +import Control.Exception (Exception(..))+import Data.Typeable (Typeable)++import Data.Attoparsec (Parser)+import qualified Blaze.ByteString.Builder as B+import qualified Data.Attoparsec.Enumerator as AE import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL-import qualified Data.CaseInsensitive as CI import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL --- | Request headers-type Headers = [(CI.CI B.ByteString, B.ByteString)]+import Network.WebSockets.Mask --- | Simple request type-data Request = Request- { requestPath :: !B.ByteString- , requestHeaders :: Headers- } deriving (Show)+-- | An alias so we don't have to import attoparsec everywhere+type Decoder p a = Parser a --- | Response to a 'Request'-data Response = Response- { responseCode :: !Int- , responseMessage :: !B.ByteString- , responseHeaders :: Headers- } deriving (Show)+-- | The inverse of a parser+type Encoder p a = Mask -> a -> B.Builder --- | A frame+-- | 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++-- | A low-level representation of a WebSocket packet data Frame = Frame { frameFin :: !Bool , frameType :: !FrameType , framePayload :: !BL.ByteString } deriving (Eq, Show) --- | Type of a frame+-- | The type of a frame. Not all types are allowed for all protocols. data FrameType = ContinuationFrame | TextFrame@@ -52,25 +68,25 @@ deriving (Eq, Show) -- | The kind of message a server application typically deals with-data Message- = ControlMessage ControlMessage- | DataMessage DataMessage- deriving (Show)+data Message p+ = ControlMessage (ControlMessage p)+ | DataMessage (DataMessage p)+ deriving (Eq, Show) -- | Different control messages-data ControlMessage+data ControlMessage p = Close BL.ByteString | Ping BL.ByteString | Pong BL.ByteString- deriving (Show)+ 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+data DataMessage p = Text BL.ByteString | Binary BL.ByteString- deriving (Show)+ 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
websockets.cabal view
@@ -1,7 +1,5 @@ Name: websockets-Version: 0.3.1.1--Cabal-version: >= 1.6+Version: 0.4.0.0 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell.@@ -9,13 +7,11 @@ Description: This library allows you to write WebSocket-capable servers. .- See an example: <http://github.com/jaspervdj/websockets/tree/master/example>.+ See an example: <http://jaspervdj/.be/websockets/example.html>. . The API of the 'Network.WebSockets' module should also contain enough information to get you started. .- This library currently works with Chromium @>= 14@, and Firefox @>= 6@.- . See also: . * The specification of the WebSocket protocol:@@ -24,21 +20,24 @@ * The JavaScript API for dealing with WebSockets: <http://www.w3.org/TR/websockets/> -License: BSD3-License-file: LICENCE-Copyright: (c) 2010-2011 Siniša Biđin- (c) 2011 Jasper Van der Jeugt--Author: Siniša Biđin <sinisa@bidin.cc>- Jasper Van der Jeugt <m@jaspervdj.be>-Maintainer: Siniša Biđin <sinisa@bidin.cc>- Jasper Van der Jeugt <m@jaspervdj.be>--Stability: experimental-Category: Network-Tested-with: GHC ==6.12+License: BSD3+License-file: LICENCE+Copyright: (c) 2010-2011 Siniša Biđin+ (c) 2011 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>+Maintainer: Jasper Van der Jeugt <m@jaspervdj.be>+Stability: experimental+Category: Network+Build-type: Simple+Cabal-version: >= 1.6 -Build-type: Simple+Homepage: http://jaspervdj.be/websockets+Bug-reports: https://github.com/jaspervdj/websockets/issues Library Hs-source-dirs: src@@ -48,12 +47,16 @@ Network.WebSockets Other-modules:- Network.WebSockets.Decode Network.WebSockets.Demultiplex- Network.WebSockets.Encode Network.WebSockets.Handshake+ Network.WebSockets.Handshake.Http+ Network.WebSockets.Handshake.ShyIterParser Network.WebSockets.Mask Network.WebSockets.Monad+ Network.WebSockets.Protocol+ Network.WebSockets.Protocol.Hybi00+ Network.WebSockets.Protocol.Hybi10+ Network.WebSockets.Protocol.Unsafe Network.WebSockets.Socket Network.WebSockets.Types @@ -67,12 +70,14 @@ blaze-builder-enumerator >= 0.2 && < 0.3, bytestring >= 0.9 && < 0.10, case-insensitive >= 0.3 && < 0.4,+ containers >= 0.3 && < 0.5, enumerator >= 0.4.13 && < 0.5, mtl >= 2.0 && < 2.2, network >= 2.3 && < 2.4, random >= 1.0 && < 1.1, SHA >= 1.5 && < 1.6,- text >= 0.10 && < 0.12+ text >= 0.10 && < 0.12,+ pureMD5 >= 0.2.2 && < 2.2 Source-repository head Type: git