websockets-0.8.1.1/0000755000000000000000000000000012251561173012221 5ustar0000000000000000websockets-0.8.1.1/LICENCE0000644000000000000000000000277012251561173013214 0ustar0000000000000000Copyright Jasper Van der Jeugt, 2011 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Siniša Biđin nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. websockets-0.8.1.1/Setup.hs0000644000000000000000000000005612251561173013656 0ustar0000000000000000import Distribution.Simple main = defaultMain websockets-0.8.1.1/websockets.cabal0000644000000000000000000000726212251561173015365 0ustar0000000000000000Name: websockets Version: 0.8.1.1 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell. Description: This library allows you to write WebSocket-capable servers. . An example server: . An example client: . See also: . * The specification of the WebSocket protocol: . * The JavaScript API for dealing with WebSockets: License: BSD3 License-file: LICENCE Copyright: (c) 2010-2011 Siniša Biđin (c) 2011-2013 Jasper Van der Jeugt (c) 2011 Steffen Schuldenzucker (c) 2011 Alex Lang Author: Siniša Biđin Jasper Van der Jeugt Steffen Schuldenzucker Alex Lang Maintainer: Jasper Van der Jeugt Stability: experimental Category: Network Build-type: Simple Cabal-version: >= 1.8 Homepage: http://jaspervdj.be/websockets Bug-reports: https://github.com/jaspervdj/websockets/issues Library Hs-source-dirs: src Ghc-options: -Wall Exposed-modules: Network.WebSockets Network.WebSockets.Connection -- Network.WebSockets.Util.PubSub TODO Other-modules: Network.WebSockets.Client Network.WebSockets.Http Network.WebSockets.Hybi13 Network.WebSockets.Hybi13.Demultiplex Network.WebSockets.Hybi13.Mask Network.WebSockets.Protocol Network.WebSockets.Server Network.WebSockets.Types Build-depends: attoparsec >= 0.9 && < 0.11, base >= 4 && < 5, base64-bytestring >= 0.1 && < 1.1, binary >= 0.5 && < 0.8, blaze-builder >= 0.3 && < 0.4, bytestring >= 0.9 && < 0.11, case-insensitive >= 0.3 && < 1.2, containers >= 0.3 && < 0.6, io-streams >= 1.1 && < 1.2, mtl >= 2.0 && < 2.2, network >= 2.3 && < 2.5, random >= 1.0 && < 1.1, SHA >= 1.5 && < 1.7, text >= 0.10 && < 1.1, entropy >= 0.2.1 && < 0.3 Test-suite websockets-tests Type: exitcode-stdio-1.0 Hs-source-dirs: src tests/haskell Main-is: TestSuite.hs Ghc-options: -Wall Other-modules: Network.WebSockets.Handshake.Tests Network.WebSockets.Http.Tests Network.WebSockets.Server.Tests Network.WebSockets.Tests Network.WebSockets.Tests.Util Build-depends: HUnit >= 1.2 && < 1.3, QuickCheck >= 2.4 && < 2.7, test-framework >= 0.4 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, test-framework-quickcheck2 >= 0.2 && < 0.4, -- Copied from regular dependencies... attoparsec >= 0.9 && < 0.11, base >= 4 && < 5, base64-bytestring >= 0.1 && < 1.1, binary >= 0.5 && < 0.8, blaze-builder >= 0.3 && < 0.4, bytestring >= 0.9 && < 0.11, case-insensitive >= 0.3 && < 1.2, containers >= 0.3 && < 0.6, io-streams >= 1.1 && < 1.2, mtl >= 2.0 && < 2.2, network >= 2.3 && < 2.5, random >= 1.0 && < 1.1, SHA >= 1.5 && < 1.7, text >= 0.10 && < 1.1, entropy >= 0.2.1 && < 0.3 Source-repository head Type: git Location: https://github.com/jaspervdj/websockets websockets-0.8.1.1/src/0000755000000000000000000000000012251561173013010 5ustar0000000000000000websockets-0.8.1.1/src/Network/0000755000000000000000000000000012251561173014441 5ustar0000000000000000websockets-0.8.1.1/src/Network/WebSockets.hs0000644000000000000000000000273512251561173017055 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE ScopedTypeVariables #-} module Network.WebSockets ( -- * Incoming connections and handshaking PendingConnection , pendingRequest , acceptRequest , rejectRequest -- * Main connection type , Connection -- * Options for connections , ConnectionOptions (..) , defaultConnectionOptions -- * Sending and receiving messages , receive , receiveDataMessage , receiveData , send , sendDataMessage , sendTextData , sendBinaryData , sendClose , sendPing -- * HTTP Types , Headers , Request (..) , RequestHead (..) , Response (..) , ResponseHead (..) -- * WebSocket message types , Message (..) , ControlMessage (..) , DataMessage (..) , WebSocketsData (..) -- * Exceptions , HandshakeException (..) , ConnectionException (..) -- * Running a standalone server , ServerApp , runServer , runServerWith -- * Running a client , ClientApp , runClient , runClientWith , runClientWithSocket , runClientWithStream ) where -------------------------------------------------------------------------------- import Network.WebSockets.Client import Network.WebSockets.Connection import Network.WebSockets.Http import Network.WebSockets.Server import Network.WebSockets.Types websockets-0.8.1.1/src/Network/WebSockets/0000755000000000000000000000000012251561173016512 5ustar0000000000000000websockets-0.8.1.1/src/Network/WebSockets/Client.hs0000644000000000000000000001133112251561173020263 0ustar0000000000000000-------------------------------------------------------------------------------- -- | This part of the library provides you with utilities to create WebSockets -- clients (in addition to servers). module Network.WebSockets.Client ( ClientApp , runClient , runClientWith , runClientWithSocket , runClientWithStream ) where -------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as Builder import Control.Exception (finally) import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.Socket as S import qualified System.IO.Streams as Streams import qualified System.IO.Streams.Attoparsec as Streams -------------------------------------------------------------------------------- import Network.WebSockets.Connection import Network.WebSockets.Http import Network.WebSockets.Protocol import Network.WebSockets.Types -------------------------------------------------------------------------------- -- | A client application interacting with a single server. Once this 'IO' -- action finished, the underlying socket is closed automatically. type ClientApp a = Connection -> IO a -------------------------------------------------------------------------------- -- TODO: Maybe this should all be strings runClient :: String -- ^ Host -> Int -- ^ Port -> String -- ^ Path -> ClientApp a -- ^ Client application -> IO a runClient host port path ws = runClientWith host port path defaultConnectionOptions [] ws -------------------------------------------------------------------------------- runClientWith :: String -- ^ Host -> Int -- ^ Port -> String -- ^ Path -> ConnectionOptions -- ^ Options -> Headers -- ^ Custom headers to send -> ClientApp a -- ^ Client application -> IO a runClientWith host port path opts customHeaders app = do -- Create and connect socket let hints = S.defaultHints {S.addrFamily = S.AF_INET, S.addrSocketType = S.Stream} sock <- S.socket S.AF_INET S.Stream S.defaultProtocol addrInfos <- S.getAddrInfo (Just hints) (Just host) (Just $ show port) S.connect sock (S.addrAddress $ head addrInfos) -- Connect WebSocket and run client res <- finally (runClientWithSocket sock host path opts customHeaders app) (S.sClose sock) -- Clean up return res -------------------------------------------------------------------------------- runClientWithStream :: (Streams.InputStream B.ByteString, Streams.OutputStream B.ByteString) -- ^ Stream -> String -- ^ Host -> String -- ^ Path -> ConnectionOptions -- ^ Connection options -> Headers -- ^ Custom headers to send -> ClientApp a -- ^ Client application -> IO a runClientWithStream (sIn, sOut) host path opts customHeaders app = do -- Create the request and send it request <- createRequest protocol bHost bPath False customHeaders bOut <- Streams.builderStream sOut Streams.write (Just $ encodeRequestHead request) bOut Streams.write (Just Builder.flush) bOut response <- Streams.parseFromStream decodeResponseHead sIn -- Note that we pattern match to evaluate the result here Response _ _ <- return $ finishResponse protocol request response mIn <- decodeMessages protocol sIn mOut <- encodeMessages protocol ClientConnection bOut app Connection { connectionOptions = opts , connectionType = ClientConnection , connectionProtocol = protocol , connectionIn = mIn , connectionOut = mOut } where protocol = defaultProtocol -- TODO bHost = T.encodeUtf8 $ T.pack host bPath = T.encodeUtf8 $ T.pack path -------------------------------------------------------------------------------- runClientWithSocket :: S.Socket -- ^ Socket -> String -- ^ Host -> String -- ^ Path -> ConnectionOptions -- ^ Options -> Headers -- ^ Custom headers to send -> ClientApp a -- ^ Client application -> IO a runClientWithSocket sock host path opts customHeaders app = do stream <- Streams.socketToStreams sock runClientWithStream stream host path opts customHeaders app websockets-0.8.1.1/src/Network/WebSockets/Connection.hs0000644000000000000000000001533212251561173021151 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Connection ( PendingConnection (..) , acceptRequest , rejectRequest , Connection (..) , ConnectionOptions (..) , defaultConnectionOptions , receive , receiveDataMessage , receiveData , send , sendDataMessage , sendTextData , sendBinaryData , sendClose , sendPing ) where -------------------------------------------------------------------------------- import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder as Builder import Control.Exception (throw) import qualified Data.ByteString as B import Data.List (find) import System.IO.Streams (InputStream, OutputStream) import qualified System.IO.Streams as Streams -------------------------------------------------------------------------------- import Network.WebSockets.Http import Network.WebSockets.Protocol import Network.WebSockets.Types -------------------------------------------------------------------------------- -- | A new client connected to the server. We haven't accepted the connection -- yet, though. data PendingConnection = PendingConnection { pendingOptions :: ConnectionOptions -- ^ Options, passed as-is to the 'Connection' , pendingRequest :: RequestHead -- ^ Useful for e.g. inspecting the request path. , pendingOnAccept :: Connection -> IO () -- ^ One-shot callback fired when a connection is accepted, i.e., *after* -- the accepting response is sent to the client. , pendingIn :: InputStream B.ByteString -- ^ Input stream , pendingOut :: OutputStream Builder -- ^ Output stream } -------------------------------------------------------------------------------- -- | Utility sendResponse :: PendingConnection -> Response -> IO () sendResponse pc rsp = do Streams.write (Just (encodeResponse rsp)) (pendingOut pc) Streams.write (Just Builder.flush) (pendingOut pc) -------------------------------------------------------------------------------- acceptRequest :: PendingConnection -> IO Connection acceptRequest pc = case find (flip compatible request) protocols of Nothing -> do sendResponse pc $ response400 versionHeader "" throw NotSupported Just protocol -> do let response = finishRequest protocol request sendResponse pc response msgIn <- decodeMessages protocol (pendingIn pc) msgOut <- encodeMessages protocol ServerConnection (pendingOut pc) let connection = Connection { connectionOptions = pendingOptions pc , connectionType = ServerConnection , connectionProtocol = protocol , connectionIn = msgIn , connectionOut = msgOut } pendingOnAccept pc connection return connection where request = pendingRequest pc versionHeader = [("Sec-WebSocket-Version", B.intercalate ", " $ concatMap headerVersions protocols)] -------------------------------------------------------------------------------- rejectRequest :: PendingConnection -> B.ByteString -> IO () rejectRequest pc message = sendResponse pc $ response400 [] message -------------------------------------------------------------------------------- data Connection = Connection { connectionOptions :: ConnectionOptions , connectionType :: ConnectionType , connectionProtocol :: Protocol , connectionIn :: InputStream Message , connectionOut :: OutputStream Message } -------------------------------------------------------------------------------- data ConnectionOptions = ConnectionOptions { connectionOnPong :: IO () } -------------------------------------------------------------------------------- defaultConnectionOptions :: ConnectionOptions defaultConnectionOptions = ConnectionOptions { connectionOnPong = return () } -------------------------------------------------------------------------------- receive :: Connection -> IO Message receive conn = do mmsg <- Streams.read (connectionIn conn) case mmsg of Nothing -> throw ConnectionClosed Just msg -> return msg -------------------------------------------------------------------------------- -- | Receive an application message. Automatically respond to control messages. receiveDataMessage :: Connection -> IO DataMessage receiveDataMessage conn = do msg <- receive conn case msg of DataMessage am -> return am ControlMessage cm -> case cm of Close _ -> throw ConnectionClosed Pong _ -> do connectionOnPong (connectionOptions conn) receiveDataMessage conn Ping pl -> do send conn (ControlMessage (Pong pl)) receiveDataMessage conn -------------------------------------------------------------------------------- -- | Receive a message, converting it to whatever format is needed. receiveData :: WebSocketsData a => Connection -> IO a receiveData conn = do dm <- receiveDataMessage conn case dm of Text x -> return (fromLazyByteString x) Binary x -> return (fromLazyByteString x) -------------------------------------------------------------------------------- send :: Connection -> Message -> IO () send conn msg = Streams.write (Just msg) (connectionOut conn) -------------------------------------------------------------------------------- -- | Send a 'DataMessage' sendDataMessage :: Connection -> DataMessage -> IO () sendDataMessage conn = send conn . DataMessage -------------------------------------------------------------------------------- -- | Send a message as text sendTextData :: WebSocketsData a => Connection -> a -> IO () sendTextData conn = sendDataMessage conn . Text . toLazyByteString -------------------------------------------------------------------------------- -- | Send a message as binary data sendBinaryData :: WebSocketsData a => Connection -> a -> IO () sendBinaryData conn = sendDataMessage conn . Binary . toLazyByteString -------------------------------------------------------------------------------- -- | Send a friendly close message sendClose :: WebSocketsData a => Connection -> a -> IO () sendClose conn = send conn . ControlMessage . Close . toLazyByteString -------------------------------------------------------------------------------- -- | Send a ping sendPing :: WebSocketsData a => Connection -> a -> IO () sendPing conn = send conn . ControlMessage . Ping . toLazyByteString websockets-0.8.1.1/src/Network/WebSockets/Http.hs0000644000000000000000000002124712251561173017773 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Module dealing with HTTP: request data types, encoding and decoding... {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Http ( Headers , RequestHead (..) , Request (..) , ResponseHead (..) , Response (..) , HandshakeException (..) , encodeRequestHead , encodeRequest , decodeRequestHead , encodeResponseHead , encodeResponse , decodeResponseHead , decodeResponse , response101 , response400 , getRequestHeader , getResponseHeader , getRequestSecWebSocketVersion ) where -------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as Builder import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder import Control.Applicative (pure, (*>), (<$>), (<*), (<*>)) import Control.Exception (Exception, throw) import Control.Monad.Error (Error (..)) import qualified Data.Attoparsec as A import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.ByteString.Char8 () import qualified Data.ByteString.Char8 as BC import Data.ByteString.Internal (c2w) import qualified Data.CaseInsensitive as CI import Data.Dynamic (Typeable) import Data.Monoid (mappend, mconcat) -------------------------------------------------------------------------------- -- | Request headers type Headers = [(CI.CI ByteString, ByteString)] -------------------------------------------------------------------------------- -- | An HTTP request. The request body is not yet read. data RequestHead = RequestHead { requestPath :: !B.ByteString , requestHeaders :: Headers , requestSecure :: Bool } deriving (Show) -------------------------------------------------------------------------------- -- | A request with a body data Request = Request RequestHead B.ByteString deriving (Show) -------------------------------------------------------------------------------- -- | HTTP response, without body. data ResponseHead = ResponseHead { responseCode :: !Int , responseMessage :: !B.ByteString , responseHeaders :: Headers } deriving (Show) -------------------------------------------------------------------------------- -- | A response including a body data Response = Response ResponseHead B.ByteString deriving (Show) -------------------------------------------------------------------------------- -- | Error in case of failed handshake. Will be thrown as an 'Exception'. -- -- TODO: This should probably be in the Handshake module, and is solely here to -- prevent a cyclic dependency. data HandshakeException -- | We don't have a match for the protocol requested by the client. -- todo: version parameter = NotSupported -- | The request was somehow invalid (missing headers or wrong security -- token) | MalformedRequest RequestHead String -- | The servers response was somehow invalid (missing headers or wrong -- security token) | MalformedResponse ResponseHead String -- | The request was well-formed, but the library user rejected it. -- (e.g. "unknown path") | RequestRejected Request String -- | for example "EOF came too early" (which is actually a parse error) -- or for your own errors. (like "unknown path"?) | OtherHandshakeException String deriving (Show, Typeable) -------------------------------------------------------------------------------- instance Error HandshakeException where strMsg = OtherHandshakeException -------------------------------------------------------------------------------- instance Exception HandshakeException -------------------------------------------------------------------------------- encodeRequestHead :: RequestHead -> Builder.Builder encodeRequestHead (RequestHead path headers _) = Builder.copyByteString "GET " `mappend` Builder.copyByteString path `mappend` Builder.copyByteString " HTTP/1.1" `mappend` Builder.fromByteString "\r\n" `mappend` mconcat (map header headers) `mappend` Builder.copyByteString "\r\n" where header (k, v) = mconcat $ map Builder.copyByteString [CI.original k, ": ", v, "\r\n"] -------------------------------------------------------------------------------- encodeRequest :: Request -> Builder.Builder encodeRequest (Request head' body) = encodeRequestHead head' `mappend` Builder.copyByteString body -------------------------------------------------------------------------------- -- | Parse an initial request decodeRequestHead :: Bool -> A.Parser RequestHead decodeRequestHead isSecure = RequestHead <$> requestLine <*> A.manyTill decodeHeaderLine newline <*> pure isSecure where space = A.word8 (c2w ' ') newline = A.string "\r\n" requestLine = A.string "GET" *> space *> A.takeWhile1 (/= c2w ' ') <* space <* A.string "HTTP/1.1" <* newline -------------------------------------------------------------------------------- -- | Encode an HTTP upgrade response encodeResponseHead :: ResponseHead -> Builder.Builder encodeResponseHead (ResponseHead code msg headers) = Builder.copyByteString "HTTP/1.1 " `mappend` Builder.fromString (show code) `mappend` Builder.fromChar ' ' `mappend` Builder.fromByteString msg `mappend` Builder.fromByteString "\r\n" `mappend` mconcat (map header headers) `mappend` Builder.copyByteString "\r\n" where header (k, v) = mconcat $ map Builder.copyByteString [CI.original k, ": ", v, "\r\n"] -------------------------------------------------------------------------------- encodeResponse :: Response -> Builder.Builder encodeResponse (Response head' body) = encodeResponseHead head' `mappend` Builder.copyByteString body -------------------------------------------------------------------------------- -- | An upgrade response response101 :: Headers -> B.ByteString -> Response response101 headers = Response (ResponseHead 101 "WebSocket Protocol Handshake" (("Upgrade", "websocket") : ("Connection", "Upgrade") : headers)) -------------------------------------------------------------------------------- -- | Bad request response400 :: Headers -> B.ByteString -> Response response400 headers = Response (ResponseHead 400 "Bad Request" headers) -------------------------------------------------------------------------------- -- | HTTP response parser decodeResponseHead :: A.Parser ResponseHead decodeResponseHead = ResponseHead <$> fmap (read . BC.unpack) code <*> message <*> A.manyTill decodeHeaderLine newline where space = A.word8 (c2w ' ') newline = A.string "\r\n" code = A.string "HTTP/1.1" *> space *> A.takeWhile1 (/= c2w ' ') <* space message = A.takeWhile1 (/= c2w '\r') <* newline -------------------------------------------------------------------------------- decodeResponse :: A.Parser Response decodeResponse = Response <$> decodeResponseHead <*> A.takeByteString -------------------------------------------------------------------------------- getRequestHeader :: RequestHead -> CI.CI ByteString -> ByteString getRequestHeader rq key = case lookup key (requestHeaders rq) of Just t -> t Nothing -> throw $ MalformedRequest rq $ "Header missing: " ++ BC.unpack (CI.original key) -------------------------------------------------------------------------------- getResponseHeader :: ResponseHead -> CI.CI ByteString -> ByteString getResponseHeader rsp key = case lookup key (responseHeaders rsp) of Just t -> t Nothing -> throw $ MalformedResponse rsp $ "Header missing: " ++ BC.unpack (CI.original key) -------------------------------------------------------------------------------- -- | Get the @Sec-WebSocket-Version@ header getRequestSecWebSocketVersion :: RequestHead -> Maybe B.ByteString getRequestSecWebSocketVersion p = lookup "Sec-WebSocket-Version" (requestHeaders p) -------------------------------------------------------------------------------- decodeHeaderLine :: A.Parser (CI.CI ByteString, ByteString) decodeHeaderLine = (,) <$> (CI.mk <$> A.takeWhile1 (/= c2w ':')) <* A.word8 (c2w ':') <* A.option (c2w ' ') (A.word8 (c2w ' ')) <*> A.takeWhile (/= c2w '\r') <* A.string "\r\n" websockets-0.8.1.1/src/Network/WebSockets/Hybi13.hs0000644000000000000000000002174712251561173020120 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Hybi13 ( headerVersions , finishRequest , finishResponse , encodeMessages , decodeMessages , createRequest -- Internal (used for testing) , encodeFrame ) where -------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as B import Control.Applicative (pure, (<$>)) import Control.Exception (throw) import Control.Monad (liftM) import Data.Attoparsec (anyWord8) import qualified Data.Attoparsec as A import Data.Binary.Get (getWord16be, getWord64be, runGet) import Data.Bits ((.&.), (.|.)) import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 () import qualified Data.ByteString.Lazy as BL import Data.Digest.Pure.SHA (bytestringDigest, sha1) import Data.Int (Int64) import Data.IORef import Data.Monoid (mappend, mconcat, mempty) import Data.Tuple (swap) import System.Entropy as R import qualified System.IO.Streams as Streams import qualified System.IO.Streams.Attoparsec as Streams import System.Random (RandomGen, newStdGen) -------------------------------------------------------------------------------- import Network.WebSockets.Http import Network.WebSockets.Hybi13.Demultiplex import Network.WebSockets.Hybi13.Mask import Network.WebSockets.Types -------------------------------------------------------------------------------- headerVersions :: [ByteString] headerVersions = ["13"] -------------------------------------------------------------------------------- finishRequest :: RequestHead -> Response finishRequest reqHttp = let !key = getRequestHeader reqHttp "Sec-WebSocket-Key" !hash = hashKey key !encoded = B64.encode hash in response101 [("Sec-WebSocket-Accept", encoded)] "" -------------------------------------------------------------------------------- finishResponse :: RequestHead -> ResponseHead -> Response finishResponse request response -- Response message should be one of -- -- - WebSocket Protocol Handshake -- - Switching Protocols -- -- But we don't check it for now | responseCode response /= 101 = throw $ MalformedResponse response "Wrong response status or message." | responseHash /= challengeHash = throw $ MalformedResponse response "Challenge and response hashes do not match." | otherwise = Response response "" where key = getRequestHeader request "Sec-WebSocket-Key" responseHash = getResponseHeader response "Sec-WebSocket-Accept" challengeHash = B64.encode $ hashKey key -------------------------------------------------------------------------------- encodeMessage :: RandomGen g => ConnectionType -> g -> Message -> (g, B.Builder) encodeMessage conType gen msg = (gen', builder `mappend` B.flush) where mkFrame = Frame True False False False (mask, gen') = case conType of ServerConnection -> (Nothing, gen) ClientConnection -> randomMask gen builder = encodeFrame mask $ case msg of (ControlMessage (Close pl)) -> mkFrame CloseFrame pl (ControlMessage (Ping pl)) -> mkFrame PingFrame pl (ControlMessage (Pong pl)) -> mkFrame PongFrame pl (DataMessage (Text pl)) -> mkFrame TextFrame pl (DataMessage (Binary pl)) -> mkFrame BinaryFrame pl -------------------------------------------------------------------------------- encodeMessages :: ConnectionType -> Streams.OutputStream B.Builder -> IO (Streams.OutputStream Message) encodeMessages conType bStream = do genRef <- newIORef =<< newStdGen Streams.lockingOutputStream =<< Streams.makeOutputStream (next genRef) where next :: RandomGen g => IORef g -> Maybe Message -> IO () next _ Nothing = return () next genRef (Just msg) = do build <- atomicModifyIORef genRef $ \s -> encodeMessage conType s msg Streams.write (Just build) bStream -------------------------------------------------------------------------------- encodeFrame :: Mask -> Frame -> B.Builder encodeFrame mask f = B.fromWord8 byte0 `mappend` B.fromWord8 byte1 `mappend` len `mappend` maskbytes `mappend` B.fromLazyByteString (maskPayload mask (framePayload f)) where byte0 = fin .|. rsv1 .|. rsv2 .|. rsv3 .|. opcode fin = if frameFin f then 0x80 else 0x00 rsv1 = if frameRsv1 f then 0x40 else 0x00 rsv2 = if frameRsv2 f then 0x20 else 0x00 rsv3 = if frameRsv3 f then 0x10 else 0x00 opcode = case frameType f of ContinuationFrame -> 0x00 TextFrame -> 0x01 BinaryFrame -> 0x02 CloseFrame -> 0x08 PingFrame -> 0x09 PongFrame -> 0x0a (maskflag, maskbytes) = case mask of Nothing -> (0x00, mempty) Just m -> (0x80, B.fromByteString m) byte1 = maskflag .|. lenflag len' = BL.length (framePayload f) (lenflag, len) | len' < 126 = (fromIntegral len', mempty) | len' < 0x10000 = (126, B.fromWord16be (fromIntegral len')) | otherwise = (127, B.fromWord64be (fromIntegral len')) -------------------------------------------------------------------------------- decodeMessages :: Streams.InputStream ByteString -> IO (Streams.InputStream Message) decodeMessages bsStream = do dmRef <- newIORef emptyDemultiplexState Streams.makeInputStream $ next dmRef where next dmRef = do frame <- Streams.parseFromStream parseFrame bsStream m <- atomicModifyIORef dmRef $ \s -> swap $ demultiplex s frame maybe (next dmRef) (return . Just) m -------------------------------------------------------------------------------- -- | Parse a frame parseFrame :: A.Parser Frame parseFrame = do byte0 <- anyWord8 let fin = byte0 .&. 0x80 == 0x80 rsv1 = byte0 .&. 0x40 == 0x40 rsv2 = byte0 .&. 0x20 == 0x20 rsv3 = byte0 .&. 0x10 == 0x10 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 rsv1 rsv2 rsv3 ft (masker $ BL.fromChunks chunks) where runGet' g = runGet g . BL.fromChunks . return take64 :: Int64 -> A.Parser [ByteString] take64 n | n <= 0 = return [] | otherwise = do let n' = min intMax n chunk <- A.take (fromIntegral n') (chunk :) <$> take64 (n - n') where intMax :: Int64 intMax = fromIntegral (maxBound :: Int) -------------------------------------------------------------------------------- hashKey :: ByteString -> ByteString hashKey key = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid where guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" lazy = BL.fromChunks . return unlazy = mconcat . BL.toChunks -------------------------------------------------------------------------------- createRequest :: ByteString -> ByteString -> Bool -> Headers -> IO RequestHead createRequest hostname path secure customHeaders = do key <- B64.encode `liftM` getEntropy 16 return $ RequestHead path (headers key ++ customHeaders) secure where headers key = [ ("Host" , hostname ) , ("Connection" , "Upgrade" ) , ("Upgrade" , "websocket" ) , ("Sec-WebSocket-Key" , key ) , ("Sec-WebSocket-Version" , versionNumber) ] versionNumber = head headerVersions websockets-0.8.1.1/src/Network/WebSockets/Protocol.hs0000644000000000000000000000554012251561173020653 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Wrapper for supporting multiple protocol versions {-# LANGUAGE ExistentialQuantification #-} module Network.WebSockets.Protocol ( Protocol (..) , defaultProtocol , protocols , compatible , headerVersions , finishRequest , finishResponse , encodeMessages , decodeMessages , createRequest ) where -------------------------------------------------------------------------------- import Blaze.ByteString.Builder (Builder) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified System.IO.Streams as Streams -------------------------------------------------------------------------------- import Network.WebSockets.Http import qualified Network.WebSockets.Hybi13 as Hybi13 import Network.WebSockets.Types -------------------------------------------------------------------------------- data Protocol = Hybi13 deriving (Show) -------------------------------------------------------------------------------- defaultProtocol :: Protocol defaultProtocol = Hybi13 -------------------------------------------------------------------------------- protocols :: [Protocol] protocols = [Hybi13] -------------------------------------------------------------------------------- headerVersions :: Protocol -> [ByteString] headerVersions Hybi13 = Hybi13.headerVersions -------------------------------------------------------------------------------- compatible :: Protocol -> RequestHead -> Bool compatible protocol req = case getRequestSecWebSocketVersion req of Just v -> v `elem` headerVersions protocol _ -> True -- Whatever? -------------------------------------------------------------------------------- finishRequest :: Protocol -> RequestHead -> Response finishRequest Hybi13 = Hybi13.finishRequest -------------------------------------------------------------------------------- finishResponse :: Protocol -> RequestHead -> ResponseHead -> Response finishResponse Hybi13 = Hybi13.finishResponse -------------------------------------------------------------------------------- encodeMessages :: Protocol -> ConnectionType -> Streams.OutputStream Builder -> IO (Streams.OutputStream Message) encodeMessages Hybi13 = Hybi13.encodeMessages -------------------------------------------------------------------------------- decodeMessages :: Protocol -> Streams.InputStream B.ByteString -> IO (Streams.InputStream Message) decodeMessages Hybi13 = Hybi13.decodeMessages -------------------------------------------------------------------------------- createRequest :: Protocol -> B.ByteString -> B.ByteString -> Bool -> Headers -> IO RequestHead createRequest Hybi13 = Hybi13.createRequest websockets-0.8.1.1/src/Network/WebSockets/Server.hs0000644000000000000000000000635312251561173020323 0ustar0000000000000000-------------------------------------------------------------------------------- -- | This provides a simple stand-alone server for 'WebSockets' applications. -- Note that in production you want to use a real webserver such as snap or -- warp. {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Server ( ServerApp , runServer , runServerWith ) where -------------------------------------------------------------------------------- import Control.Concurrent (forkIO) import Control.Exception (finally) import Control.Monad (forever) import Network.Socket (Socket) import qualified Network.Socket as S import qualified System.IO.Streams.Attoparsec as Streams import qualified System.IO.Streams.Builder as Streams import qualified System.IO.Streams.Network as Streams -------------------------------------------------------------------------------- import Network.WebSockets.Connection import Network.WebSockets.Http -------------------------------------------------------------------------------- -- | WebSockets application that can be ran by a server. Once this 'IO' action -- finishes, the underlying socket is closed automatically. type ServerApp = PendingConnection -> IO () -------------------------------------------------------------------------------- -- | Provides a simple server. This function blocks forever. Note that this -- is merely provided for quick-and-dirty standalone applications, for real -- applications, you should use a real server. runServer :: String -- ^ Address to bind -> Int -- ^ Port to listen on -> ServerApp -- ^ Application -> IO () -- ^ Never returns runServer host port app = runServerWith host port defaultConnectionOptions app -------------------------------------------------------------------------------- -- | A version of 'runServer' which allows you to customize some options. runServerWith :: String -> Int -> ConnectionOptions -> ServerApp -> IO () runServerWith host port opts app = S.withSocketsDo $ do sock <- S.socket S.AF_INET S.Stream S.defaultProtocol _ <- S.setSocketOption sock S.ReuseAddr 1 host' <- S.inet_addr host S.bindSocket sock (S.SockAddrInet (fromIntegral port) host') S.listen sock 5 _ <- forever $ do -- TODO: top level handle (conn, _) <- S.accept sock _ <- forkIO $ finally (runApp conn opts app) (S.sClose conn) return () S.sClose sock -------------------------------------------------------------------------------- runApp :: Socket -> ConnectionOptions -> ServerApp -> IO () runApp socket opts app = do (sIn, sOut) <- Streams.socketToStreams socket bOut <- Streams.builderStream sOut -- TODO: we probably want to send a 40x if the request is bad? request <- Streams.parseFromStream (decodeRequestHead False) sIn let pc = PendingConnection { pendingOptions = opts , pendingRequest = request , pendingOnAccept = \_ -> return () , pendingIn = sIn , pendingOut = bOut } app pc websockets-0.8.1.1/src/Network/WebSockets/Types.hs0000644000000000000000000001002312251561173020146 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Primary types {-# LANGUAGE DeriveDataTypeable #-} module Network.WebSockets.Types ( Message (..) , ControlMessage (..) , DataMessage (..) , WebSocketsData (..) , HandshakeException (..) , ConnectionException (..) , ConnectionType (..) ) where -------------------------------------------------------------------------------- import Control.Exception (Exception (..)) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Data.Typeable (Typeable) -------------------------------------------------------------------------------- import Network.WebSockets.Http -------------------------------------------------------------------------------- -- | The kind of message a server application typically deals with data Message = ControlMessage ControlMessage | DataMessage DataMessage deriving (Eq, Show) -------------------------------------------------------------------------------- -- | Different control messages data ControlMessage = Close BL.ByteString | Ping BL.ByteString | Pong BL.ByteString deriving (Eq, Show) -------------------------------------------------------------------------------- -- | For an end-user of this library, dealing with 'Frame's would be a bit -- low-level. This is why define another type on top of it, which represents -- data for the application layer. data DataMessage = Text BL.ByteString | Binary BL.ByteString deriving (Eq, Show) -------------------------------------------------------------------------------- -- | In order to have an even more high-level API, we define a typeclass for -- values the user can receive from and send to the socket. A few warnings -- apply: -- -- * Natively, everything is represented as a 'BL.ByteString', so this is the -- fastest instance -- -- * You should only use the 'TL.Text' or the 'T.Text' instance when you are -- sure that the data is UTF-8 encoded (which is the case for 'Text' -- messages). -- -- * Messages can be very large. If this is the case, it might be inefficient to -- use the strict 'B.ByteString' and 'T.Text' instances. class WebSocketsData a where fromLazyByteString :: BL.ByteString -> a toLazyByteString :: a -> BL.ByteString -------------------------------------------------------------------------------- instance WebSocketsData BL.ByteString where fromLazyByteString = id toLazyByteString = id -------------------------------------------------------------------------------- instance WebSocketsData B.ByteString where fromLazyByteString = B.concat . BL.toChunks toLazyByteString = BL.fromChunks . return -------------------------------------------------------------------------------- instance WebSocketsData TL.Text where fromLazyByteString = TL.decodeUtf8 toLazyByteString = TL.encodeUtf8 -------------------------------------------------------------------------------- instance WebSocketsData T.Text where fromLazyByteString = T.concat . TL.toChunks . fromLazyByteString toLazyByteString = toLazyByteString . TL.fromChunks . return -------------------------------------------------------------------------------- -- | The connection couldn't be established or broke down unexpectedly. thrown -- as an iteratee exception. data ConnectionException -- | the client unexpectedly closed the connection while we were trying to -- receive some data. -- -- todo: Also want this for sending. = ConnectionClosed deriving (Show, Typeable) -------------------------------------------------------------------------------- instance Exception ConnectionException -------------------------------------------------------------------------------- data ConnectionType = ServerConnection | ClientConnection deriving (Eq, Ord, Show) websockets-0.8.1.1/src/Network/WebSockets/Hybi13/0000755000000000000000000000000012251561173017551 5ustar0000000000000000websockets-0.8.1.1/src/Network/WebSockets/Hybi13/Demultiplex.hs0000644000000000000000000000746512251561173022415 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Demultiplexing of frames into messages {-# LANGUAGE DeriveDataTypeable #-} module Network.WebSockets.Hybi13.Demultiplex ( FrameType (..) , Frame (..) , DemultiplexState , emptyDemultiplexState , demultiplex ) where -------------------------------------------------------------------------------- import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder as B import Control.Exception (Exception, throw) import qualified Data.ByteString.Lazy as BL import Data.Monoid (mappend) import Data.Typeable (Typeable) -------------------------------------------------------------------------------- import Network.WebSockets.Types -------------------------------------------------------------------------------- -- | A low-level representation of a WebSocket packet data Frame = Frame { frameFin :: !Bool , frameRsv1 :: !Bool , frameRsv2 :: !Bool , frameRsv3 :: !Bool , frameType :: !FrameType , framePayload :: !BL.ByteString } deriving (Eq, Show) -------------------------------------------------------------------------------- -- | The type of a frame. Not all types are allowed for all protocols. data FrameType = ContinuationFrame | TextFrame | BinaryFrame | CloseFrame | PingFrame | PongFrame deriving (Eq, Show) -------------------------------------------------------------------------------- -- | Thrown if the client sends invalid multiplexed data data DemultiplexException = DemultiplexException deriving (Show, Typeable) -------------------------------------------------------------------------------- instance Exception DemultiplexException -------------------------------------------------------------------------------- -- | Internal state used by the demultiplexer newtype DemultiplexState = DemultiplexState { unDemultiplexState :: Maybe (FrameType, Builder) } -------------------------------------------------------------------------------- emptyDemultiplexState :: DemultiplexState emptyDemultiplexState = DemultiplexState Nothing -------------------------------------------------------------------------------- demultiplex :: DemultiplexState -> Frame -> (Maybe Message, DemultiplexState) demultiplex state (Frame fin _ _ _ tp pl) = case tp of -- Return control messages immediately, they have no influence on the state CloseFrame -> (Just (ControlMessage (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) _ -> throw DemultiplexException where b' = b `mappend` plb m = B.toLazyByteString b' TextFrame | fin -> (Just (DataMessage (Text pl)), e) | otherwise -> (Nothing, DemultiplexState (Just (TextFrame, plb))) BinaryFrame | fin -> (Just (DataMessage (Binary pl)), e) | otherwise -> (Nothing, DemultiplexState (Just (BinaryFrame, plb))) where e = emptyDemultiplexState plb = B.fromLazyByteString pl websockets-0.8.1.1/src/Network/WebSockets/Hybi13/Mask.hs0000644000000000000000000000314012251561173020776 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Masking of fragmes using a simple XOR algorithm {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.WebSockets.Hybi13.Mask ( Mask , maskPayload , randomMask ) where -------------------------------------------------------------------------------- import Data.Bits (shiftR, xor) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import System.Random (RandomGen, random) -------------------------------------------------------------------------------- -- | ByteString should be exactly 4 bytes long type Mask = Maybe B.ByteString -------------------------------------------------------------------------------- -- | Apply mask maskPayload :: Mask -> BL.ByteString -> BL.ByteString maskPayload Nothing = id maskPayload (Just mask) = snd . BL.mapAccumL f 0 where len = B.length mask f !i !c = let i' = (i + 1) `mod` len m = mask `B.index` i in (i', m `xor` c) -------------------------------------------------------------------------------- -- | Create a random mask randomMask :: forall g. RandomGen g => g -> (Mask, g) randomMask gen = (Just (B.pack [b1, b2, b3, b4]), gen') where (!int, !gen') = random gen :: (Int, g) !b1 = fromIntegral $ int `mod` 0x100 !b2 = fromIntegral $ int `shiftR` 8 `mod` 0x100 !b3 = fromIntegral $ int `shiftR` 16 `mod` 0x100 !b4 = fromIntegral $ int `shiftR` 24 `mod` 0x100 websockets-0.8.1.1/tests/0000755000000000000000000000000012251561173013363 5ustar0000000000000000websockets-0.8.1.1/tests/haskell/0000755000000000000000000000000012251561173015006 5ustar0000000000000000websockets-0.8.1.1/tests/haskell/TestSuite.hs0000644000000000000000000000131012251561173017266 0ustar0000000000000000-------------------------------------------------------------------------------- import Test.Framework (defaultMain) -------------------------------------------------------------------------------- import qualified Network.WebSockets.Handshake.Tests import qualified Network.WebSockets.Http.Tests import qualified Network.WebSockets.Server.Tests import qualified Network.WebSockets.Tests -------------------------------------------------------------------------------- main :: IO () main = defaultMain [ Network.WebSockets.Handshake.Tests.tests , Network.WebSockets.Http.Tests.tests , Network.WebSockets.Server.Tests.tests , Network.WebSockets.Tests.tests ] websockets-0.8.1.1/tests/haskell/Network/0000755000000000000000000000000012251561173016437 5ustar0000000000000000websockets-0.8.1.1/tests/haskell/Network/WebSockets/0000755000000000000000000000000012251561173020510 5ustar0000000000000000websockets-0.8.1.1/tests/haskell/Network/WebSockets/Tests.hs0000644000000000000000000001547312251561173022160 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.WebSockets.Tests ( tests ) where -------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as Builder import Control.Applicative ((<$>)) import Control.Monad (replicateM) import qualified Data.ByteString.Lazy as BL import Data.List (intersperse) import Data.Maybe (catMaybes) import qualified System.IO.Streams as Streams import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit ((@=?)) import Test.QuickCheck (Arbitrary (..), Gen, Property) import qualified Test.QuickCheck as QC import qualified Test.QuickCheck.Monadic as QC -------------------------------------------------------------------------------- import Network.WebSockets import qualified Network.WebSockets.Hybi13 as Hybi13 import Network.WebSockets.Hybi13.Demultiplex import Network.WebSockets.Protocol import Network.WebSockets.Tests.Util import Network.WebSockets.Types -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Network.WebSockets.Test" [ testProperty "simple encode/decode Hybi13" (testSimpleEncodeDecode Hybi13) , testProperty "framgmented Hybi13" testFragmentedHybi13 ] -------------------------------------------------------------------------------- testSimpleEncodeDecode :: Protocol -> Property testSimpleEncodeDecode protocol = QC.monadicIO $ QC.forAllM QC.arbitrary $ \msgs -> QC.run $ do (is, os) <- makeChanPipe is' <- decodeMessages protocol is os' <- encodeMessages protocol ClientConnection =<< Streams.builderStream os Streams.writeList msgs os' msgs' <- catMaybes <$> replicateM (length msgs) (Streams.read is') msgs @=? msgs' -------------------------------------------------------------------------------- testFragmentedHybi13 :: Property testFragmentedHybi13 = QC.monadicIO $ QC.forAllM QC.arbitrary $ \fragmented -> QC.run $ do (is, os) <- makeChanPipe is' <- Streams.filter isDataMessage =<< Hybi13.decodeMessages is os' <- Streams.builderStream os -- Simple hacky encoding of all frames Streams.writeList [ Hybi13.encodeFrame Nothing f | FragmentedMessage _ frames <- fragmented , f <- frames ] os' Streams.write (Just Builder.flush) os' Streams.write Nothing os' -- Check if we got all data msgs <- catMaybes <$> replicateM (length fragmented) (Streams.read is') [msg | FragmentedMessage msg _ <- fragmented] @=? msgs where isDataMessage (ControlMessage _) = False isDataMessage (DataMessage _) = True -------------------------------------------------------------------------------- instance Arbitrary FrameType where arbitrary = QC.elements [ ContinuationFrame , TextFrame , BinaryFrame , CloseFrame , PingFrame , PongFrame ] -------------------------------------------------------------------------------- instance Arbitrary Frame where arbitrary = do fin <- arbitrary rsv1 <- arbitrary rsv2 <- arbitrary rsv3 <- arbitrary t <- arbitrary payload <- case t of TextFrame -> arbitraryUtf8 _ -> BL.pack <$> arbitrary return $ Frame fin rsv1 rsv2 rsv3 t payload -------------------------------------------------------------------------------- instance Arbitrary Message where arbitrary = do payload <- BL.pack <$> arbitrary QC.elements [ ControlMessage (Close payload) , ControlMessage (Ping payload) , ControlMessage (Pong payload) , DataMessage (Text payload) , DataMessage (Binary payload) ] -------------------------------------------------------------------------------- data FragmentedMessage = FragmentedMessage Message [Frame] deriving (Show) -------------------------------------------------------------------------------- instance Arbitrary FragmentedMessage where arbitrary = do -- Pick a frametype and a corresponding random payload ft <- QC.elements [TextFrame, BinaryFrame] payload <- case ft of TextFrame -> arbitraryUtf8 _ -> arbitraryByteString fragments <- arbitraryFragmentation payload let fs = makeFrames $ zip (ft : repeat ContinuationFrame) fragments msg = case ft of TextFrame -> DataMessage (Text payload) BinaryFrame -> DataMessage (Binary payload) _ -> error "Arbitrary FragmentedMessage crashed" interleaved <- arbitraryInterleave genControlFrame fs return $ FragmentedMessage msg interleaved -- return $ FragmentedMessage msg fs where makeFrames [] = [] makeFrames [(ft, pl)] = [Frame True False False False ft pl] makeFrames ((ft, pl) : fr) = Frame False False False False ft pl : makeFrames fr genControlFrame = QC.elements [ Frame True False False False PingFrame "Herp" , Frame True True True True PongFrame "Derp" ] -------------------------------------------------------------------------------- arbitraryFragmentation :: BL.ByteString -> Gen [BL.ByteString] arbitraryFragmentation bs = arbitraryFragmentation' bs where len :: Int len = fromIntegral $ BL.length bs arbitraryFragmentation' bs' = do -- TODO: we currently can't send packets of length 0. We should -- investigate why (regardless of the spec). n <- QC.choose (1, len - 1) let (l, r) = BL.splitAt (fromIntegral n) bs' case r of "" -> return [l] _ -> (l :) <$> arbitraryFragmentation' r -------------------------------------------------------------------------------- arbitraryInterleave :: Gen a -> [a] -> Gen [a] arbitraryInterleave sep xs = fmap concat $ sequence $ [sep'] ++ intersperse sep' [return [x] | x <- xs] ++ [sep'] where sep' = QC.sized $ \size -> do num <- QC.choose (1, size) replicateM num sep websockets-0.8.1.1/tests/haskell/Network/WebSockets/Handshake/0000755000000000000000000000000012251561173022376 5ustar0000000000000000websockets-0.8.1.1/tests/haskell/Network/WebSockets/Handshake/Tests.hs0000644000000000000000000001037412251561173024041 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Handshake.Tests ( tests ) where -------------------------------------------------------------------------------- import Control.Concurrent (forkIO) import Control.Exception (handle) import Data.ByteString.Char8 () import Data.IORef (newIORef, readIORef, writeIORef) import Data.Maybe (fromJust) import qualified System.IO.Streams.Attoparsec as Streams import qualified System.IO.Streams.Builder as Streams import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, (@?=), assert) -------------------------------------------------------------------------------- import Network.WebSockets import Network.WebSockets.Connection import Network.WebSockets.Http import Network.WebSockets.Tests.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Network.WebSockets.Handshake.Test" [ testCase "handshake Hybi13" testHandshakeHybi13 , testCase "handshake reject" testHandshakeReject , testCase "handshake Hybi9000" testHandshakeHybi9000 ] -------------------------------------------------------------------------------- testHandshake :: RequestHead -> (PendingConnection -> IO a) -> IO ResponseHead testHandshake rq app = do (is, os) <- makeChanPipe os' <- Streams.builderStream os _ <- forkIO $ do _ <- app (PendingConnection defaultConnectionOptions rq nullify is os') return () Streams.parseFromStream decodeResponseHead is where nullify _ = return () -------------------------------------------------------------------------------- (!) :: Eq a => [(a, b)] -> a -> b assoc ! key = fromJust (lookup key assoc) -------------------------------------------------------------------------------- rq13 :: RequestHead rq13 = RequestHead "/mychat" [ ("Host", "server.example.com") , ("Upgrade", "websocket") , ("Connection", "Upgrade") , ("Sec-WebSocket-Key", "x3JJHMbDL1EzLkh9GBhXDw==") , ("Sec-WebSocket-Protocol", "chat") , ("Sec-WebSocket-Version", "13") , ("Origin", "http://example.com") ] False -------------------------------------------------------------------------------- testHandshakeHybi13 :: Assertion testHandshakeHybi13 = do onAcceptFired <- newIORef False ResponseHead code message headers <- testHandshake rq13 $ \pc -> acceptRequest pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True} readIORef onAcceptFired >>= assert code @?= 101 message @?= "WebSocket Protocol Handshake" headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk=" headers ! "Connection" @?= "Upgrade" -------------------------------------------------------------------------------- testHandshakeReject :: Assertion testHandshakeReject = do ResponseHead code _ _ <- testHandshake rq13 $ \pc -> rejectRequest pc "YOU SHALL NOT PASS" code @?= 400 -------------------------------------------------------------------------------- -- I don't believe this one is supported yet rq9000 :: RequestHead rq9000 = RequestHead "/chat" [ ("Host", "server.example.com") , ("Upgrade", "websocket") , ("Connection", "Upgrade") , ("Sec-WebSocket-Key", "dGhlIHNhbXBsZSBub25jZQ==") , ("Sec-WebSocket-Origin", "http://example.com") , ("Sec-WebSocket-Protocol", "chat, superchat") , ("Sec-WebSocket-Version", "9000") ] False -------------------------------------------------------------------------------- testHandshakeHybi9000 :: Assertion testHandshakeHybi9000 = do ResponseHead code _ headers <- testHandshake rq9000 $ \pc -> flip handle (acceptRequest pc) $ \e -> case e of NotSupported -> return undefined _ -> error $ "Unexpected Exception: " ++ show e code @?= 400 headers ! "Sec-WebSocket-Version" @?= "13" websockets-0.8.1.1/tests/haskell/Network/WebSockets/Http/0000755000000000000000000000000012251561173021427 5ustar0000000000000000websockets-0.8.1.1/tests/haskell/Network/WebSockets/Http/Tests.hs0000644000000000000000000000421412251561173023066 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Http.Tests ( tests ) where -------------------------------------------------------------------------------- import qualified Data.Attoparsec as A import qualified Data.ByteString.Char8 as BC import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, assert) -------------------------------------------------------------------------------- import Network.WebSockets.Http -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Network.WebSockets.Http.Tests" [ testCase "jwebsockets response" jWebSocketsResponse , testCase "chromium response" chromiumResponse ] -------------------------------------------------------------------------------- -- | This is a specific response sent by jwebsockets which caused trouble jWebSocketsResponse :: Assertion jWebSocketsResponse = assert $ case A.parseOnly decodeResponseHead input of Left err -> error err Right _ -> True where input = BC.intercalate "\r\n" [ "HTTP/1.1 101 Switching Protocols" , "Upgrade: websocket" , "Connection: Upgrade" , "Sec-WebSocket-Accept: Ha0QR1T9CoYx/nqwHsVnW8KVTSo=" , "Sec-WebSocket-Origin: " , "Sec-WebSocket-Location: ws://127.0.0.1" , "Set-Cookie: JWSSESSIONID=2e0690e2e328f327056a5676b6a890e3; HttpOnly" , "" , "" ] -------------------------------------------------------------------------------- -- | This is a specific response sent by chromium which caused trouble chromiumResponse :: Assertion chromiumResponse = assert $ case A.parseOnly decodeResponseHead input of Left err -> error err Right _ -> True where input = BC.intercalate "\r\n" [ "HTTP/1.1 500 Internal Error" , "Content-Type:text/html" , "Content-Length:23" , "" , "No such target id: 20_1" ] websockets-0.8.1.1/tests/haskell/Network/WebSockets/Server/0000755000000000000000000000000012251561173021756 5ustar0000000000000000websockets-0.8.1.1/tests/haskell/Network/WebSockets/Server/Tests.hs0000644000000000000000000001046612251561173023423 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.WebSockets.Server.Tests ( tests ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Exception (SomeException, handle) import Control.Monad (forM_, forever, replicateM) import Data.IORef (newIORef, readIORef, writeIORef) -------------------------------------------------------------------------------- import qualified Data.ByteString.Lazy as BL import Data.Text (Text) import System.Random (newStdGen) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, assert, (@=?)) import Test.QuickCheck (Arbitrary, arbitrary) import Test.QuickCheck.Gen (Gen (..)) -------------------------------------------------------------------------------- import Network.WebSockets import Network.WebSockets.Tests.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Network.WebSockets.Server.Tests" [ testCase "simple server/client" testSimpleServerClient , testCase "onPong" testOnPong ] -------------------------------------------------------------------------------- testSimpleServerClient :: Assertion testSimpleServerClient = withEchoServer 42940 $ do texts <- map unArbitraryUtf8 <$> sample texts' <- retry $ runClient "127.0.0.1" 42940 "/chat" $ client texts texts @=? texts' where client :: [BL.ByteString] -> ClientApp [BL.ByteString] client texts conn = do forM_ texts (sendTextData conn) texts' <- replicateM (length texts) (receiveData conn) sendClose conn ("Bye" :: BL.ByteString) return texts' -------------------------------------------------------------------------------- testOnPong :: Assertion testOnPong = withEchoServer 42941 $ do gotPong <- newIORef False let opts = defaultConnectionOptions { connectionOnPong = writeIORef gotPong True } rcv <- runClientWith "127.0.0.1" 42941 "/" opts [] client assert rcv assert =<< readIORef gotPong where client :: ClientApp Bool client conn = do sendPing conn ("What's a fish without an eye?" :: Text) sendTextData conn ("A fsh!" :: Text) msg <- receiveData conn return $ "A fsh!" == (msg :: Text) -------------------------------------------------------------------------------- sample :: Arbitrary a => IO [a] sample = do gen <- newStdGen return $ (unGen arbitrary) gen 512 -------------------------------------------------------------------------------- waitSome :: IO () waitSome = threadDelay $ 200 * 1000 -------------------------------------------------------------------------------- -- HOLY SHIT WHAT SORT OF ATROCITY IS THIS?!?!?! -- -- The problem is that sometimes, the server hasn't been brought down yet -- before the next test, which will cause it not to be able to bind to the -- same port again. In this case, we just retry. -- -- The same is true for our client: possibly, the server is not up yet -- before we run the client. We also want to retry in that case. retry :: IO a -> IO a retry action = (\(_ :: SomeException) -> waitSome >> action) `handle` action -------------------------------------------------------------------------------- withEchoServer :: Int -> IO a -> IO a withEchoServer port action = do serverThread <- forkIO $ retry $ runServer "0.0.0.0" port server waitSome result <- action waitSome killThread serverThread return result where server :: ServerApp server pc = do conn <- acceptRequest pc forever $ do msg <- receiveDataMessage conn sendDataMessage conn msg websockets-0.8.1.1/tests/haskell/Network/WebSockets/Tests/0000755000000000000000000000000012251561173021612 5ustar0000000000000000websockets-0.8.1.1/tests/haskell/Network/WebSockets/Tests/Util.hs0000644000000000000000000000371112251561173023065 0ustar0000000000000000-------------------------------------------------------------------------------- module Network.WebSockets.Tests.Util ( ArbitraryUtf8 (..) , arbitraryUtf8 , arbitraryByteString , makeChanPipe ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>), (<*>)) import Control.Concurrent.Chan (newChan) import qualified Data.ByteString.Lazy as BL import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import System.IO.Streams (InputStream, OutputStream) import qualified System.IO.Streams.Concurrent as Streams import Test.QuickCheck (Arbitrary (..), Gen) -------------------------------------------------------------------------------- import Network.WebSockets.Types -------------------------------------------------------------------------------- newtype ArbitraryUtf8 = ArbitraryUtf8 {unArbitraryUtf8 :: BL.ByteString} deriving (Eq, Ord, Show) -------------------------------------------------------------------------------- instance Arbitrary ArbitraryUtf8 where arbitrary = ArbitraryUtf8 <$> arbitraryUtf8 -------------------------------------------------------------------------------- arbitraryUtf8 :: Gen BL.ByteString arbitraryUtf8 = toLazyByteString . TL.encodeUtf8 . TL.pack <$> arbitrary -------------------------------------------------------------------------------- arbitraryByteString :: Gen BL.ByteString arbitraryByteString = BL.pack <$> arbitrary -------------------------------------------------------------------------------- -- | TODO: I added this function to the io-streams library but it isn't released -- yet, at some point we should be able to remove it here. makeChanPipe :: IO (InputStream a, OutputStream a) makeChanPipe = do chan <- newChan (,) <$> Streams.chanToInput chan <*> Streams.chanToOutput chan