diff --git a/Network/WebSockets.hs b/Network/WebSockets.hs deleted file mode 100644 --- a/Network/WebSockets.hs +++ /dev/null @@ -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 . 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 diff --git a/example.hs b/example.hs deleted file mode 100644 --- a/example.hs +++ /dev/null @@ -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 diff --git a/src/Network/WebSockets.hs b/src/Network/WebSockets.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets.hs @@ -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: +-- +-- +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 diff --git a/src/Network/WebSockets/Decode.hs b/src/Network/WebSockets/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Decode.hs @@ -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) diff --git a/src/Network/WebSockets/Demultiplex.hs b/src/Network/WebSockets/Demultiplex.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Demultiplex.hs @@ -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 diff --git a/src/Network/WebSockets/Encode.hs b/src/Network/WebSockets/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Encode.hs @@ -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 diff --git a/src/Network/WebSockets/Handshake.hs b/src/Network/WebSockets/Handshake.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Handshake.hs @@ -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 diff --git a/src/Network/WebSockets/Mask.hs b/src/Network/WebSockets/Mask.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Mask.hs @@ -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) diff --git a/src/Network/WebSockets/Monad.hs b/src/Network/WebSockets/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Monad.hs @@ -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 diff --git a/src/Network/WebSockets/Socket.hs b/src/Network/WebSockets/Socket.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Socket.hs @@ -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 diff --git a/src/Network/WebSockets/Types.hs b/src/Network/WebSockets/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Types.hs @@ -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 diff --git a/websockets.cabal b/websockets.cabal --- a/websockets.cabal +++ b/websockets.cabal @@ -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: . + 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: . . - 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: + + . + * The JavaScript API for dealing with 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 -Bug-reports: mailto:sinisa@bidin.cc +Author: Siniša Biđin + Jasper Van der Jeugt +Maintainer: Siniša Biđin + Jasper Van der Jeugt 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