websockets 0.3.0.0 → 0.3.1.0
raw patch · 12 files changed
+869/−340 lines, 12 filesdep +SHAdep +attoparsecdep +attoparsec-enumeratordep −containersdep −pureMD5dep ~binarydep ~bytestringdep ~networknew-uploader
Dependencies added: SHA, attoparsec, attoparsec-enumerator, base64-bytestring, blaze-builder, blaze-builder-enumerator, case-insensitive, enumerator, mtl, random, text
Dependencies removed: containers, pureMD5
Dependency ranges changed: binary, bytestring, network
Files
- Network/WebSockets.hs +0/−285
- example.hs +0/−39
- src/Network/WebSockets.hs +173/−0
- src/Network/WebSockets/Decode.hs +86/−0
- src/Network/WebSockets/Demultiplex.hs +52/−0
- src/Network/WebSockets/Encode.hs +106/−0
- src/Network/WebSockets/Handshake.hs +60/−0
- src/Network/WebSockets/Mask.hs +24/−0
- src/Network/WebSockets/Monad.hs +135/−0
- src/Network/WebSockets/Socket.hs +65/−0
- src/Network/WebSockets/Types.hs +106/−0
- websockets.cabal +62/−16
− Network/WebSockets.hs
@@ -1,285 +0,0 @@-{- | How do you use this library? Here's how:-- * Get a 'Handle' to your connected client.-- * Perform the initial handshake with 'shakeHands' (or 'getRequest' and 'putResponse').-- * Send and receive strict bytestrings with 'putFrame' and 'getFrame'.--And here's a short example of a server that accepts clients, greets-them with a welcome message, checks for disconnects and replies to all-messages by echoing them back with an appended meow:--> import Network.WebSockets (shakeHands, getFrame, putFrame)-> import Network (listenOn, PortID(PortNumber), accept, withSocketsDo)-> import System.IO (Handle, hClose)-> import qualified Data.ByteString as B (append, null)-> import Data.ByteString.UTF8 (fromString) -- this is from utf8-string-> import Control.Monad (forever)-> import Control.Concurrent (forkIO)->-> -- Accepts clients, spawns a single handler for each one.-> main :: IO ()-> main = withSocketsDo $ do-> socket <- listenOn (PortNumber 8088)-> putStrLn "Listening on port 8088."-> forever $ do-> (h, _, _) <- accept socket-> forkIO (talkTo h)->-> -- Shakes hands with client. If no error, starts talking.-> talkTo :: Handle -> IO ()-> talkTo h = do-> request <- shakeHands h-> case request of-> Left err -> print err-> Right _ -> do-> putFrame h (fromString "Do you read me, Lieutenant Bowie?")-> putStrLn "Shook hands, sent welcome message."-> talkLoop h->-> -- Talks to the client (by echoing messages back) until EOF.-> talkLoop :: Handle -> IO ()-> talkLoop h = do-> msg <- getFrame h-> if B.null msg-> then do-> putStrLn "EOF encountered. Closing handle."-> hClose h-> else do-> putFrame h $ B.append msg (fromString ", meow.")-> talkLoop h--The example above will suffice if you wish to accept any-WebSocket-capable client, regardless of its origin or target. It won't-suffice if you have to filter the incoming clients by the contents of-their requests. For that, you can use 'getRequest' and 'putResponse',-which allow you to inspect the request details /before/ you send back-a response, if any.--If you have any suggestions, bug reports and\/or fixes, feel free to-send them to <mailto:sinisa@bidin.cc>. Thanks! -}-module Network.WebSockets (-shakeHands, getRequest, putResponse, createResponse, getFrame,-putFrame, createToken, Request(..), HandshakeError(..)) where--import System.IO (Handle, hFlush)-import Data.Binary (encode)-import Data.Int (Int32)--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Data.Digest.Pure.MD5 (md5)-import Data.Char (isDigit, chr, ord)-import Data.List (isPrefixOf, isSuffixOf)-import qualified Control.Exception as E-import qualified Data.Map as M----- | Contains the request details.-data Request = Request {- reqHost :: String, -- ^ The requested host.- reqPath :: String, -- ^ The requested path.- reqOrigin :: String, -- ^ The origin of the request.- reqKey1 :: String, -- ^ The first security key.- reqKey2 :: String, -- ^ The second security key.- reqToken :: String -- ^ The given eight-byte token.-} deriving (Show)----- Contains the client's request. The eight-byte token is under key--- \"Token\", while the requested path is under key \"Path\". Others--- are the same as in the request header: \"Origin\", \"Upgrade\" and--- \"Sec-WebSocket-Key2\", to name a few.-type RawRequest = M.Map String String----- | Error in case of failed handshake.-data HandshakeError = HsIOError String- | HsInvalidGETRequest String- | HsInvalidHeaderLine String- | HsMissingHeaderKeys String- | HsBadFirstSecurityKey String- | HsBadSecondSecurityKey String- deriving (Show)----- | Accept and perform a handshake, no matter the request contents.------ As long as the request is well-formed, the client will receive a--- response saying, essentially, \"proceed\". Use this function if you--- don't care who you're connected to, as long as that someone speaks--- the WebSocket protocol.------ The function returns either a 'HandshakeError' in case of error, or--- a 'Request' on success. The 'Request' is returned purely for--- logging purposes, since the handshake has already been--- executed. Use this function immediately after establishing the--- connection.------ If you wish not to blindly accept requests but to filter them--- according to their contents, use the 'getRequest' and 'putResponse'--- functions.-shakeHands :: Handle -> IO (Either HandshakeError Request)-shakeHands h = do- request <- getRequest h- case request of- Right r -> putResponse h r >> return request- Left _ -> return request -- Returns the error.------ | Reads the client's opening handshake and returns either a--- 'Request' based on its contents, or a 'HandshakeError' in case of--- an error.-getRequest :: Handle -> IO (Either HandshakeError Request)-getRequest h = do- -- The first line should be "GET :path: HTTP/1.1".- first <- toString `fmap` B.hGetLine h- if "GET " `isPrefixOf` first && " HTTP/1.1\r" `isSuffixOf` first- -- Start stepping through following headers, collecting them.- then (step.M.singleton "Path" $ words first !! 1)- `E.catch`- (\e -> return . Left . HsIOError $ show (e::E.SomeException))- else return.Left $ HsInvalidGETRequest first-- where- -- Collect header keys and values.- -- Stops in case of error or upon reading the final 8-byte token.- step :: RawRequest -> IO (Either HandshakeError Request)- step req = do- line <- toString `fmap` B.hGetLine h- if null line- then return.Left $ HsInvalidHeaderLine line-- -- Else, split line in half. We get the header key (++':') and value.- else case break (==' ') (init line) of- ("", "") -> do- -- The line is empty, so the next 8 bytes are the token.- bytes <- (map (chr.fromIntegral) . BL.unpack) `fmap` BL.hGet h 8- -- We have the whole request. Validate it and return result.- return.validateRequest $ M.insert "Token" bytes req-- (key, val) ->- step $ M.insert (init key) (tail val) req----- Checks if a given raw request is valid or not. A valid request--- won't cause a division by zero when calculating a response token--- and contains all the neccessary data to create a response. Returns--- either a 'HandshakeError' if the request is not valid, or a valid--- 'Request'.-validateRequest :: RawRequest -> Either HandshakeError Request-validateRequest req- | lacksHeaderKeys = Left $ HsMissingHeaderKeys (show req)- | faultyKey 1 = Left $ HsBadFirstSecurityKey (show req)- | faultyKey 2 = Left $ HsBadSecondSecurityKey (show req)- | otherwise = Right $ fromRaw req-- where- -- Is there a header key (and value) that we don't have, but need?- lacksHeaderKeys = any (`M.notMember` req)- ["Host", "Path", "Origin", "Token",- "Sec-WebSocket-Key1", "Sec-WebSocket-Key2"]-- -- Are there no spaces in a security key value? We can't divide by 0.- -- If there are no spaces, return False.- faultyKey :: Int -> Bool- faultyKey n =- let key = req M.! ("Sec-WebSocket-Key" ++ show n)- in null $ filter (==' ') key-- -- Converts a RawRequest to a final Request.- fromRaw :: RawRequest -> Request- fromRaw r = Request { reqHost = r M.! "Host"- , reqPath = r M.! "Path"- , reqOrigin = r M.! "Origin"- , reqKey1 = r M.! "Sec-WebSocket-Key1"- , reqKey2 = r M.! "Sec-WebSocket-Key2"- , reqToken = r M.! "Token" }----- | Sends an accepting response based on the given 'Request', thus--- accepting and ending the handshake.-putResponse :: Handle -> Request -> IO ()-putResponse h req = B.hPutStr h (createResponse req)----- | Returns an accepting response based on the given--- 'Request'. 'putResponse' uses this function internally.-createResponse :: Request -> B.ByteString-createResponse req = B.append (fromString header) (createToken req)- where header =- "HTTP/1.1 101 WebSocket Protocol Handshake\r\n\- \Upgrade: WebSocket\r\n\- \Connection: Upgrade\r\n\- \Sec-WebSocket-Origin: "++ reqOrigin req ++"\r\n\- \Sec-WebSocket-Location: ws://"++ reqHost req ++ reqPath req ++"\r\n\- \Sec-WebSocket-Protocol: sample\r\n\r\n"----- | Constructs the response token by using the two security keys the--- and eight-byte token given in the request, as defined by the--- protocol.-createToken :: Request -> B.ByteString-createToken req = B.pack $ BL.unpack (encode hash)- where- hash = md5 $ BL.concat [num1, num2, token]- [num1, num2] = map (encode.divBySpaces) [reqKey1 req, reqKey2 req]- token = BL.pack $ map (fromIntegral.ord) (reqToken req)----- Divides the number hiding in the string by the number of spaces in--- the string, as defined in the protocol. Assumes division by zero--- will not occur, since the request was verified to be valid--- beforehand.-divBySpaces :: String -> Int32-divBySpaces str =- let number = read $ filter isDigit str :: Integer- spaces = fromIntegral . length $ filter (==' ') str- in fromIntegral $ number `div` spaces----- | Send a strict ByteString. Call this function only after having--- performed the handshake.-putFrame :: Handle -> B.ByteString -> IO ()-putFrame h bs = do- let frame = B.cons 0 (B.snoc bs 255)- B.hPutStr h frame- hFlush h----- | Receive a strict ByteString. Call this function only after having--- performed the handshake. This function will block until an entire--- frame is read. If the writing end of the handle is closed, the--- function returns an empty ByteString.-getFrame :: Handle -> IO B.ByteString-getFrame h = do- first <- B.hGet h 1 -- The first byte should be zero.- if B.null first -- In case of EOF, return empty ByteString.- then return B.empty-- -- What if the first byte isn't zero? The frame is invalid.- -- Ignore this and consider the byte part of the frame contents.- else if first /= B.singleton 0- then readUntil255 first -- Byte becomes first in buffer.- else readUntil255 B.empty -- Start with empty buffer, as should be.-- where- -- Read bytes from the handle, accumulating them, until 255 is reached.- readUntil255 buf = do- b <- B.hGet h 1- if B.null b- then return B.empty -- Return empty in case of EOF.- else if b == B.singleton 255- then return buf- else readUntil255 (B.append buf b)------ Quick and dirty String<->B.ByteString conversions.-fromString :: String -> B.ByteString-fromString = B.pack . map (fromIntegral.ord)--toString :: B.ByteString -> String-toString = map (chr.fromIntegral) . B.unpack
− example.hs
@@ -1,39 +0,0 @@- import Network.WebSockets (shakeHands, getFrame, putFrame)- import Network (listenOn, PortID(PortNumber), accept, withSocketsDo)- import System.IO (Handle, hClose)- import qualified Data.ByteString as B (append, null)- import Data.ByteString.UTF8 (fromString) -- this is from utf8-string- import Control.Monad (forever)- import Control.Concurrent (forkIO)-- -- Accepts clients, spawns a single handler for each one.- main :: IO ()- main = withSocketsDo $ do- socket <- listenOn (PortNumber 8088)- putStrLn "Listening on port 8088."- forever $ do- (h, _, _) <- accept socket- forkIO (talkTo h)-- -- Shakes hands with client. If no error, starts talking.- talkTo :: Handle -> IO ()- talkTo h = do- request <- shakeHands h- case request of- Left err -> print err- Right _ -> do- putFrame h (fromString "Do you read me, Lieutenant Bowie?")- putStrLn "Shook hands, sent welcome message."- talkLoop h-- -- Talks to the client (by echoing messages back) until EOF.- talkLoop :: Handle -> IO ()- talkLoop h = do- msg <- getFrame h- if B.null msg- then do- putStrLn "EOF encountered. Closing handle."- hClose h- else do- putFrame h $ B.append msg (fromString ", meow.")- talkLoop h
+ src/Network/WebSockets.hs view
@@ -0,0 +1,173 @@+-- | 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.+--+-- * 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.+--+-- There are (informally) three ways in which you can use the library:+--+-- * 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 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.+--+-- * 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.+--+-- 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.+--+-- For a full example, see:+--+-- <http://github.com/jaspervdj/websockets/tree/master/example>+module Network.WebSockets+ ( + -- * WebSocket type+ I.WebSocketsOptions (..)+ , I.defaultWebSocketsOptions+ , I.WebSockets+ , I.runWebSockets+ , I.runWebSocketsWith++ -- * A simple standalone server+ , I.runServer+ , I.runWithSocket++ -- * Types+ , I.Headers+ , I.Request (..)+ , I.Response (..)+ , I.FrameType (..)+ , I.Frame (..)+ , I.Message (..)+ , I.ControlMessage (..)+ , I.DataMessage (..)+ , I.WebSocketsData (..)++ -- * Initial handshake+ , H.HandshakeError (..)+ , receiveRequest+ , sendResponse+ , H.handshake++ -- * Sending and receiving+ , receiveFrame+ , sendFrame+ , receiveMessage+ , sendMessage+ , receiveDataMessage+ , sendDataMessage+ , receiveData+ , 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+ ) 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.Monad as I+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++-- | Read a 'I.Frame' from the socket. Blocks until a frame is received and+-- returns 'Nothing' if the socket has been closed.+--+-- 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++-- | 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 an application message. Automatically respond to control messages.+receiveDataMessage :: I.WebSockets (Maybe I.DataMessage)+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+ I.Pong _ -> do+ options <- I.getOptions+ liftIO $ I.onPong options+ receiveDataMessage+ I.Ping pl -> do+ I.send E.controlMessage (I.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 = 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)++-- | Send a text message+sendTextData :: I.WebSocketsData a => a -> I.WebSockets ()+sendTextData = I.send E.textData++-- | Send some binary data+sendBinaryData :: I.WebSocketsData a => a -> I.WebSockets ()+sendBinaryData = I.send E.binaryData
+ src/Network/WebSockets/Decode.hs view
@@ -0,0 +1,86 @@+-- | 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
@@ -0,0 +1,52 @@+-- | Demultiplexing of frames into messages+module Network.WebSockets.Demultiplex+ ( DemultiplexState+ , emptyDemultiplexState+ , demultiplex+ ) where++import Blaze.ByteString.Builder (Builder)+import Data.Monoid (mappend)+import qualified Blaze.ByteString.Builder as B++import Network.WebSockets.Types++-- | Internal state used by the demultiplexer+newtype DemultiplexState = DemultiplexState+ { unDemultiplexState :: Maybe (FrameType, Builder)+ }++emptyDemultiplexState :: DemultiplexState+emptyDemultiplexState = DemultiplexState Nothing++demultiplex :: DemultiplexState -> Frame -> (Maybe Message, DemultiplexState)+demultiplex state (Frame fin tp pl) = case tp of+ -- Return control messages immediately, they have no influence on the state+ CloseFrame -> (Just (ControlMessage (Close pl)), state)+ PingFrame -> (Just (ControlMessage (Ping pl)), state)+ PongFrame -> (Just (ControlMessage (Pong pl)), state)+ -- If we're dealing with a continuation...+ ContinuationFrame -> case unDemultiplexState state of+ -- We received a continuation but we don't have any state. Let's ignore+ -- this fragment...+ Nothing -> (Nothing, DemultiplexState Nothing)+ -- Append the payload to the state+ -- TODO: protect against overflows+ Just (amt, b)+ | not fin -> (Nothing, DemultiplexState (Just (amt, b')))+ | otherwise -> case amt of+ TextFrame -> (Just (DataMessage (Text m)), e)+ BinaryFrame -> (Just (DataMessage (Binary m)), e)+ _ -> error "Demultiplex.demultiplex: Internal error"+ where+ b' = b `mappend` plb+ m = B.toLazyByteString b'+ TextFrame+ | fin -> (Just (DataMessage (Text pl)), e)+ | otherwise -> (Nothing, DemultiplexState (Just (TextFrame, plb)))+ BinaryFrame+ | fin -> (Just (DataMessage (Binary pl)), e)+ | otherwise -> (Nothing, DemultiplexState (Just (BinaryFrame, plb)))+ where+ e = emptyDemultiplexState+ plb = B.fromLazyByteString pl
+ src/Network/WebSockets/Encode.hs view
@@ -0,0 +1,106 @@+-- | 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
@@ -0,0 +1,60 @@+-- | Implementation of the WebSocket handshake+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Handshake+ ( HandshakeError (..)+ , handshake+ , response101+ , response400+ ) 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 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.+--+-- 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)]+ 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++-- | Bad request+response400 :: Headers -> Response+response400 headers = Response 400 "Bad Request" headers
+ src/Network/WebSockets/Mask.hs view
@@ -0,0 +1,24 @@+-- | Masking of fragmes using a simple XOR algorithm+{-# LANGUAGE BangPatterns #-}+module Network.WebSockets.Mask+ ( Mask+ , maskPayload+ ) where++import Data.Bits (xor)++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL++-- | ByteString should be exactly 4 bytes long+type Mask = Maybe B.ByteString++-- | Apply mask+maskPayload :: Mask -> BL.ByteString -> BL.ByteString+maskPayload Nothing = id+maskPayload (Just mask) = snd . BL.mapAccumL f 0+ where+ len = B.length mask+ f !i !c = let i' = (i + 1) `mod` len+ m = mask `B.index` i+ in (i', m `xor` c)
+ src/Network/WebSockets/Monad.hs view
@@ -0,0 +1,135 @@+-- | Provides a simple, clean monad to write websocket servers in+{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}+module Network.WebSockets.Monad+ ( WebSocketsOptions (..)+ , defaultWebSocketsOptions+ , WebSockets (..)+ , runWebSockets+ , runWebSocketsWith+ , receive+ , send+ , Sender+ , getSender+ , getOptions+ ) where++import Control.Applicative ((<$>))+import Control.Concurrent.MVar (newMVar, takeMVar, putMVar)+import Control.Concurrent (forkIO, threadDelay)+import Control.Monad (forever, replicateM)+import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Control.Monad.State (StateT, evalStateT)+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 Network.WebSockets.Demultiplex (DemultiplexState, emptyDemultiplexState)+import Network.WebSockets.Encode (Encoder)+import qualified Network.WebSockets.Encode as E++-- | 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 ())++-- | The monad in which you can write WebSocket-capable applications+newtype WebSockets a = WebSockets+ { unWebSockets :: ReaderT WebSocketsEnv+ (StateT DemultiplexState (Iteratee ByteString IO)) a+ } deriving (Functor, Monad, MonadIO)++-- | Run a 'WebSockets' application on an 'Enumerator'/'Iteratee' pair.+runWebSockets :: WebSockets 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+ -> Iteratee ByteString IO ()+ -> Iteratee ByteString IO a+runWebSocketsWith options ws outIter = do+ sendLock <- liftIO $ newMVar () + let sender = makeSend sendLock+ env = WebSocketsEnv options sender+ state = runReaderT (unWebSockets ws') env+ iter = evalStateT state emptyDemultiplexState+++ iter+ where+ makeSend sendLock x = do+ () <- takeMVar sendLock+ _ <- run $ singleton x $$ builderToByteString $$ outIter+ putMVar sendLock ()++ singleton c = checkContinue0 $ \_ f -> f (Chunks [c]) >>== returnI++ -- Spawn a ping thread first+ ws' = spawnPingThread >> ws++-- | 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+ sender E.ping ("Hi" :: ByteString)+ threadDelay (i * 1000 * 1000) -- seconds+ return ()++-- | 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)++-- | Low-level sending with an arbitrary 'Encoder'+send :: Encoder a -> a -> WebSockets ()+send encoder x = do+ sender <- getSender+ liftIO $ sender encoder x++-- | For asynchronous sending+type Sender a = Encoder a -> a -> IO ()++-- | 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,+-- 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)+ where+ randomByte = fromIntegral <$> randomRIO (0x00 :: Int, 0xff)++-- | Get the current configuration+getOptions :: WebSockets WebSocketsOptions+getOptions = WebSockets $ ask >>= \(WebSocketsEnv options _) -> return options
+ src/Network/WebSockets/Socket.hs view
@@ -0,0 +1,65 @@+-- | Simple module which provides the low-level socket handling in case you want+-- to write a stand-alone 'WebSockets' application.+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Socket+ ( runServer+ , runWithSocket+ ) where++import Control.Concurrent (forkIO)+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 Network.WebSockets.Monad++-- | 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+ return ()++-- | This function wraps 'runWebSockets' in order to provide a simple API for+-- stand-alone servers.+runWithSocket :: Socket -> WebSockets a -> IO a+runWithSocket s ws = do+ r <- run $ receiveEnum s $$ runWebSockets ws (sendIter s)+ sClose s+ either (error . show) return r++receiveEnum :: Socket -> Enumerator ByteString IO a+receiveEnum s = checkContinue0 $ \loop f -> do+ b <- liftIO $ recv s 4096+ if b == ""+ then continue f+ else f (Chunks [b]) >>== loop++sendIter :: Socket -> Iteratee ByteString IO ()+sendIter s = continue go+ where+ go (Chunks []) = continue go+ go (Chunks cs) = liftIO (sendMany s cs) >> continue go+ go EOF = yield () EOF
+ src/Network/WebSockets/Types.hs view
@@ -0,0 +1,106 @@+-- | Primary types+module Network.WebSockets.Types+ ( Headers+ , Request (..)+ , Response (..)+ , FrameType (..)+ , Frame (..)+ , Message (..)+ , ControlMessage (..)+ , DataMessage (..)+ , WebSocketsData (..)+ ) where++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)]++-- | Simple request type+data Request = Request+ { requestPath :: !B.ByteString+ , requestHeaders :: Headers+ } deriving (Show)++-- | Response to a 'Request'+data Response = Response+ { responseCode :: !Int+ , responseMessage :: !B.ByteString+ , responseHeaders :: Headers+ } deriving (Show)++-- | A frame+data Frame = Frame+ { frameFin :: !Bool+ , frameType :: !FrameType+ , framePayload :: !BL.ByteString+ } deriving (Eq, Show)++-- | Type of a frame+data FrameType+ = ContinuationFrame+ | TextFrame+ | BinaryFrame+ | CloseFrame+ | PingFrame+ | PongFrame+ deriving (Eq, Show)++-- | The kind of message a server application typically deals with+data Message+ = ControlMessage ControlMessage+ | DataMessage DataMessage+ deriving (Show)++-- | Different control messages+data ControlMessage+ = Close BL.ByteString+ | Ping BL.ByteString+ | Pong BL.ByteString+ deriving (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 (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
websockets.cabal view
@@ -1,24 +1,38 @@-Name: websockets-Version: 0.3.0.0+Name: websockets+Version: 0.3.1.0 -Cabal-version: >=1.6+Cabal-version: >= 1.6 -Synopsis: Create WebSocket servers+Synopsis:+ A sensible and clean way to write WebSocket-capable servers in Haskell. Description:- A library for creating WebSocket-capable servers, where the implemented protocol is defined here: <http://is.gd/eSdLB>.+ This library allows you to write WebSocket-capable servers. .- This library is tested with Chromium >=7, Opera >=11 and Firefox >=4 and is a work in progress. (Note: many of these newest browsers have recently stopped shipping with websockets enabled by default, due to security issues which are yet to be resolved.)+ See an example: <http://github.com/jaspervdj/websockets/tree/master/example>. .- An example of usage can be found in the Network.WebSockets module documentation.+ 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:+ <http://www.whatwg.org/specs/web-socket-protocol/>+ .+ * The JavaScript API for dealing with WebSockets:+ <http://www.w3.org/TR/websockets/> -License: BSD3-License-file: LICENCE-Copyright: (c) 2010 Siniša Biđin+License: BSD3+License-file: LICENCE+Copyright: (c) 2010-2011 Siniša Biđin+ (c) 2011 Jasper Van der Jeugt -Author: Siniša Biđin-Maintainer: Siniša Biđin <sinisa@bidin.cc>-Bug-reports: mailto:sinisa@bidin.cc+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@@ -27,7 +41,39 @@ Build-type: Simple Library- Exposed-Modules: Network.WebSockets- Build-depends: pureMD5 >=2.1, network >=2.2.1.7, base ==4.*,- bytestring >=0.9, binary >=0.5, containers >=0.3+ Hs-source-dirs: src+ Ghc-options: -Wall + Exposed-modules:+ Network.WebSockets++ Other-modules:+ Network.WebSockets.Decode+ Network.WebSockets.Demultiplex+ Network.WebSockets.Encode+ Network.WebSockets.Handshake+ Network.WebSockets.Mask+ Network.WebSockets.Monad+ Network.WebSockets.Socket+ Network.WebSockets.Types++ Build-depends:+ attoparsec >= 0.9 && < 0.10,+ attoparsec-enumerator >= 0.2 && < 0.3,+ base >= 4 && < 5,+ base64-bytestring >= 0.1 && < 0.2,+ binary >= 0.5 && < 0.6,+ blaze-builder >= 0.3 && < 0.4,+ blaze-builder-enumerator >= 0.2 && < 0.3,+ bytestring >= 0.9 && < 0.10,+ case-insensitive >= 0.3 && < 0.4,+ 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++Source-repository head+ Type: git+ Location: https://github.com/jaspervdj/websockets