diff --git a/LICENCE b/LICENCE --- a/LICENCE +++ b/LICENCE @@ -1,4 +1,4 @@ -Copyright Siniša Biđin, 2010 +Copyright Jasper Van der Jeugt, 2011 All rights reserved. diff --git a/src/Network/WebSockets.hs b/src/Network/WebSockets.hs --- a/src/Network/WebSockets.hs +++ b/src/Network/WebSockets.hs @@ -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: -- --- +-- +{-# 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 diff --git a/src/Network/WebSockets/Decode.hs b/src/Network/WebSockets/Decode.hs deleted file mode 100644 --- a/src/Network/WebSockets/Decode.hs +++ /dev/null @@ -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) diff --git a/src/Network/WebSockets/Demultiplex.hs b/src/Network/WebSockets/Demultiplex.hs --- a/src/Network/WebSockets/Demultiplex.hs +++ b/src/Network/WebSockets/Demultiplex.hs @@ -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) diff --git a/src/Network/WebSockets/Encode.hs b/src/Network/WebSockets/Encode.hs deleted file mode 100644 --- a/src/Network/WebSockets/Encode.hs +++ /dev/null @@ -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 diff --git a/src/Network/WebSockets/Handshake.hs b/src/Network/WebSockets/Handshake.hs --- a/src/Network/WebSockets/Handshake.hs +++ b/src/Network/WebSockets/Handshake.hs @@ -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]))] diff --git a/src/Network/WebSockets/Handshake/Http.hs b/src/Network/WebSockets/Handshake/Http.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Handshake/Http.hs @@ -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 "" diff --git a/src/Network/WebSockets/Handshake/ShyIterParser.hs b/src/Network/WebSockets/Handshake/ShyIterParser.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Handshake/ShyIterParser.hs @@ -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) diff --git a/src/Network/WebSockets/Mask.hs b/src/Network/WebSockets/Mask.hs --- a/src/Network/WebSockets/Mask.hs +++ b/src/Network/WebSockets/Mask.hs @@ -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) diff --git a/src/Network/WebSockets/Monad.hs b/src/Network/WebSockets/Monad.hs --- a/src/Network/WebSockets/Monad.hs +++ b/src/Network/WebSockets/Monad.hs @@ -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 diff --git a/src/Network/WebSockets/Protocol.hs b/src/Network/WebSockets/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Protocol.hs @@ -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 diff --git a/src/Network/WebSockets/Protocol/Hybi00.hs b/src/Network/WebSockets/Protocol/Hybi00.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Protocol/Hybi00.hs @@ -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 diff --git a/src/Network/WebSockets/Protocol/Hybi10.hs b/src/Network/WebSockets/Protocol/Hybi10.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Protocol/Hybi10.hs @@ -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 diff --git a/src/Network/WebSockets/Protocol/Unsafe.hs b/src/Network/WebSockets/Protocol/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Protocol/Unsafe.hs @@ -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 diff --git a/src/Network/WebSockets/Socket.hs b/src/Network/WebSockets/Socket.hs --- a/src/Network/WebSockets/Socket.hs +++ b/src/Network/WebSockets/Socket.hs @@ -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 diff --git a/src/Network/WebSockets/Types.hs b/src/Network/WebSockets/Types.hs --- a/src/Network/WebSockets/Types.hs +++ b/src/Network/WebSockets/Types.hs @@ -1,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 diff --git a/websockets.cabal b/websockets.cabal --- a/websockets.cabal +++ b/websockets.cabal @@ -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: . + See an example: . . 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: -License: BSD3 -License-file: LICENCE -Copyright: (c) 2010-2011 Siniša Biđin - (c) 2011 Jasper Van der Jeugt - -Author: Siniša Biđin - Jasper Van der Jeugt -Maintainer: Siniša Biđin - Jasper Van der Jeugt - -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 + Jasper Van der Jeugt + Steffen Schuldenzucker + Alex Lang +Maintainer: Jasper Van der Jeugt +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