websockets-0.12.5.3/benchmarks/0000755000000000000000000000000013105562161014414 5ustar0000000000000000websockets-0.12.5.3/cbits/0000755000000000000000000000000013424550521013404 5ustar0000000000000000websockets-0.12.5.3/example/0000755000000000000000000000000013275255045013742 5ustar0000000000000000websockets-0.12.5.3/src/0000755000000000000000000000000012722550455013075 5ustar0000000000000000websockets-0.12.5.3/src/Network/0000755000000000000000000000000013304170003014506 5ustar0000000000000000websockets-0.12.5.3/src/Network/WebSockets/0000755000000000000000000000000013424550505016573 5ustar0000000000000000websockets-0.12.5.3/src/Network/WebSockets/Connection/0000755000000000000000000000000013424550505020672 5ustar0000000000000000websockets-0.12.5.3/src/Network/WebSockets/Extensions/0000755000000000000000000000000013251754463020741 5ustar0000000000000000websockets-0.12.5.3/src/Network/WebSockets/Hybi13/0000755000000000000000000000000013251754463017641 5ustar0000000000000000websockets-0.12.5.3/tests/0000755000000000000000000000000013317147262013447 5ustar0000000000000000websockets-0.12.5.3/tests/autobahn/0000755000000000000000000000000013223015276015243 5ustar0000000000000000websockets-0.12.5.3/tests/haskell/0000755000000000000000000000000013133677425015077 5ustar0000000000000000websockets-0.12.5.3/tests/haskell/Network/0000755000000000000000000000000012722550455016524 5ustar0000000000000000websockets-0.12.5.3/tests/haskell/Network/WebSockets/0000755000000000000000000000000013251754463020600 5ustar0000000000000000websockets-0.12.5.3/tests/haskell/Network/WebSockets/Extensions/0000755000000000000000000000000013133677425022740 5ustar0000000000000000websockets-0.12.5.3/tests/haskell/Network/WebSockets/Extensions/PermessageDeflate/0000755000000000000000000000000013133677425026320 5ustar0000000000000000websockets-0.12.5.3/tests/haskell/Network/WebSockets/Handshake/0000755000000000000000000000000013072462164022461 5ustar0000000000000000websockets-0.12.5.3/tests/haskell/Network/WebSockets/Http/0000755000000000000000000000000013111331443021477 5ustar0000000000000000websockets-0.12.5.3/tests/haskell/Network/WebSockets/Hybi13/0000755000000000000000000000000013133677425021640 5ustar0000000000000000websockets-0.12.5.3/tests/haskell/Network/WebSockets/Hybi13/Demultiplex/0000755000000000000000000000000013133677425024134 5ustar0000000000000000websockets-0.12.5.3/tests/haskell/Network/WebSockets/Mask/0000755000000000000000000000000013105561166021465 5ustar0000000000000000websockets-0.12.5.3/tests/haskell/Network/WebSockets/Server/0000755000000000000000000000000013317411473022040 5ustar0000000000000000websockets-0.12.5.3/tests/haskell/Network/WebSockets/Tests/0000755000000000000000000000000012722550455021677 5ustar0000000000000000websockets-0.12.5.3/src/Network/WebSockets.hs0000644000000000000000000000414313304170003017115 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE ScopedTypeVariables #-} module Network.WebSockets ( -- * Incoming connections and handshaking PendingConnection , pendingRequest , acceptRequest , AcceptRequest(..) , defaultAcceptRequest , acceptRequestWith , rejectRequest , RejectRequest(..) , defaultRejectRequest , rejectRequestWith -- * Main connection type , Connection -- * Options for connections , ConnectionOptions (..) , defaultConnectionOptions -- ** Compression options , CompressionOptions (..) , PermessageDeflate (..) , defaultPermessageDeflate -- ** Protection limits , SizeLimit (..) -- * Sending and receiving messages , receive , receiveDataMessage , receiveData , send , sendDataMessage , sendDataMessages , sendTextData , sendTextDatas , sendBinaryData , sendBinaryDatas , sendClose , sendCloseCode , sendPing -- * HTTP Types , Headers , Request (..) , RequestHead (..) , getRequestSubprotocols , Response (..) , ResponseHead (..) -- * WebSocket message types , Message (..) , ControlMessage (..) , DataMessage (..) , WebSocketsData (..) -- * Exceptions , HandshakeException (..) , ConnectionException (..) -- * Running a standalone server , ServerApp , runServer , runServerWith -- * Utilities for writing your own server , makeListenSocket , makePendingConnection , makePendingConnectionFromStream -- * Running a client , ClientApp , runClient , runClientWith , runClientWithSocket , runClientWithStream , newClientConnection -- * Utilities , forkPingThread ) where -------------------------------------------------------------------------------- import Network.WebSockets.Client import Network.WebSockets.Connection import Network.WebSockets.Http import Network.WebSockets.Server import Network.WebSockets.Types websockets-0.12.5.3/src/Network/WebSockets/Connection.hs0000644000000000000000000004163313251754463021244 0ustar0000000000000000-------------------------------------------------------------------------------- -- | This module exposes connection internals and should only be used if you -- really know what you are doing. {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Connection ( PendingConnection (..) , acceptRequest , AcceptRequest(..) , defaultAcceptRequest , acceptRequestWith , rejectRequest , RejectRequest(..) , defaultRejectRequest , rejectRequestWith , Connection (..) , ConnectionOptions (..) , defaultConnectionOptions , receive , receiveDataMessage , receiveData , send , sendDataMessage , sendDataMessages , sendTextData , sendTextDatas , sendBinaryData , sendBinaryDatas , sendClose , sendCloseCode , sendPing , forkPingThread , CompressionOptions (..) , PermessageDeflate (..) , defaultPermessageDeflate , SizeLimit (..) ) where -------------------------------------------------------------------------------- import qualified Data.ByteString.Builder as Builder import Control.Applicative ((<$>)) import Control.Concurrent (forkIO, threadDelay) import Control.Exception (AsyncException, fromException, handle, throwIO) import Control.Monad (foldM, unless, when) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.List (find) import Data.Maybe (catMaybes) import qualified Data.Text as T import Data.Word (Word16) import Prelude -------------------------------------------------------------------------------- import Network.WebSockets.Connection.Options import Network.WebSockets.Extensions as Extensions import Network.WebSockets.Extensions.PermessageDeflate import Network.WebSockets.Extensions.StrictUnicode import Network.WebSockets.Http import Network.WebSockets.Protocol import Network.WebSockets.Stream (Stream) import qualified Network.WebSockets.Stream as Stream 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. , pendingStream :: !Stream -- ^ Input/output stream } -------------------------------------------------------------------------------- -- | This datatype allows you to set options for 'acceptRequestWith'. It is -- strongly recommended to use 'defaultAcceptRequest' and then modify the -- various fields, that way new fields introduced in the library do not break -- your code. data AcceptRequest = AcceptRequest { acceptSubprotocol :: !(Maybe B.ByteString) -- ^ The subprotocol to speak with the client. If 'pendingSubprotcols' is -- non-empty, 'acceptSubprotocol' must be one of the subprotocols from the -- list. , acceptHeaders :: !Headers -- ^ Extra headers to send with the response. } -------------------------------------------------------------------------------- defaultAcceptRequest :: AcceptRequest defaultAcceptRequest = AcceptRequest Nothing [] -------------------------------------------------------------------------------- -- | Utility sendResponse :: PendingConnection -> Response -> IO () sendResponse pc rsp = Stream.write (pendingStream pc) (Builder.toLazyByteString (encodeResponse rsp)) -------------------------------------------------------------------------------- -- | Accept a pending connection, turning it into a 'Connection'. acceptRequest :: PendingConnection -> IO Connection acceptRequest pc = acceptRequestWith pc defaultAcceptRequest -------------------------------------------------------------------------------- -- | This function is like 'acceptRequest' but allows you to set custom options -- using the 'AcceptRequest' datatype. acceptRequestWith :: PendingConnection -> AcceptRequest -> IO Connection acceptRequestWith pc ar = case find (flip compatible request) protocols of Nothing -> do sendResponse pc $ response400 versionHeader "" throwIO NotSupported Just protocol -> do -- Get requested list of exceptions from client. rqExts <- either throwIO return $ getRequestSecWebSocketExtensions request -- Set up permessage-deflate extension if configured. pmdExt <- case connectionCompressionOptions (pendingOptions pc) of NoCompression -> return Nothing PermessageDeflateCompression pmd0 -> case negotiateDeflate (connectionMessageDataSizeLimit options) (Just pmd0) rqExts of Left err -> do rejectRequestWith pc defaultRejectRequest {rejectMessage = B8.pack err} throwIO NotSupported Right pmd1 -> return (Just pmd1) -- Set up strict utf8 extension if configured. let unicodeExt = if connectionStrictUnicode (pendingOptions pc) then Just strictUnicode else Nothing -- Final extension list. let exts = catMaybes [pmdExt, unicodeExt] let subproto = maybe [] (\p -> [("Sec-WebSocket-Protocol", p)]) $ acceptSubprotocol ar headers = subproto ++ acceptHeaders ar ++ concatMap extHeaders exts response = finishRequest protocol request headers either throwIO (sendResponse pc) response parseRaw <- decodeMessages protocol (connectionFramePayloadSizeLimit options) (connectionMessageDataSizeLimit options) (pendingStream pc) writeRaw <- encodeMessages protocol ServerConnection (pendingStream pc) write <- foldM (\x ext -> extWrite ext x) writeRaw exts parse <- foldM (\x ext -> extParse ext x) parseRaw exts sentRef <- newIORef False let connection = Connection { connectionOptions = options , connectionType = ServerConnection , connectionProtocol = protocol , connectionParse = parse , connectionWrite = write , connectionSentClose = sentRef } pendingOnAccept pc connection return connection where options = pendingOptions pc request = pendingRequest pc versionHeader = [("Sec-WebSocket-Version", B.intercalate ", " $ concatMap headerVersions protocols)] -------------------------------------------------------------------------------- -- | Parameters that allow you to tweak how a request is rejected. Please use -- 'defaultRejectRequest' and modify fields using record syntax so your code -- will not break when new fields are added. data RejectRequest = RejectRequest { -- | The status code, 400 by default. rejectCode :: !Int , -- | The message, "Bad Request" by default rejectMessage :: !B.ByteString , -- | Extra headers to be sent with the response. rejectHeaders :: Headers , -- | Reponse body of the rejection. rejectBody :: !B.ByteString } -------------------------------------------------------------------------------- defaultRejectRequest :: RejectRequest defaultRejectRequest = RejectRequest { rejectCode = 400 , rejectMessage = "Bad Request" , rejectHeaders = [] , rejectBody = "" } -------------------------------------------------------------------------------- rejectRequestWith :: PendingConnection -- ^ Connection to reject -> RejectRequest -- ^ Params on how to reject the request -> IO () rejectRequestWith pc reject = sendResponse pc $ Response ResponseHead { responseCode = rejectCode reject , responseMessage = rejectMessage reject , responseHeaders = rejectHeaders reject } (rejectBody reject) -------------------------------------------------------------------------------- rejectRequest :: PendingConnection -- ^ Connection to reject -> B.ByteString -- ^ Rejection response body -> IO () rejectRequest pc body = rejectRequestWith pc defaultRejectRequest {rejectBody = body} -------------------------------------------------------------------------------- data Connection = Connection { connectionOptions :: !ConnectionOptions , connectionType :: !ConnectionType , connectionProtocol :: !Protocol , connectionParse :: !(IO (Maybe Message)) , connectionWrite :: !([Message] -> IO ()) , connectionSentClose :: !(IORef Bool) -- ^ According to the RFC, both the client and the server MUST send -- a close control message to each other. Either party can initiate -- the first close message but then the other party must respond. Finally, -- the server is in charge of closing the TCP connection. This IORef tracks -- if we have sent a close message and are waiting for the peer to respond. } -------------------------------------------------------------------------------- receive :: Connection -> IO Message receive conn = do mbMsg <- connectionParse conn case mbMsg of Nothing -> throwIO ConnectionClosed Just msg -> return msg -------------------------------------------------------------------------------- -- | Receive an application message. Automatically respond to control messages. -- -- When the peer sends a close control message, an exception of type 'CloseRequest' -- is thrown. The peer can send a close control message either to initiate a -- close or in response to a close message we have sent to the peer. In either -- case the 'CloseRequest' exception will be thrown. The RFC specifies that -- the server is responsible for closing the TCP connection, which should happen -- after receiving the 'CloseRequest' exception from this function. -- -- This will throw 'ConnectionClosed' if the TCP connection dies unexpectedly. receiveDataMessage :: Connection -> IO DataMessage receiveDataMessage conn = do msg <- receive conn case msg of DataMessage _ _ _ am -> return am ControlMessage cm -> case cm of Close i closeMsg -> do hasSentClose <- readIORef $ connectionSentClose conn unless hasSentClose $ send conn msg throwIO $ CloseRequest i closeMsg 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 = fromDataMessage <$> receiveDataMessage conn -------------------------------------------------------------------------------- send :: Connection -> Message -> IO () send conn = sendAll conn . return -------------------------------------------------------------------------------- sendAll :: Connection -> [Message] -> IO () sendAll _ [] = return () sendAll conn msgs = do when (any isCloseMessage msgs) $ writeIORef (connectionSentClose conn) True connectionWrite conn msgs where isCloseMessage (ControlMessage (Close _ _)) = True isCloseMessage _ = False -------------------------------------------------------------------------------- -- | Send a 'DataMessage'. This allows you send both human-readable text and -- binary data. This is a slightly more low-level interface than 'sendTextData' -- or 'sendBinaryData'. sendDataMessage :: Connection -> DataMessage -> IO () sendDataMessage conn = sendDataMessages conn . return -------------------------------------------------------------------------------- -- | Send a collection of 'DataMessage's. This is more efficient than calling -- 'sendDataMessage' many times. sendDataMessages :: Connection -> [DataMessage] -> IO () sendDataMessages conn = sendAll conn . map (DataMessage False False False) -------------------------------------------------------------------------------- -- | Send a textual message. The message will be encoded as UTF-8. This should -- be the default choice for human-readable text-based protocols such as JSON. sendTextData :: WebSocketsData a => Connection -> a -> IO () sendTextData conn = sendTextDatas conn . return -------------------------------------------------------------------------------- -- | Send a number of textual messages. This is more efficient than calling -- 'sendTextData' many times. sendTextDatas :: WebSocketsData a => Connection -> [a] -> IO () sendTextDatas conn = sendDataMessages conn . map (\x -> Text (toLazyByteString x) Nothing) -------------------------------------------------------------------------------- -- | Send a binary message. This is useful for sending binary blobs, e.g. -- images, data encoded with MessagePack, images... sendBinaryData :: WebSocketsData a => Connection -> a -> IO () sendBinaryData conn = sendBinaryDatas conn . return -------------------------------------------------------------------------------- -- | Send a number of binary messages. This is more efficient than calling -- 'sendBinaryData' many times. sendBinaryDatas :: WebSocketsData a => Connection -> [a] -> IO () sendBinaryDatas conn = sendDataMessages conn . map (Binary . toLazyByteString) -------------------------------------------------------------------------------- -- | Send a friendly close message. Note that after sending this message, -- you should still continue calling 'receiveDataMessage' to process any -- in-flight messages. The peer will eventually respond with a close control -- message of its own which will cause 'receiveDataMessage' to throw the -- 'CloseRequest' exception. This exception is when you can finally consider -- the connection closed. sendClose :: WebSocketsData a => Connection -> a -> IO () sendClose conn = sendCloseCode conn 1000 -------------------------------------------------------------------------------- -- | Send a friendly close message and close code. Similar to 'sendClose', -- you should continue calling 'receiveDataMessage' until you receive a -- 'CloseRequest' exception. -- -- See for a list of close -- codes. sendCloseCode :: WebSocketsData a => Connection -> Word16 -> a -> IO () sendCloseCode conn code = send conn . ControlMessage . Close code . toLazyByteString -------------------------------------------------------------------------------- -- | Send a ping sendPing :: WebSocketsData a => Connection -> a -> IO () sendPing conn = send conn . ControlMessage . Ping . toLazyByteString -------------------------------------------------------------------------------- -- | Forks a ping thread, sending a ping message every @n@ seconds over the -- connection. The thread dies silently if the connection crashes or is closed. -- -- This is useful to keep idle connections open through proxies and whatnot. -- Many (but not all) proxies have a 60 second default timeout, so based on that -- sending a ping every 30 seconds is a good idea. forkPingThread :: Connection -> Int -> IO () forkPingThread conn n | n <= 0 = return () | otherwise = do _ <- forkIO (ignore `handle` go 1) return () where go :: Int -> IO () go i = do threadDelay (n * 1000 * 1000) sendPing conn (T.pack $ show i) go (i + 1) ignore e = case fromException e of Just async -> throwIO (async :: AsyncException) Nothing -> return () websockets-0.12.5.3/src/Network/WebSockets/Extensions.hs0000644000000000000000000000144113074734714021275 0ustar0000000000000000module Network.WebSockets.Extensions ( ExtensionDescription (..) , ExtensionDescriptions , parseExtensionDescriptions , NegotiateExtension , Extension (..) ) where import Network.WebSockets.Extensions.Description import Network.WebSockets.Http import Network.WebSockets.Types type NegotiateExtension = ExtensionDescriptions -> Either String Extension -- | An extension is currently allowed to set extra headers and transform the -- parse/write functions of 'Connection'. -- -- This type is very likely to change as other extensions are introduced. data Extension = Extension { extHeaders :: Headers , extParse :: IO (Maybe Message) -> IO (IO (Maybe Message)) , extWrite :: ([Message] -> IO ()) -> IO ([Message] -> IO ()) } websockets-0.12.5.3/src/Network/WebSockets/Stream.hs0000644000000000000000000001674313317411473020376 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Lightweight abstraction over an input/output stream. {-# LANGUAGE CPP #-} module Network.WebSockets.Stream ( Stream , makeStream , makeSocketStream , makeEchoStream , parse , parseBin , write , close ) where import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar, withMVar) import Control.Exception (onException, throwIO) import Control.Monad (forM_) import qualified Data.Attoparsec.ByteString as Atto import qualified Data.Binary.Get as BIN import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) import qualified Network.Socket as S import qualified Network.Socket.ByteString as SB (recv) #if !defined(mingw32_HOST_OS) import qualified Network.Socket.ByteString.Lazy as SBL (sendAll) #else import qualified Network.Socket.ByteString as SB (sendAll) #endif import Network.WebSockets.Types -------------------------------------------------------------------------------- -- | State of the stream data StreamState = Closed !B.ByteString -- Remainder | Open !B.ByteString -- Buffer -------------------------------------------------------------------------------- -- | Lightweight abstraction over an input/output stream. data Stream = Stream { streamIn :: IO (Maybe B.ByteString) , streamOut :: (Maybe BL.ByteString -> IO ()) , streamState :: !(IORef StreamState) } -------------------------------------------------------------------------------- -- | Create a stream from a "receive" and "send" action. The following -- properties apply: -- -- - Regardless of the provided "receive" and "send" functions, reading and -- writing from the stream will be thread-safe, i.e. this function will create -- a receive and write lock to be used internally. -- -- - Reading from or writing or to a closed 'Stream' will always throw an -- exception, even if the underlying "receive" and "send" functions do not -- (we do the bookkeeping). -- -- - Streams should always be closed. makeStream :: IO (Maybe B.ByteString) -- ^ Reading -> (Maybe BL.ByteString -> IO ()) -- ^ Writing -> IO Stream -- ^ Resulting stream makeStream receive send = do ref <- newIORef (Open B.empty) receiveLock <- newMVar () sendLock <- newMVar () return $ Stream (receive' ref receiveLock) (send' ref sendLock) ref where closeRef :: IORef StreamState -> IO () closeRef ref = atomicModifyIORef' ref $ \state -> case state of Open buf -> (Closed buf, ()) Closed buf -> (Closed buf, ()) -- Throw a 'ConnectionClosed' is the connection is not 'Open'. assertOpen :: IORef StreamState -> IO () assertOpen ref = do state <- readIORef ref case state of Closed _ -> throwIO ConnectionClosed Open _ -> return () receive' :: IORef StreamState -> MVar () -> IO (Maybe B.ByteString) receive' ref lock = withMVar lock $ \() -> do assertOpen ref mbBs <- onException receive (closeRef ref) case mbBs of Nothing -> closeRef ref >> return Nothing Just bs -> return (Just bs) send' :: IORef StreamState -> MVar () -> (Maybe BL.ByteString -> IO ()) send' ref lock mbBs = withMVar lock $ \() -> do case mbBs of Nothing -> closeRef ref Just _ -> assertOpen ref onException (send mbBs) (closeRef ref) -------------------------------------------------------------------------------- makeSocketStream :: S.Socket -> IO Stream makeSocketStream socket = makeStream receive send where receive = do bs <- SB.recv socket 8192 return $ if B.null bs then Nothing else Just bs send Nothing = return () send (Just bs) = do #if !defined(mingw32_HOST_OS) SBL.sendAll socket bs #else forM_ (BL.toChunks bs) (SB.sendAll socket) #endif -------------------------------------------------------------------------------- makeEchoStream :: IO Stream makeEchoStream = do mvar <- newEmptyMVar makeStream (takeMVar mvar) $ \mbBs -> case mbBs of Nothing -> putMVar mvar Nothing Just bs -> forM_ (BL.toChunks bs) $ \c -> putMVar mvar (Just c) -------------------------------------------------------------------------------- parseBin :: Stream -> BIN.Get a -> IO (Maybe a) parseBin stream parser = do state <- readIORef (streamState stream) case state of Closed remainder | B.null remainder -> return Nothing | otherwise -> go (BIN.runGetIncremental parser `BIN.pushChunk` remainder) True Open buffer | B.null buffer -> do mbBs <- streamIn stream case mbBs of Nothing -> do writeIORef (streamState stream) (Closed B.empty) return Nothing Just bs -> go (BIN.runGetIncremental parser `BIN.pushChunk` bs) False | otherwise -> go (BIN.runGetIncremental parser `BIN.pushChunk` buffer) False where -- Buffer is empty when entering this function. go (BIN.Done remainder _ x) closed = do writeIORef (streamState stream) $ if closed then Closed remainder else Open remainder return (Just x) go (BIN.Partial f) closed | closed = go (f Nothing) True | otherwise = do mbBs <- streamIn stream case mbBs of Nothing -> go (f Nothing) True Just bs -> go (f (Just bs)) False go (BIN.Fail _ _ err) _ = throwIO (ParseException err) parse :: Stream -> Atto.Parser a -> IO (Maybe a) parse stream parser = do state <- readIORef (streamState stream) case state of Closed remainder | B.null remainder -> return Nothing | otherwise -> go (Atto.parse parser remainder) True Open buffer | B.null buffer -> do mbBs <- streamIn stream case mbBs of Nothing -> do writeIORef (streamState stream) (Closed B.empty) return Nothing Just bs -> go (Atto.parse parser bs) False | otherwise -> go (Atto.parse parser buffer) False where -- Buffer is empty when entering this function. go (Atto.Done remainder x) closed = do writeIORef (streamState stream) $ if closed then Closed remainder else Open remainder return (Just x) go (Atto.Partial f) closed | closed = go (f B.empty) True | otherwise = do mbBs <- streamIn stream case mbBs of Nothing -> go (f B.empty) True Just bs -> go (f bs) False go (Atto.Fail _ _ err) _ = throwIO (ParseException err) -------------------------------------------------------------------------------- write :: Stream -> BL.ByteString -> IO () write stream = streamOut stream . Just -------------------------------------------------------------------------------- close :: Stream -> IO () close stream = streamOut stream Nothing websockets-0.12.5.3/src/Network/WebSockets/Client.hs0000644000000000000000000001370113424550505020347 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 , newClientConnection ) where -------------------------------------------------------------------------------- import qualified Data.ByteString.Builder as Builder import Control.Exception (bracket, finally, throwIO) import Control.Monad (void) import Data.IORef (newIORef) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.Socket as S -------------------------------------------------------------------------------- import Network.WebSockets.Connection import Network.WebSockets.Http import Network.WebSockets.Protocol import Network.WebSockets.Stream (Stream) import qualified Network.WebSockets.Stream as Stream 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 path0 opts customHeaders app = do -- Create and connect socket let hints = S.defaultHints {S.addrSocketType = S.Stream} -- Correct host and path. fullHost = if port == 80 then host else (host ++ ":" ++ show port) path = if null path0 then "/" else path0 addr:_ <- S.getAddrInfo (Just hints) (Just host) (Just $ show port) sock <- S.socket (S.addrFamily addr) S.Stream S.defaultProtocol S.setSocketOption sock S.NoDelay 1 -- Connect WebSocket and run client res <- finally (S.connect sock (S.addrAddress addr) >> runClientWithSocket sock fullHost path opts customHeaders app) (S.close sock) -- Clean up return res -------------------------------------------------------------------------------- runClientWithStream :: Stream -- ^ Stream -> String -- ^ Host -> String -- ^ Path -> ConnectionOptions -- ^ Connection options -> Headers -- ^ Custom headers to send -> ClientApp a -- ^ Client application -> IO a runClientWithStream stream host path opts customHeaders app = do newClientConnection stream host path opts customHeaders >>= app -- | Build a new 'Connection' from the client's point of view. -- -- /WARNING/: Be sure to call 'Stream.close' on the given 'Stream' after you are -- done using the 'Connection' in order to properly close the communication -- channel. 'runClientWithStream' handles this for you, prefer to use it when -- possible. newClientConnection :: Stream -- ^ Stream that will be used by the new 'Connection'. -> String -- ^ Host -> String -- ^ Path -> ConnectionOptions -- ^ Connection options -> Headers -- ^ Custom headers to send -> IO Connection newClientConnection stream host path opts customHeaders = do -- Create the request and send it request <- createRequest protocol bHost bPath False customHeaders Stream.write stream (Builder.toLazyByteString $ encodeRequestHead request) mbResponse <- Stream.parse stream decodeResponseHead response <- case mbResponse of Just response -> return response Nothing -> throwIO $ OtherHandshakeException $ "Network.WebSockets.Client.newClientConnection: no handshake " ++ "response from server" void $ either throwIO return $ finishResponse protocol request response parse <- decodeMessages protocol (connectionFramePayloadSizeLimit opts) (connectionMessageDataSizeLimit opts) stream write <- encodeMessages protocol ClientConnection stream sentRef <- newIORef False return $ Connection { connectionOptions = opts , connectionType = ClientConnection , connectionProtocol = protocol , connectionParse = parse , connectionWrite = write , connectionSentClose = sentRef } 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 = bracket (Stream.makeSocketStream sock) Stream.close (\stream -> runClientWithStream stream host path opts customHeaders app) websockets-0.12.5.3/src/Network/WebSockets/Connection/Options.hs0000644000000000000000000001145113424550505022663 0ustar0000000000000000{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- module Network.WebSockets.Connection.Options ( ConnectionOptions (..) , defaultConnectionOptions , CompressionOptions (..) , PermessageDeflate (..) , defaultPermessageDeflate , SizeLimit (..) , atMostSizeLimit ) where -------------------------------------------------------------------------------- import Data.Int (Int64) import Data.Monoid (Monoid (..)) import Prelude -------------------------------------------------------------------------------- -- | Set options for a 'Connection'. Please do not use this constructor -- directly, but rather use 'defaultConnectionOptions' and then set the fields -- you want, e.g.: -- -- > myOptions = defaultConnectionOptions {connectionStrictUnicode = True} -- -- This way your code does not break if the library introduces new fields. data ConnectionOptions = ConnectionOptions { connectionOnPong :: !(IO ()) -- ^ Whenever a 'pong' is received, this IO action is executed. It can be -- used to tickle connections or fire missiles. , connectionCompressionOptions :: !CompressionOptions -- ^ Enable 'PermessageDeflate'. , connectionStrictUnicode :: !Bool -- ^ Enable strict unicode on the connection. This means that if a client -- (or server) sends invalid UTF-8, we will throw a 'UnicodeException' -- rather than replacing it by the unicode replacement character U+FFFD. , connectionFramePayloadSizeLimit :: !SizeLimit -- ^ The maximum size for incoming frame payload size in bytes. If a -- frame exceeds this limit, a 'ParseException' is thrown. , connectionMessageDataSizeLimit :: !SizeLimit -- ^ 'connectionFrameSizeLimit' is often not enough since a malicious -- client can send many small frames to create a huge message. This limit -- allows you to protect from that. If a message exceeds this limit, a -- 'ParseException' is thrown. -- -- Note that, if compression is enabled, we check the size of the -- compressed messages, as well as the size of the uncompressed messages -- as we are deflating them to ensure we don't use too much memory in any -- case. } -------------------------------------------------------------------------------- -- | The default connection options: -- -- * Nothing happens when a pong is received. -- * Compression is disabled. -- * Lenient unicode decoding. defaultConnectionOptions :: ConnectionOptions defaultConnectionOptions = ConnectionOptions { connectionOnPong = return () , connectionCompressionOptions = NoCompression , connectionStrictUnicode = False , connectionFramePayloadSizeLimit = mempty , connectionMessageDataSizeLimit = mempty } -------------------------------------------------------------------------------- data CompressionOptions = NoCompression | PermessageDeflateCompression PermessageDeflate deriving (Eq, Show) -------------------------------------------------------------------------------- -- | Four extension parameters are defined for "permessage-deflate" to -- help endpoints manage per-connection resource usage. -- -- - "server_no_context_takeover" -- - "client_no_context_takeover" -- - "server_max_window_bits" -- - "client_max_window_bits" data PermessageDeflate = PermessageDeflate { serverNoContextTakeover :: Bool , clientNoContextTakeover :: Bool , serverMaxWindowBits :: Int , clientMaxWindowBits :: Int , pdCompressionLevel :: Int } deriving (Eq, Show) -------------------------------------------------------------------------------- defaultPermessageDeflate :: PermessageDeflate defaultPermessageDeflate = PermessageDeflate False False 15 15 8 -------------------------------------------------------------------------------- -- | A size limit, in bytes. The 'Monoid' instance takes the minimum limit. data SizeLimit = NoSizeLimit | SizeLimit !Int64 deriving (Eq, Show) -------------------------------------------------------------------------------- instance Monoid SizeLimit where mempty = NoSizeLimit #if !MIN_VERSION_base(4,11,0) mappend NoSizeLimit y = y mappend x NoSizeLimit = x mappend (SizeLimit x) (SizeLimit y) = SizeLimit (min x y) #else instance Semigroup SizeLimit where (<>) NoSizeLimit y = y (<>) x NoSizeLimit = x (<>) (SizeLimit x) (SizeLimit y) = SizeLimit (min x y) #endif -------------------------------------------------------------------------------- atMostSizeLimit :: Int64 -> SizeLimit -> Bool atMostSizeLimit _ NoSizeLimit = True atMostSizeLimit s (SizeLimit l) = s <= l {-# INLINE atMostSizeLimit #-} websockets-0.12.5.3/src/Network/WebSockets/Extensions/Description.hs0000644000000000000000000000436713251754463023572 0ustar0000000000000000-- | Code for parsing extensions headers. {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.WebSockets.Extensions.Description ( ExtensionParam , ExtensionDescription (..) , ExtensionDescriptions , parseExtensionDescriptions , encodeExtensionDescriptions ) where import Control.Applicative ((*>), (<*)) import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString.Char8 as AC8 import qualified Data.ByteString as B import Data.Monoid (mconcat, mappend) import Prelude type ExtensionParam = (B.ByteString, Maybe B.ByteString) data ExtensionDescription = ExtensionDescription { extName :: !B.ByteString , extParams :: ![ExtensionParam] } deriving (Eq, Show) parseExtensionDescription :: A.Parser ExtensionDescription parseExtensionDescription = do extName <- parseIdentifier extParams <- A.many' (token ';' *> parseParam) return ExtensionDescription {..} where parseIdentifier = AC8.takeWhile isIdentifierChar <* AC8.skipSpace token c = AC8.char8 c <* AC8.skipSpace isIdentifierChar c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9') || c == '-' || c == '_' parseParam :: A.Parser ExtensionParam parseParam = do name <- parseIdentifier val <- A.option Nothing $ fmap Just $ token '=' *> parseIdentifier return (name, val) encodeExtensionDescription :: ExtensionDescription -> B.ByteString encodeExtensionDescription ExtensionDescription {..} = mconcat (extName : map encodeParam extParams) where encodeParam (key, Nothing) = ";" `mappend` key encodeParam (key, Just val) = ";" `mappend` key `mappend` "=" `mappend` val type ExtensionDescriptions = [ExtensionDescription] parseExtensionDescriptions :: B.ByteString -> Either String ExtensionDescriptions parseExtensionDescriptions = A.parseOnly $ AC8.skipSpace *> A.sepBy parseExtensionDescription (AC8.char8 ',' <* AC8.skipSpace) <* A.endOfInput encodeExtensionDescriptions :: ExtensionDescriptions -> B.ByteString encodeExtensionDescriptions = B.intercalate "," . map encodeExtensionDescription websockets-0.12.5.3/src/Network/WebSockets/Extensions/PermessageDeflate.hs0000644000000000000000000002567413135435576024675 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} module Network.WebSockets.Extensions.PermessageDeflate ( defaultPermessageDeflate , PermessageDeflate(..) , negotiateDeflate -- * Considered internal , makeMessageInflater , makeMessageDeflater ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Control.Exception (throwIO) import Control.Monad (foldM, unless) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.ByteString.Lazy.Internal as BL import Data.Int (Int64) import Data.Monoid import qualified Data.Streaming.Zlib as Zlib import Network.WebSockets.Connection.Options import Network.WebSockets.Extensions import Network.WebSockets.Extensions.Description import Network.WebSockets.Http import Network.WebSockets.Types import Prelude import Text.Read (readMaybe) -------------------------------------------------------------------------------- -- | Convert the parameters to an 'ExtensionDescription' that we can put in a -- 'Sec-WebSocket-Extensions' header. toExtensionDescription :: PermessageDeflate -> ExtensionDescription toExtensionDescription PermessageDeflate {..} = ExtensionDescription { extName = "permessage-deflate" , extParams = [("server_no_context_takeover", Nothing) | serverNoContextTakeover] ++ [("client_no_context_takeover", Nothing) | clientNoContextTakeover] ++ [("server_max_window_bits", param serverMaxWindowBits) | serverMaxWindowBits /= 15] ++ [("client_max_window_bits", param clientMaxWindowBits) | clientMaxWindowBits /= 15] } where param = Just . B8.pack . show -------------------------------------------------------------------------------- toHeaders :: PermessageDeflate -> Headers toHeaders pmd = [ ( "Sec-WebSocket-Extensions" , encodeExtensionDescriptions [toExtensionDescription pmd] ) ] -------------------------------------------------------------------------------- negotiateDeflate :: SizeLimit -> Maybe PermessageDeflate -> NegotiateExtension negotiateDeflate messageLimit pmd0 exts0 = do (headers, pmd1) <- negotiateDeflateOpts exts0 pmd0 return Extension { extHeaders = headers , extParse = \parseRaw -> do inflate <- makeMessageInflater messageLimit pmd1 return $ do msg <- parseRaw case msg of Nothing -> return Nothing Just m -> fmap Just (inflate m) , extWrite = \writeRaw -> do deflate <- makeMessageDeflater pmd1 return $ \msgs -> mapM deflate msgs >>= writeRaw } where negotiateDeflateOpts :: ExtensionDescriptions -> Maybe PermessageDeflate -> Either String (Headers, Maybe PermessageDeflate) negotiateDeflateOpts (ext : _) (Just x) | extName ext == "x-webkit-deflate-frame" = Right ([("Sec-WebSocket-Extensions", "x-webkit-deflate-frame")], Just x) negotiateDeflateOpts (ext : _) (Just x) | extName ext == "permessage-deflate" = do x' <- foldM setParam x (extParams ext) Right (toHeaders x', Just x') negotiateDeflateOpts (_ : exts) (Just x) = negotiateDeflateOpts exts (Just x) negotiateDeflateOpts _ _ = Right ([], Nothing) -------------------------------------------------------------------------------- setParam :: PermessageDeflate -> ExtensionParam -> Either String PermessageDeflate setParam pmd ("server_no_context_takeover", _) = Right pmd {serverNoContextTakeover = True} setParam pmd ("client_no_context_takeover", _) = Right pmd {clientNoContextTakeover = True} setParam pmd ("server_max_window_bits", Nothing) = Right pmd {serverMaxWindowBits = 15} setParam pmd ("server_max_window_bits", Just param) = do w <- parseWindow param Right pmd {serverMaxWindowBits = w} setParam pmd ("client_max_window_bits", Nothing) = do Right pmd {clientMaxWindowBits = 15} setParam pmd ("client_max_window_bits", Just param) = do w <- parseWindow param Right pmd {clientMaxWindowBits = w} setParam pmd (_, _) = Right pmd -------------------------------------------------------------------------------- parseWindow :: B.ByteString -> Either String Int parseWindow bs8 = case readMaybe (B8.unpack bs8) of Just w | w >= 8 && w <= 15 -> Right w | otherwise -> Left $ "Window out of bounds: " ++ show w Nothing -> Left $ "Can't parse window: " ++ show bs8 -------------------------------------------------------------------------------- -- | If the window_bits parameter is set to 8, we must set it to 9 instead. -- -- Related issues: -- - https://github.com/haskell/zlib/issues/11 -- - https://github.com/madler/zlib/issues/94 -- -- Quote from zlib manual: -- -- For the current implementation of deflate(), a windowBits value of 8 (a -- window size of 256 bytes) is not supported. As a result, a request for 8 will -- result in 9 (a 512-byte window). In that case, providing 8 to inflateInit2() -- will result in an error when the zlib header with 9 is checked against the -- initialization of inflate(). The remedy is to not use 8 with deflateInit2() -- with this initialization, or at least in that case use 9 with inflateInit2(). fixWindowBits :: Int -> Int fixWindowBits n | n < 9 = 9 | n > 15 = 15 | otherwise = n -------------------------------------------------------------------------------- appTailL :: BL.ByteString appTailL = BL.pack [0x00,0x00,0xff,0xff] -------------------------------------------------------------------------------- maybeStrip :: BL.ByteString -> BL.ByteString maybeStrip x | appTailL `BL.isSuffixOf` x = BL.take (BL.length x - 4) x maybeStrip x = x -------------------------------------------------------------------------------- rejectExtensions :: Message -> IO Message rejectExtensions (DataMessage rsv1 rsv2 rsv3 _) | rsv1 || rsv2 || rsv3 = throwIO $ CloseRequest 1002 "Protocol Error" rejectExtensions x = return x -------------------------------------------------------------------------------- makeMessageDeflater :: Maybe PermessageDeflate -> IO (Message -> IO Message) makeMessageDeflater Nothing = return rejectExtensions makeMessageDeflater (Just pmd) | serverNoContextTakeover pmd = do return $ \msg -> do ptr <- initDeflate pmd deflateMessageWith (deflateBody ptr) msg | otherwise = do ptr <- initDeflate pmd return $ \msg -> deflateMessageWith (deflateBody ptr) msg where ---------------------------------------------------------------------------- initDeflate :: PermessageDeflate -> IO Zlib.Deflate initDeflate PermessageDeflate {..} = Zlib.initDeflate pdCompressionLevel (Zlib.WindowBits (- (fixWindowBits serverMaxWindowBits))) ---------------------------------------------------------------------------- deflateMessageWith :: (BL.ByteString -> IO BL.ByteString) -> Message -> IO Message deflateMessageWith deflater (DataMessage False False False (Text x _)) = do x' <- deflater x return (DataMessage True False False (Text x' Nothing)) deflateMessageWith deflater (DataMessage False False False (Binary x)) = do x' <- deflater x return (DataMessage True False False (Binary x')) deflateMessageWith _ x = return x ---------------------------------------------------------------------------- deflateBody :: Zlib.Deflate -> BL.ByteString -> IO BL.ByteString deflateBody ptr = fmap maybeStrip . go . BL.toChunks where go [] = dePopper (Zlib.flushDeflate ptr) go (c : cs) = do chunk <- Zlib.feedDeflate ptr c >>= dePopper (chunk <>) <$> go cs -------------------------------------------------------------------------------- dePopper :: Zlib.Popper -> IO BL.ByteString dePopper p = p >>= \res -> case res of Zlib.PRDone -> return BL.empty Zlib.PRNext c -> BL.chunk c <$> dePopper p Zlib.PRError x -> throwIO $ CloseRequest 1002 (BL8.pack (show x)) -------------------------------------------------------------------------------- makeMessageInflater :: SizeLimit -> Maybe PermessageDeflate -> IO (Message -> IO Message) makeMessageInflater _ Nothing = return rejectExtensions makeMessageInflater messageLimit (Just pmd) | clientNoContextTakeover pmd = return $ \msg -> do ptr <- initInflate pmd inflateMessageWith (inflateBody ptr) msg | otherwise = do ptr <- initInflate pmd return $ \msg -> inflateMessageWith (inflateBody ptr) msg where -------------------------------------------------------------------------------- initInflate :: PermessageDeflate -> IO Zlib.Inflate initInflate PermessageDeflate {..} = Zlib.initInflate (Zlib.WindowBits (- (fixWindowBits clientMaxWindowBits))) ---------------------------------------------------------------------------- inflateMessageWith :: (BL.ByteString -> IO BL.ByteString) -> Message -> IO Message inflateMessageWith inflater (DataMessage True a b (Text x _)) = do x' <- inflater x return (DataMessage False a b (Text x' Nothing)) inflateMessageWith inflater (DataMessage True a b (Binary x)) = do x' <- inflater x return (DataMessage False a b (Binary x')) inflateMessageWith _ x = return x ---------------------------------------------------------------------------- inflateBody :: Zlib.Inflate -> BL.ByteString -> IO BL.ByteString inflateBody ptr = go 0 . BL.toChunks . (<> appTailL) where go :: Int64 -> [B.ByteString] -> IO BL.ByteString go size0 [] = do chunk <- Zlib.flushInflate ptr checkSize (fromIntegral (B.length chunk) + size0) return (BL.fromStrict chunk) go size0 (c : cs) = do chunk <- Zlib.feedInflate ptr c >>= dePopper let size1 = size0 + BL.length chunk checkSize size1 (chunk <>) <$> go size1 cs ---------------------------------------------------------------------------- checkSize :: Int64 -> IO () checkSize size = unless (atMostSizeLimit size messageLimit) $ throwIO $ ParseException $ "Message of size " ++ show size ++ " exceeded limit" websockets-0.12.5.3/src/Network/WebSockets/Extensions/StrictUnicode.hs0000644000000000000000000000322213074734714024053 0ustar0000000000000000-------------------------------------------------------------------------------- module Network.WebSockets.Extensions.StrictUnicode ( strictUnicode ) where -------------------------------------------------------------------------------- import Control.Exception (throwIO) import qualified Data.ByteString.Lazy as BL import Network.WebSockets.Extensions import Network.WebSockets.Types -------------------------------------------------------------------------------- strictUnicode :: Extension strictUnicode = Extension { extHeaders = [] , extParse = \parseRaw -> return (parseRaw >>= strictParse) , extWrite = return } -------------------------------------------------------------------------------- strictParse :: Maybe Message -> IO (Maybe Message) strictParse Nothing = return Nothing strictParse (Just (DataMessage rsv1 rsv2 rsv3 (Text bl _))) = case decodeUtf8Strict bl of Left err -> throwIO err Right txt -> return (Just (DataMessage rsv1 rsv2 rsv3 (Text bl (Just txt)))) strictParse (Just msg@(ControlMessage (Close _ bl))) = -- If there is a body, the first two bytes of the body MUST be a 2-byte -- unsigned integer (in network byte order) representing a status code with -- value /code/ defined in Section 7.4. Following the 2-byte integer, the -- body MAY contain UTF-8-encoded data with value /reason/, the -- interpretation of which is not defined by this specification. case decodeUtf8Strict (BL.drop 2 bl) of Left err -> throwIO err Right _ -> return (Just msg) strictParse (Just msg) = return (Just msg) websockets-0.12.5.3/src/Network/WebSockets/Http.hs0000644000000000000000000002347713251754463020072 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 , getRequestSubprotocols , getRequestSecWebSocketExtensions ) where -------------------------------------------------------------------------------- import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Builder.Extra as Builder import Control.Applicative (pure, (*>), (<$>), (<*), (<*>)) import Control.Exception (Exception) import qualified Data.Attoparsec.ByteString 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) import qualified Network.WebSockets.Extensions.Description as Extensions -------------------------------------------------------------------------------- -- | 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 Exception HandshakeException -------------------------------------------------------------------------------- encodeRequestHead :: RequestHead -> Builder.Builder encodeRequestHead (RequestHead path headers _) = Builder.byteStringCopy "GET " `mappend` Builder.byteStringCopy path `mappend` Builder.byteStringCopy " HTTP/1.1" `mappend` Builder.byteString "\r\n" `mappend` mconcat (map header headers) `mappend` Builder.byteStringCopy "\r\n" where header (k, v) = mconcat $ map Builder.byteStringCopy [CI.original k, ": ", v, "\r\n"] -------------------------------------------------------------------------------- encodeRequest :: Request -> Builder.Builder encodeRequest (Request head' body) = encodeRequestHead head' `mappend` Builder.byteStringCopy 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.byteStringCopy "HTTP/1.1 " `mappend` Builder.stringUtf8 (show code) `mappend` Builder.charUtf8 ' ' `mappend` Builder.byteString msg `mappend` Builder.byteString "\r\n" `mappend` mconcat (map header headers) `mappend` Builder.byteStringCopy "\r\n" where header (k, v) = mconcat $ map Builder.byteStringCopy [CI.original k, ": ", v, "\r\n"] -------------------------------------------------------------------------------- encodeResponse :: Response -> Builder.Builder encodeResponse (Response head' body) = encodeResponseHead head' `mappend` Builder.byteStringCopy 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.takeWhile (/= c2w '\r') <* newline -------------------------------------------------------------------------------- decodeResponse :: A.Parser Response decodeResponse = Response <$> decodeResponseHead <*> A.takeByteString -------------------------------------------------------------------------------- getRequestHeader :: RequestHead -> CI.CI ByteString -> Either HandshakeException ByteString getRequestHeader rq key = case lookup key (requestHeaders rq) of Just t -> Right t Nothing -> Left $ MalformedRequest rq $ "Header missing: " ++ BC.unpack (CI.original key) -------------------------------------------------------------------------------- getResponseHeader :: ResponseHead -> CI.CI ByteString -> Either HandshakeException ByteString getResponseHeader rsp key = case lookup key (responseHeaders rsp) of Just t -> Right t Nothing -> Left $ 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) -------------------------------------------------------------------------------- -- | List of subprotocols specified by the client, in order of preference. -- If the client did not specify a list of subprotocols, this will be the -- empty list. getRequestSubprotocols :: RequestHead -> [B.ByteString] getRequestSubprotocols rh = maybe [] parse mproto where mproto = lookup "Sec-WebSocket-Protocol" $ requestHeaders rh parse = filter (not . B.null) . BC.splitWith (\o -> o == ',' || o == ' ') -------------------------------------------------------------------------------- -- | Get the @Sec-WebSocket-Extensions@ header getRequestSecWebSocketExtensions :: RequestHead -> Either HandshakeException Extensions.ExtensionDescriptions getRequestSecWebSocketExtensions rq = case lookup "Sec-WebSocket-Extensions" (requestHeaders rq) of Nothing -> Right [] Just ext -> case Extensions.parseExtensionDescriptions ext of Right x -> Right x Left err -> Left $ MalformedRequest rq $ "Malformed Sec-WebSockets-Extensions: " ++ err -------------------------------------------------------------------------------- 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.12.5.3/src/Network/WebSockets/Hybi13.hs0000644000000000000000000002367613251754463020213 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Hybi13 ( headerVersions , finishRequest , finishResponse , encodeMessage , encodeMessages , decodeMessages , createRequest -- Internal (used for testing) , encodeFrame , parseFrame ) where -------------------------------------------------------------------------------- import qualified Data.ByteString.Builder as B import Control.Applicative (pure, (<$>)) import Control.Arrow (first) import Control.Exception (throwIO) import Control.Monad (forM, liftM, unless, when) import Data.Binary.Get (Get, getInt64be, getLazyByteString, getWord16be, getWord8) import Data.Binary.Put (putWord16be, runPut) 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.IORef import Data.Monoid (mappend, mconcat, mempty) import Data.Tuple (swap) import System.Entropy as R import System.Random (RandomGen, newStdGen) -------------------------------------------------------------------------------- import Network.WebSockets.Connection.Options import Network.WebSockets.Http import Network.WebSockets.Hybi13.Demultiplex import Network.WebSockets.Hybi13.Mask import Network.WebSockets.Stream (Stream) import qualified Network.WebSockets.Stream as Stream import Network.WebSockets.Types -------------------------------------------------------------------------------- headerVersions :: [ByteString] headerVersions = ["13"] -------------------------------------------------------------------------------- finishRequest :: RequestHead -> Headers -> Either HandshakeException Response finishRequest reqHttp headers = do !key <- getRequestHeader reqHttp "Sec-WebSocket-Key" let !hash = hashKey key !encoded = B64.encode hash return $ response101 (("Sec-WebSocket-Accept", encoded):headers) "" -------------------------------------------------------------------------------- finishResponse :: RequestHead -> ResponseHead -> Either HandshakeException Response finishResponse request response = do -- Response message should be one of -- -- - WebSocket Protocol Handshake -- - Switching Protocols -- -- But we don't check it for now when (responseCode response /= 101) $ Left $ MalformedResponse response "Wrong response status or message." key <- getRequestHeader request "Sec-WebSocket-Key" responseHash <- getResponseHeader response "Sec-WebSocket-Accept" let challengeHash = B64.encode $ hashKey key when (responseHash /= challengeHash) $ Left $ MalformedResponse response "Challenge and response hashes do not match." return $ Response response "" -------------------------------------------------------------------------------- encodeMessage :: RandomGen g => ConnectionType -> g -> Message -> (g, B.Builder) encodeMessage conType gen msg = (gen', builder) where mkFrame = Frame True False False False (mask, gen') = case conType of ServerConnection -> (Nothing, gen) ClientConnection -> first Just (randomMask gen) builder = encodeFrame mask $ case msg of (ControlMessage (Close code pl)) -> mkFrame CloseFrame $ runPut (putWord16be code) `mappend` pl (ControlMessage (Ping pl)) -> mkFrame PingFrame pl (ControlMessage (Pong pl)) -> mkFrame PongFrame pl (DataMessage rsv1 rsv2 rsv3 (Text pl _)) -> Frame True rsv1 rsv2 rsv3 TextFrame pl (DataMessage rsv1 rsv2 rsv3 (Binary pl)) -> Frame True rsv1 rsv2 rsv3 BinaryFrame pl -------------------------------------------------------------------------------- encodeMessages :: ConnectionType -> Stream -> IO ([Message] -> IO ()) encodeMessages conType stream = do genRef <- newIORef =<< newStdGen return $ \msgs -> do builders <- forM msgs $ \msg -> atomicModifyIORef' genRef $ \s -> encodeMessage conType s msg Stream.write stream (B.toLazyByteString $ mconcat builders) -------------------------------------------------------------------------------- encodeFrame :: Maybe Mask -> Frame -> B.Builder encodeFrame mask f = B.word8 byte0 `mappend` B.word8 byte1 `mappend` len `mappend` maskbytes `mappend` B.lazyByteString (maskPayload mask payload) 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 payload = case frameType f of ContinuationFrame -> framePayload f TextFrame -> framePayload f BinaryFrame -> framePayload f CloseFrame -> BL.take 125 $ framePayload f PingFrame -> BL.take 125 $ framePayload f PongFrame -> BL.take 125 $ framePayload f 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, encodeMask m) byte1 = maskflag .|. lenflag len' = BL.length payload (lenflag, len) | len' < 126 = (fromIntegral len', mempty) | len' < 0x10000 = (126, B.word16BE (fromIntegral len')) | otherwise = (127, B.word64BE (fromIntegral len')) -------------------------------------------------------------------------------- decodeMessages :: SizeLimit -> SizeLimit -> Stream -> IO (IO (Maybe Message)) decodeMessages frameLimit messageLimit stream = do dmRef <- newIORef emptyDemultiplexState return $ go dmRef where go dmRef = do mbFrame <- Stream.parseBin stream (parseFrame frameLimit) case mbFrame of Nothing -> return Nothing Just frame -> do demultiplexResult <- atomicModifyIORef' dmRef $ \s -> swap $ demultiplex messageLimit s frame case demultiplexResult of DemultiplexError err -> throwIO err DemultiplexContinue -> go dmRef DemultiplexSuccess msg -> return (Just msg) -------------------------------------------------------------------------------- -- | Parse a frame parseFrame :: SizeLimit -> Get Frame parseFrame frameSizeLimit = do byte0 <- getWord8 let fin = byte0 .&. 0x80 == 0x80 rsv1 = byte0 .&. 0x40 == 0x40 rsv2 = byte0 .&. 0x20 == 0x20 rsv3 = byte0 .&. 0x10 == 0x10 opcode = byte0 .&. 0x0f byte1 <- getWord8 let mask = byte1 .&. 0x80 == 0x80 lenflag = byte1 .&. 0x7f len <- case lenflag of 126 -> fromIntegral <$> getWord16be 127 -> getInt64be _ -> return (fromIntegral lenflag) -- Check size against limit. unless (atMostSizeLimit len frameSizeLimit) $ fail $ "Frame of size " ++ show len ++ " exceeded limit" ft <- case opcode of 0x00 -> return ContinuationFrame 0x01 -> return TextFrame 0x02 -> return BinaryFrame 0x08 -> enforceControlFrameRestrictions len fin >> return CloseFrame 0x09 -> enforceControlFrameRestrictions len fin >> return PingFrame 0x0a -> enforceControlFrameRestrictions len fin >> return PongFrame _ -> fail $ "Unknown opcode: " ++ show opcode masker <- maskPayload <$> if mask then Just <$> parseMask else pure Nothing chunks <- getLazyByteString len return $ Frame fin rsv1 rsv2 rsv3 ft (masker chunks) where enforceControlFrameRestrictions len fin | not fin = fail "Control Frames must not be fragmented!" | len > 125 = fail "Control Frames must not carry payload > 125 bytes!" | otherwise = pure () -------------------------------------------------------------------------------- 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.12.5.3/src/Network/WebSockets/Hybi13/Demultiplex.hs0000644000000000000000000001374613251754463022504 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Demultiplexing of frames into messages {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Hybi13.Demultiplex ( FrameType (..) , Frame (..) , DemultiplexState , emptyDemultiplexState , DemultiplexResult (..) , demultiplex ) where -------------------------------------------------------------------------------- import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as B import Control.Exception (Exception) import Data.Binary.Get (getWord16be, runGet) import qualified Data.ByteString.Lazy as BL import Data.Int (Int64) import Data.Monoid (mappend) import Data.Typeable (Typeable) import Network.WebSockets.Connection.Options 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 data DemultiplexState = EmptyDemultiplexState | DemultiplexState !Int64 !Builder !(Builder -> Message) -------------------------------------------------------------------------------- emptyDemultiplexState :: DemultiplexState emptyDemultiplexState = EmptyDemultiplexState -------------------------------------------------------------------------------- -- | Result of demultiplexing data DemultiplexResult = DemultiplexSuccess Message | DemultiplexError ConnectionException | DemultiplexContinue -------------------------------------------------------------------------------- demultiplex :: SizeLimit -> DemultiplexState -> Frame -> (DemultiplexResult, DemultiplexState) demultiplex _ state (Frame True False False False PingFrame pl) | BL.length pl > 125 = (DemultiplexError $ CloseRequest 1002 "Protocol Error", emptyDemultiplexState) | otherwise = (DemultiplexSuccess $ ControlMessage (Ping pl), state) demultiplex _ state (Frame True False False False PongFrame pl) = (DemultiplexSuccess (ControlMessage (Pong pl)), state) demultiplex _ _ (Frame True False False False CloseFrame pl) = (DemultiplexSuccess (ControlMessage (uncurry Close parsedClose)), emptyDemultiplexState) where -- The Close frame MAY contain a body (the "Application data" portion of the -- frame) that indicates a reason for closing, such as an endpoint shutting -- down, an endpoint having received a frame too large, or an endpoint -- having received a frame that does not conform to the format expected by -- the endpoint. If there is a body, the first two bytes of the body MUST -- be a 2-byte unsigned integer (in network byte order) representing a -- status code with value /code/ defined in Section 7.4. parsedClose | BL.length pl >= 2 = case runGet getWord16be pl of a | a < 1000 || a `elem` [1004,1005,1006 ,1014,1015,1016 ,1100,2000,2999 ,5000,65535] -> (1002, BL.empty) a -> (a, BL.drop 2 pl) | BL.length pl == 1 = (1002, BL.empty) | otherwise = (1000, BL.empty) demultiplex sizeLimit EmptyDemultiplexState (Frame fin rsv1 rsv2 rsv3 tp pl) = case tp of _ | not (atMostSizeLimit size sizeLimit) -> ( DemultiplexError $ ParseException $ "Message of size " ++ show size ++ " exceeded limit" , emptyDemultiplexState ) TextFrame | fin -> (DemultiplexSuccess (text pl), emptyDemultiplexState) | otherwise -> (DemultiplexContinue, DemultiplexState size plb (text . B.toLazyByteString)) BinaryFrame | fin -> (DemultiplexSuccess (binary pl), emptyDemultiplexState) | otherwise -> (DemultiplexContinue, DemultiplexState size plb (binary . B.toLazyByteString)) _ -> (DemultiplexError $ CloseRequest 1002 "Protocol Error", emptyDemultiplexState) where size = BL.length pl plb = B.lazyByteString pl text x = DataMessage rsv1 rsv2 rsv3 (Text x Nothing) binary x = DataMessage rsv1 rsv2 rsv3 (Binary x) demultiplex sizeLimit (DemultiplexState size0 b f) (Frame fin False False False ContinuationFrame pl) | not (atMostSizeLimit size1 sizeLimit) = ( DemultiplexError $ ParseException $ "Message of size " ++ show size1 ++ " exceeded limit" , emptyDemultiplexState ) | fin = (DemultiplexSuccess (f b'), emptyDemultiplexState) | otherwise = (DemultiplexContinue, DemultiplexState size1 b' f) where size1 = size0 + BL.length pl b' = b `mappend` plb plb = B.lazyByteString pl demultiplex _ _ _ = (DemultiplexError (CloseRequest 1002 "Protocol Error"), emptyDemultiplexState) websockets-0.12.5.3/src/Network/WebSockets/Hybi13/Mask.hs0000644000000000000000000000603013251754463021067 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Masking of fragmes using a simple XOR algorithm {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.WebSockets.Hybi13.Mask ( Mask , parseMask , encodeMask , randomMask , maskPayload ) where -------------------------------------------------------------------------------- import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Builder.Extra as Builder import Data.Binary.Get (Get, getWord32host) import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Internal as BL import Data.Word (Word32, Word8) import Foreign.C.Types (CChar (..), CInt (..), CSize (..)) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, plusPtr) import System.Random (RandomGen, random) -------------------------------------------------------------------------------- foreign import ccall unsafe "_hs_mask_chunk" c_mask_chunk :: Word32 -> CInt -> Ptr CChar -> CSize -> Ptr Word8 -> IO () -------------------------------------------------------------------------------- -- | A mask is sequence of 4 bytes. We store this in a 'Word32' in the host's -- native byte ordering. newtype Mask = Mask {unMask :: Word32} -------------------------------------------------------------------------------- -- | Parse a mask. parseMask :: Get Mask parseMask = fmap Mask getWord32host -------------------------------------------------------------------------------- -- | Encode a mask encodeMask :: Mask -> Builder.Builder encodeMask = Builder.word32Host . unMask -------------------------------------------------------------------------------- -- | Create a random mask randomMask :: forall g. RandomGen g => g -> (Mask, g) randomMask gen = (Mask int, gen') where (!int, !gen') = random gen :: (Word32, g) -------------------------------------------------------------------------------- -- | Mask a lazy bytestring. Uses 'c_mask_chunk' under the hood. maskPayload :: Maybe Mask -> BL.ByteString -> BL.ByteString maskPayload Nothing = id maskPayload (Just (Mask 0)) = id maskPayload (Just (Mask mask)) = go 0 where go _ BL.Empty = BL.Empty go !maskOffset (BL.Chunk (B.PS payload off len) rest) = BL.Chunk maskedChunk (go ((maskOffset + len) `rem` 4) rest) where maskedChunk = B.unsafeCreate len $ \dst -> withForeignPtr payload $ \src -> c_mask_chunk mask (fromIntegral maskOffset) (src `plusPtr` off) (fromIntegral len) dst websockets-0.12.5.3/src/Network/WebSockets/Protocol.hs0000644000000000000000000000570313133677425020745 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 Data.ByteString (ByteString) import qualified Data.ByteString as B -------------------------------------------------------------------------------- import Network.WebSockets.Connection.Options import Network.WebSockets.Http import qualified Network.WebSockets.Hybi13 as Hybi13 import Network.WebSockets.Stream (Stream) 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 -> Headers -> Either HandshakeException Response finishRequest Hybi13 = Hybi13.finishRequest -------------------------------------------------------------------------------- finishResponse :: Protocol -> RequestHead -> ResponseHead -> Either HandshakeException Response finishResponse Hybi13 = Hybi13.finishResponse -------------------------------------------------------------------------------- encodeMessages :: Protocol -> ConnectionType -> Stream -> IO ([Message] -> IO ()) encodeMessages Hybi13 = Hybi13.encodeMessages -------------------------------------------------------------------------------- decodeMessages :: Protocol -> SizeLimit -> SizeLimit -> Stream -> IO (IO (Maybe Message)) decodeMessages Hybi13 frameLimit messageLimit = Hybi13.decodeMessages frameLimit messageLimit -------------------------------------------------------------------------------- createRequest :: Protocol -> B.ByteString -> B.ByteString -> Bool -> Headers -> IO RequestHead createRequest Hybi13 = Hybi13.createRequest websockets-0.12.5.3/src/Network/WebSockets/Server.hs0000644000000000000000000001211413105072736020375 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 , makeListenSocket , makePendingConnection , makePendingConnectionFromStream ) where -------------------------------------------------------------------------------- import Control.Concurrent (forkIOWithUnmask) import Control.Exception (allowInterrupt, bracket, bracketOnError, finally, mask_, throwIO) import Control.Monad (forever, void) import Network.Socket (Socket) import qualified Network.Socket as S -------------------------------------------------------------------------------- import Network.WebSockets.Connection import Network.WebSockets.Http import qualified Network.WebSockets.Stream as Stream import Network.WebSockets.Types -------------------------------------------------------------------------------- -- | 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 or internal applications, but for real -- applications, you should use a real server. -- -- For example: -- -- * Performance is reasonable under load, but: -- * No protection against DoS attacks is provided. -- * No logging is performed. -- * ... -- -- Glue for using this package with real servers is provided by: -- -- * -- -- * 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 $ bracket (makeListenSocket host port) S.close (\sock -> mask_ $ forever $ do allowInterrupt (conn, _) <- S.accept sock void $ forkIOWithUnmask $ \unmask -> finally (unmask $ runApp conn opts app) (S.close conn) ) -------------------------------------------------------------------------------- -- | Create a standardized socket on which you can listen for incomming -- connections. Should only be used for a quick and dirty solution! Should be -- preceded by the call 'Network.Socket.withSocketsDo'. makeListenSocket :: String -> Int -> IO Socket makeListenSocket host port = do addr:_ <- S.getAddrInfo (Just hints) (Just host) (Just (show port)) bracketOnError (S.socket (S.addrFamily addr) S.Stream S.defaultProtocol) S.close (\sock -> do _ <- S.setSocketOption sock S.ReuseAddr 1 _ <- S.setSocketOption sock S.NoDelay 1 S.bind sock (S.addrAddress addr) S.listen sock 5 return sock ) where hints = S.defaultHints { S.addrSocketType = S.Stream } -------------------------------------------------------------------------------- runApp :: Socket -> ConnectionOptions -> ServerApp -> IO () runApp socket opts app = bracket (makePendingConnection socket opts) (Stream.close . pendingStream) app -------------------------------------------------------------------------------- -- | Turns a socket, connected to some client, into a 'PendingConnection'. The -- 'PendingConnection' should be closed using 'Stream.close' later. makePendingConnection :: Socket -> ConnectionOptions -> IO PendingConnection makePendingConnection socket opts = do stream <- Stream.makeSocketStream socket makePendingConnectionFromStream stream opts -- | More general version of 'makePendingConnection' for 'Stream.Stream' -- instead of a 'Socket'. makePendingConnectionFromStream :: Stream.Stream -> ConnectionOptions -> IO PendingConnection makePendingConnectionFromStream stream opts = do -- TODO: we probably want to send a 40x if the request is bad? mbRequest <- Stream.parse stream (decodeRequestHead False) case mbRequest of Nothing -> throwIO ConnectionClosed Just request -> return PendingConnection { pendingOptions = opts , pendingRequest = request , pendingOnAccept = \_ -> return () , pendingStream = stream } websockets-0.12.5.3/src/Network/WebSockets/Types.hs0000644000000000000000000001560613133677425020253 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Primary types {-# LANGUAGE DeriveDataTypeable #-} module Network.WebSockets.Types ( Message (..) , ControlMessage (..) , DataMessage (..) , WebSocketsData (..) , HandshakeException (..) , ConnectionException (..) , ConnectionType (..) , decodeUtf8Lenient , decodeUtf8Strict ) where -------------------------------------------------------------------------------- import Control.Exception (Exception (..)) import Control.Exception (throw, try) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.Encoding.Error as TL import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Data.Typeable (Typeable) import Data.Word (Word16) import System.IO.Unsafe (unsafePerformIO) -------------------------------------------------------------------------------- import Network.WebSockets.Http -------------------------------------------------------------------------------- -- | The kind of message a server application typically deals with data Message = ControlMessage ControlMessage -- | Reserved bits, actual message | DataMessage Bool Bool Bool DataMessage deriving (Eq, Show) -------------------------------------------------------------------------------- -- | Different control messages data ControlMessage = Close Word16 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. -- -- There are currently two kinds of data messages supported by the WebSockets -- protocol: -- -- * Textual UTF-8 encoded data. This corresponds roughly to sending a String -- in JavaScript. -- -- * Binary data. This corresponds roughly to send an ArrayBuffer in -- JavaScript. data DataMessage -- | A textual message. The second field /might/ contain the decoded UTF-8 -- text for caching reasons. This field is computed lazily so if it's not -- accessed, it should have no performance impact. = Text BL.ByteString (Maybe TL.Text) -- | A binary message. | 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 fromDataMessage :: DataMessage -> a fromLazyByteString :: BL.ByteString -> a toLazyByteString :: a -> BL.ByteString -------------------------------------------------------------------------------- instance WebSocketsData BL.ByteString where fromDataMessage (Text bl _) = bl fromDataMessage (Binary bl) = bl fromLazyByteString = id toLazyByteString = id -------------------------------------------------------------------------------- instance WebSocketsData B.ByteString where fromDataMessage (Text bl _) = fromLazyByteString bl fromDataMessage (Binary bl) = fromLazyByteString bl fromLazyByteString = B.concat . BL.toChunks toLazyByteString = BL.fromChunks . return -------------------------------------------------------------------------------- instance WebSocketsData TL.Text where fromDataMessage (Text _ (Just tl)) = tl fromDataMessage (Text bl Nothing) = fromLazyByteString bl fromDataMessage (Binary bl) = fromLazyByteString bl fromLazyByteString = TL.decodeUtf8 toLazyByteString = TL.encodeUtf8 -------------------------------------------------------------------------------- instance WebSocketsData T.Text where fromDataMessage (Text _ (Just tl)) = T.concat (TL.toChunks tl) fromDataMessage (Text bl Nothing) = fromLazyByteString bl fromDataMessage (Binary bl) = fromLazyByteString bl fromLazyByteString = T.concat . TL.toChunks . fromLazyByteString toLazyByteString = toLazyByteString . TL.fromChunks . return -------------------------------------------------------------------------------- -- | Various exceptions that can occur while receiving or transmitting messages data ConnectionException -- | The peer has requested that the connection be closed, and included -- a close code and a reason for closing. When receiving this exception, -- no more messages can be sent. Also, the server is responsible for -- closing the TCP connection once this exception is received. -- -- See for a list of close -- codes. = CloseRequest Word16 BL.ByteString -- | The peer unexpectedly closed the connection while we were trying to -- receive some data. This is a violation of the websocket RFC since the -- TCP connection should only be closed after sending and receiving close -- control messages. | ConnectionClosed -- | The client sent garbage, i.e. we could not parse the WebSockets stream. | ParseException String -- | The client sent invalid UTF-8. Note that this exception will only be -- thrown if strict decoding is set in the connection options. | UnicodeException String deriving (Eq, Show, Typeable) -------------------------------------------------------------------------------- instance Exception ConnectionException -------------------------------------------------------------------------------- data ConnectionType = ServerConnection | ClientConnection deriving (Eq, Ord, Show) -------------------------------------------------------------------------------- -- | Replace an invalid input byte with the Unicode replacement character -- U+FFFD. decodeUtf8Lenient :: BL.ByteString -> TL.Text decodeUtf8Lenient = TL.decodeUtf8With TL.lenientDecode -------------------------------------------------------------------------------- -- | Throw an error if there is an invalid input byte. decodeUtf8Strict :: BL.ByteString -> Either ConnectionException TL.Text decodeUtf8Strict bl = unsafePerformIO $ try $ let txt = TL.decodeUtf8With (\err _ -> throw (UnicodeException err)) bl in TL.length txt `seq` return txt websockets-0.12.5.3/cbits/cbits.c0000644000000000000000000000456113424550521014662 0ustar0000000000000000#include #include #include #include /* Taken from: * * */ static inline uint32_t rotr32(uint32_t n, unsigned int c) { const unsigned int mask = (CHAR_BIT*sizeof(n)-1); c &= mask; /* avoid undef behaviour with NDEBUG. 0 overhead for most types / compilers */ return (n>>c) | (n<<( (-c)&mask )); } /* - `mask` is the 4-byte mask to apply to the source. It is stored in the * hosts' native byte ordering. * - `mask_offset` is the initial offset in the mask. It is specified in bytes * and should be between 0 and 3 (inclusive). This is necessary for when we * are dealing with multiple chunks. * - `src` is the source pointer. * - `len` is the size of the source (and destination) in bytes. * - `dst` is the destination. */ void _hs_mask_chunk( uint32_t mask, int mask_offset, uint8_t *src, size_t len, uint8_t *dst) { const uint8_t *src_end = src + len; /* We have two fast paths: one for `x86_64` and one for `i386` * architectures. In these fast paths, we mask 8 (or 4) bytes at a time. * * Note that we use unaligned loads and stores (allowed on these * architectures). This makes the code much easier to write, since we don't * need to guarantee that `src` and `dst` have the same alignment. * * It only causes a minor slowdown, around 5% on my machine (TM). */ #if defined(__x86_64__) uint64_t mask64; /* Set up 64 byte mask. */ mask64 = (uint64_t)(rotr32(mask, 8 * mask_offset)); mask64 |= (mask64 << 32); /* Take the fast road. */ while (src < src_end - 7) { *(uint64_t *)dst = *(uint64_t*)src ^ mask64; src += 8; dst += 8; } #elif defined(__i386__) /* Set up 32 byte mask. */ uint32_t mask32; mask32 = (uint32_t)(rotr32(mask, 8 * mask_offset)); /* Take the fast road. */ while (src < src_end - 3) { *(uint32_t *)dst = *(uint32_t*)src ^ mask32; src += 4; dst += 4; } #endif /* This is the slow path which also handles the un-aligned suffix. */ uint8_t *mask_ptr = (uint8_t *) &mask; while (src != src_end) { *dst = *src ^ *(mask_ptr + mask_offset); src++; dst++; mask_offset = (mask_offset + 1) & 0x3; } } websockets-0.12.5.3/tests/autobahn/server.hs0000644000000000000000000000515313223015276017111 0ustar0000000000000000-------------------------------------------------------------------------------- -- | The server part of the tests {-# LANGUAGE OverloadedStrings #-} module Main ( main ) where {- ## once virtualenv pyt source pyt/bin/activate ### pip install --upgrade setuptools ### possibly pip install autobahntestsuite ## each time source pyt/bin/activate mkdir -p test && cd test wstest -m fuzzingclient websockets-autobahn -} -------------------------------------------------------------------------------- import Control.Exception (catch) import Data.ByteString.Lazy.Char8 () import Data.String (fromString) import Data.Version (showVersion) -------------------------------------------------------------------------------- import qualified Network.WebSockets as WS import qualified Paths_websockets -------------------------------------------------------------------------------- echoDataMessage :: WS.Connection -> IO () echoDataMessage conn = go 0 where go :: Int -> IO () go x = do msg <- WS.receiveDataMessage conn WS.sendDataMessage conn msg go (x + 1) -------------------------------------------------------------------------------- infoHeaders :: WS.Headers infoHeaders = [ ( "Server" , fromString $ "websockets/" ++ showVersion Paths_websockets.version ) ] -------------------------------------------------------------------------------- -- | Application application :: WS.ServerApp application pc = do conn <- WS.acceptRequestWith pc WS.defaultAcceptRequest { WS.acceptHeaders = infoHeaders } echoDataMessage conn `catch` handleClose where handleClose (WS.CloseRequest i "") = putStrLn $ "Clean close (" ++ show i ++ ")" handleClose (WS.CloseRequest i msg) = putStrLn $ "Clean close (" ++ show i ++ "): " ++ show msg handleClose WS.ConnectionClosed = putStrLn "Unexpected connection closed exception" handleClose (WS.ParseException e) = putStrLn $ "Recevied parse exception: " ++ show e handleClose (WS.UnicodeException e) = putStrLn $ "Recevied unicode exception: " ++ show e -------------------------------------------------------------------------------- -- | Accepts clients, spawns a single handler for each one. main :: IO () main = WS.runServerWith "0.0.0.0" 9001 options application where options = WS.defaultConnectionOptions { WS.connectionCompressionOptions = WS.PermessageDeflateCompression WS.defaultPermessageDeflate , WS.connectionStrictUnicode = True } websockets-0.12.5.3/example/server.lhs0000644000000000000000000001233013275255045015757 0ustar0000000000000000websockets example ================== This is the Haskell implementation of the example for the WebSockets library. We implement a simple multi-user chat program. A live demo of the example is available [here](/example/client.html). In order to understand this example, keep the [reference](/reference/) nearby to check out the functions we use. > {-# LANGUAGE OverloadedStrings #-} > module Main where > import Data.Char (isPunctuation, isSpace) > import Data.Monoid (mappend) > import Data.Text (Text) > import Control.Exception (finally) > import Control.Monad (forM_, forever) > import Control.Concurrent (MVar, newMVar, modifyMVar_, modifyMVar, readMVar) > import qualified Data.Text as T > import qualified Data.Text.IO as T > import qualified Network.WebSockets as WS We represent a client by their username and a `WS.Connection`. We will see how we obtain this `WS.Connection` later on. > type Client = (Text, WS.Connection) The state kept on the server is simply a list of connected clients. We've added an alias and some utility functions, so it will be easier to extend this state later on. > type ServerState = [Client] Create a new, initial state: > newServerState :: ServerState > newServerState = [] Get the number of active clients: > numClients :: ServerState -> Int > numClients = length Check if a user already exists (based on username): > clientExists :: Client -> ServerState -> Bool > clientExists client = any ((== fst client) . fst) Add a client (this does not check if the client already exists, you should do this yourself using `clientExists`): > addClient :: Client -> ServerState -> ServerState > addClient client clients = client : clients Remove a client: > removeClient :: Client -> ServerState -> ServerState > removeClient client = filter ((/= fst client) . fst) Send a message to all clients, and log it on stdout: > broadcast :: Text -> ServerState -> IO () > broadcast message clients = do > T.putStrLn message > forM_ clients $ \(_, conn) -> WS.sendTextData conn message The main function first creates a new state for the server, then spawns the actual server. For this purpose, we use the simple server provided by `WS.runServer`. > main :: IO () > main = do > state <- newMVar newServerState > WS.runServer "127.0.0.1" 9160 $ application state Our main application has the type: > application :: MVar ServerState -> WS.ServerApp Note that `WS.ServerApp` is nothing but a type synonym for `WS.PendingConnection -> IO ()`. Our application starts by accepting the connection. In a more realistic application, you probably want to check the path and headers provided by the pending request. We also fork a pinging thread in the background. This will ensure the connection stays alive on some browsers. > application state pending = do > conn <- WS.acceptRequest pending > WS.forkPingThread conn 30 When a client is succesfully connected, we read the first message. This should be in the format of "Hi! I am Jasper", where Jasper is the requested username. > msg <- WS.receiveData conn > clients <- readMVar state > case msg of Check that the first message has the right format: > _ | not (prefix `T.isPrefixOf` msg) -> > WS.sendTextData conn ("Wrong announcement" :: Text) Check the validity of the username: > | any ($ fst client) > [T.null, T.any isPunctuation, T.any isSpace] -> > WS.sendTextData conn ("Name cannot " `mappend` > "contain punctuation or whitespace, and " `mappend` > "cannot be empty" :: Text) Check that the given username is not already taken: > | clientExists client clients -> > WS.sendTextData conn ("User already exists" :: Text) All is right! We're going to allow the client, but for safety reasons we *first* setup a `disconnect` function that will be run when the connection is closed. > | otherwise -> flip finally disconnect $ do We send a "Welcome!", according to our own little protocol. We add the client to the list and broadcast the fact that he has joined. Then, we give control to the 'talk' function. > modifyMVar_ state $ \s -> do > let s' = addClient client s > WS.sendTextData conn $ > "Welcome! Users: " `mappend` > T.intercalate ", " (map fst s) > broadcast (fst client `mappend` " joined") s' > return s' > talk client state > where > prefix = "Hi! I am " > client = (T.drop (T.length prefix) msg, conn) > disconnect = do > -- Remove client and return new state > s <- modifyMVar state $ \s -> > let s' = removeClient client s in return (s', s') > broadcast (fst client `mappend` " disconnected") s The talk function continues to read messages from a single client until he disconnects. All messages are broadcasted to the other clients. > talk :: Client -> MVar ServerState -> IO () > talk (user, conn) state = forever $ do > msg <- WS.receiveData conn > readMVar state >>= broadcast > (user `mappend` ": " `mappend` msg) websockets-0.12.5.3/tests/haskell/TestSuite.hs0000644000000000000000000000207213133677425017365 0ustar0000000000000000-------------------------------------------------------------------------------- import qualified Network.WebSockets.Extensions.Tests import qualified Network.WebSockets.Extensions.PermessageDeflate.Tests import qualified Network.WebSockets.Handshake.Tests import qualified Network.WebSockets.Http.Tests import qualified Network.WebSockets.Hybi13.Demultiplex.Tests import qualified Network.WebSockets.Mask.Tests import qualified Network.WebSockets.Server.Tests import qualified Network.WebSockets.Tests import Test.Framework (defaultMain) -------------------------------------------------------------------------------- main :: IO () main = defaultMain [ Network.WebSockets.Extensions.Tests.tests , Network.WebSockets.Extensions.PermessageDeflate.Tests.tests , Network.WebSockets.Handshake.Tests.tests , Network.WebSockets.Http.Tests.tests , Network.WebSockets.Hybi13.Demultiplex.Tests.tests , Network.WebSockets.Server.Tests.tests , Network.WebSockets.Mask.Tests.tests , Network.WebSockets.Tests.tests ] websockets-0.12.5.3/tests/haskell/Network/WebSockets/Extensions/PermessageDeflate/Tests.hs0000644000000000000000000000375313133677425027766 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Extensions.PermessageDeflate.Tests ( tests ) where -------------------------------------------------------------------------------- import Control.Exception (try) import qualified Data.ByteString.Lazy as BL import Network.WebSockets.Extensions.PermessageDeflate import Network.WebSockets.Types import Network.WebSockets.Connection.Options import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, (@?=)) -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Network.WebSockets.Extensions.PermessageDeflate.Tests" [ testCase "OK 1" $ do inflater <- makeMessageInflater (SizeLimit 100) (Just defaultPermessageDeflate) message <- inflater $ DataMessage True False False (Binary deflated100) message @?= DataMessage False False False (Binary inflated100) , testCase "Exceed 1" $ do inflater <- makeMessageInflater (SizeLimit 99) (Just defaultPermessageDeflate) assertParseException $ inflater $ DataMessage True False False (Binary deflated100) ] where assertParseException :: IO a -> Assertion assertParseException io = do errOrX <- try io case errOrX of Left (ParseException _) -> return () _ -> fail "Excepted ParseException" -- This inflates to 100 bytes. deflated100 = "b`\160=\NUL\NUL" inflated100 = BL.replicate 100 0 websockets-0.12.5.3/tests/haskell/Network/WebSockets/Extensions/Tests.hs0000644000000000000000000000372413074734714024403 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Extensions.Tests ( tests ) where -------------------------------------------------------------------------------- import Network.WebSockets.Extensions import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Network.WebSockets.Extensions.Tests" [ testCase "parseExtensionDescriptions 01" $ do parseExtensionDescriptions "permessage-deflate" @?= Right [ ExtensionDescription "permessage-deflate" [] ] , testCase "parseExtensionDescriptions 02" $ do parseExtensionDescriptions "permessage-deflate; client_max_window_bits; server_max_window_bits=10" @?= Right [ ExtensionDescription "permessage-deflate" [ ("client_max_window_bits", Nothing) , ("server_max_window_bits", Just "10") ] ] , testCase "parseExtensionDescriptions 03" $ do parseExtensionDescriptions "permessage-deflate; client_max_window_bits=15; server_max_window_bits=10, permessage-deflate; client_max_window_bits,permessage-deflate; client_max_window_bits=15; client_max_window_bits=10" @?= Right [ ExtensionDescription "permessage-deflate" [ ("client_max_window_bits", Just "15") , ("server_max_window_bits", Just "10") ] , ExtensionDescription "permessage-deflate" [ ("client_max_window_bits", Nothing) ] , ExtensionDescription "permessage-deflate" [ ("client_max_window_bits", Just "15") , ("client_max_window_bits", Just "10") ] ] ] websockets-0.12.5.3/tests/haskell/Network/WebSockets/Handshake/Tests.hs0000644000000000000000000001702613072462164024125 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 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 qualified Network.WebSockets.Stream as Stream -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Network.WebSockets.Handshake.Test" [ testCase "handshake Hybi13" testHandshakeHybi13 , testCase "handshake Hybi13 with subprotocols" testHandshakeHybi13WithProto , testCase "handshake Hybi13 with headers" testHandshakeHybi13WithHeaders , testCase "handshake Hybi13 with subprotocols and headers" testHandshakeHybi13WithProtoAndHeaders , testCase "handshake reject" testHandshakeReject , testCase "handshake reject with custom code" testHandshakeRejectWithCode , testCase "handshake Hybi9000" testHandshakeHybi9000 ] -------------------------------------------------------------------------------- testHandshake :: RequestHead -> (PendingConnection -> IO a) -> IO ResponseHead testHandshake rq app = do echo <- Stream.makeEchoStream _ <- forkIO $ do _ <- app (PendingConnection defaultConnectionOptions rq nullify echo) return () mbRh <- Stream.parse echo decodeResponseHead Stream.close echo case mbRh of Nothing -> fail "testHandshake: No response" Just rh -> return rh 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, superchat") , ("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" lookup "Sec-WebSocket-Protocol" headers @?= Nothing -------------------------------------------------------------------------------- testHandshakeHybi13WithProto :: Assertion testHandshakeHybi13WithProto = do onAcceptFired <- newIORef False ResponseHead code message headers <- testHandshake rq13 $ \pc -> do getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"] acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True} (AcceptRequest (Just "superchat") []) readIORef onAcceptFired >>= assert code @?= 101 message @?= "WebSocket Protocol Handshake" headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk=" headers ! "Connection" @?= "Upgrade" headers ! "Sec-WebSocket-Protocol" @?= "superchat" -------------------------------------------------------------------------------- testHandshakeHybi13WithHeaders :: Assertion testHandshakeHybi13WithHeaders = do onAcceptFired <- newIORef False ResponseHead code message headers <- testHandshake rq13 $ \pc -> do getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"] acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True} (AcceptRequest Nothing [("Set-Cookie","sid=foo")]) readIORef onAcceptFired >>= assert code @?= 101 message @?= "WebSocket Protocol Handshake" headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk=" headers ! "Connection" @?= "Upgrade" headers ! "Set-Cookie" @?= "sid=foo" lookup "Sec-WebSocket-Protocol" headers @?= Nothing -------------------------------------------------------------------------------- testHandshakeHybi13WithProtoAndHeaders :: Assertion testHandshakeHybi13WithProtoAndHeaders = do onAcceptFired <- newIORef False ResponseHead code message headers <- testHandshake rq13 $ \pc -> do getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"] acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True} (AcceptRequest (Just "superchat") [("Set-Cookie","sid=foo")]) readIORef onAcceptFired >>= assert code @?= 101 message @?= "WebSocket Protocol Handshake" headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk=" headers ! "Connection" @?= "Upgrade" headers ! "Sec-WebSocket-Protocol" @?= "superchat" headers ! "Set-Cookie" @?= "sid=foo" -------------------------------------------------------------------------------- testHandshakeReject :: Assertion testHandshakeReject = do ResponseHead code _ _ <- testHandshake rq13 $ \pc -> rejectRequest pc "YOU SHALL NOT PASS" code @?= 400 -------------------------------------------------------------------------------- testHandshakeRejectWithCode :: Assertion testHandshakeRejectWithCode = do ResponseHead code _ _ <- testHandshake rq13 $ \pc -> rejectRequestWith pc defaultRejectRequest { rejectBody = "YOU SHALL NOT PASS" , rejectCode = 401 } code @?= 401 -------------------------------------------------------------------------------- -- 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.12.5.3/tests/haskell/Network/WebSockets/Http/Tests.hs0000644000000000000000000000627013111331443023142 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Http.Tests ( tests ) where -------------------------------------------------------------------------------- import qualified Data.Attoparsec.ByteString 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 , testCase "matchbook response" matchbookResponse ] -------------------------------------------------------------------------------- -- | 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" ] -------------------------------------------------------------------------------- -- | This is a specific response sent by Matchbook.com which caused trouble matchbookResponse :: Assertion matchbookResponse = assert $ case A.parseOnly decodeResponseHead input of Left err -> error err Right _ -> True where input = BC.intercalate "\r\n" [ "HTTP/1.1 101 " , "Date: Mon, 22 May 2017 19:39:08 GMT" , "Connection: upgrade" , "Set-Cookie: __cfduid=deadbeefdeadbeefdeadbeefdeadbeefdeadbeefdea; expires=Tue, 22-May-18 19:39:08 GMT; path=/; domain=.matchbook.com; HttpOnly" , "X-Content-Type-Options: nosniff" , "X-XSS-Protection: 1; mode=block" , "X-Frame-Options: DENY" , "Upgrade: websocket" , "Sec-WebSocket-Accept: dEadB33fDeadbEEfD3aDbE3Fdea=" , "X-MB-HA: edge-socket" , "X-MB-HAP: haproxy01aws" , "Server: cloudflare-nginx" , "CF-RAY: 3632deadbeef5b33-HEL" , "" , "" ] websockets-0.12.5.3/tests/haskell/Network/WebSockets/Hybi13/Demultiplex/Tests.hs0000644000000000000000000000536513133677425025603 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Hybi13.Demultiplex.Tests ( tests ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import qualified Data.ByteString.Lazy as BL import Network.WebSockets import Network.WebSockets.Hybi13.Demultiplex import Prelude import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, (@=?)) -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Network.WebSockets.Hybi13.Demultiplex.Tests" [ testMessageDataSizeLimit ] -------------------------------------------------------------------------------- testMessageDataSizeLimit :: Test testMessageDataSizeLimit = testGroup "testMessageDataSizeLimit Hybi13" [ testCase "OK 1" $ Right [DataMessage False False False (Binary (mkZeroes 100))] @=? testDemultiplex (SizeLimit 100) (fragmented 5 20) , testCase "Exceeds 1" $ assertLeft $ testDemultiplex (SizeLimit 99) (fragmented 5 20) , testCase "Exceeds 2" $ assertLeft $ testDemultiplex (SizeLimit 100) (fragmented 6 20) , testCase "Exceeds 3" $ assertLeft $ testDemultiplex (SizeLimit 100) (fragmented 101 1) , testCase "Exceeds 4" $ assertLeft $ testDemultiplex (SizeLimit 100) (fragmented 1 101) ] where fragmented :: Int -> Int -> [Frame] fragmented n size = let payload = mkZeroes size in [Frame False False False False BinaryFrame payload] ++ replicate (n - 2) (Frame False False False False ContinuationFrame payload) ++ [Frame True False False False ContinuationFrame payload] mkZeroes :: Int -> BL.ByteString mkZeroes size = BL.replicate (fromIntegral size) 0 assertLeft :: Either a b -> Assertion assertLeft (Left _) = return () assertLeft (Right _) = fail "Expecting test to fail" -------------------------------------------------------------------------------- testDemultiplex :: SizeLimit -> [Frame] -> Either ConnectionException [Message] testDemultiplex messageLimit = go emptyDemultiplexState where go _state0 [] = return [] go state0 (frame : frames) = case demultiplex messageLimit state0 frame of (DemultiplexContinue, state1) -> go state1 frames (DemultiplexError err, _) -> Left err (DemultiplexSuccess m, state1) -> (m :) <$> go state1 frames websockets-0.12.5.3/tests/haskell/Network/WebSockets/Mask/Tests.hs0000644000000000000000000000420613105561166023125 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Mask.Tests ( tests ) where -------------------------------------------------------------------------------- import qualified Data.Binary.Get as Get import Data.Bits (xor) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Network.WebSockets.Hybi13.Mask import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck (Arbitrary (..), (===)) import qualified Test.QuickCheck as QC -------------------------------------------------------------------------------- import Network.WebSockets.Tests.Util tests :: Test tests = testGroup "Network.WebSockets.Masks.Tests" [ testProperty "correct fast masking" testMasking ] maskPayload' :: Maybe B.ByteString -> BL.ByteString -> BL.ByteString maskPayload' Nothing = id maskPayload' (Just mask) = snd . BL.mapAccumL f (cycle $ B.unpack mask) where f [] !c = ([], c) f (m:ms) !c = (ms, m `xor` c) newtype AMask = AMask B.ByteString deriving (Show) instance Arbitrary AMask where arbitrary = do c1 <- arbitrary c2 <- arbitrary c3 <- arbitrary c4 <- arbitrary return (AMask (B.pack [c1,c2,c3,c4])) newtype APkt = APkt BL.ByteString deriving (Show) instance Arbitrary APkt where arbitrary = do b1 <- arbitraryByteString b2 <- arbitraryByteString return $ APkt (b1 `BL.append` b2) -- Just for sure to test correctly different alignments shrink (APkt bs) = map APkt [ BL.append a b | (a, b) <- zip (BL.inits bs) (tail $ BL.tails bs) ] testMasking :: QC.Property testMasking = QC.forAllShrink QC.arbitrary QC.shrink $ \(AMask mask, APkt pkt) -> let wmask = Get.runGet parseMask (BL.fromStrict mask) in maskPayload' (Just mask) pkt === maskPayload (Just wmask) pkt websockets-0.12.5.3/tests/haskell/Network/WebSockets/Server/Tests.hs0000644000000000000000000001563213317411473023505 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, catch, handle) import Control.Monad (forever, replicateM, unless) import Data.IORef (IORef, newIORef, readIORef, writeIORef) -------------------------------------------------------------------------------- import qualified Data.ByteString.Lazy as BL import Data.Text (Text) import System.Environment (getEnvironment) 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 Test.QuickCheck.Random (newQCGen) -------------------------------------------------------------------------------- import Network.WebSockets import Network.WebSockets.Tests.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Network.WebSockets.Server.Tests" [ testCase "simple server/client" testSimpleServerClient , testCase "bulk server/client" testBulkServerClient , testCase "onPong" testOnPong , testCase "ipv6 server" testIpv6Server ] -------------------------------------------------------------------------------- testSimpleServerClient :: Assertion testSimpleServerClient = testServerClient "127.0.0.1" $ \conn -> mapM_ (sendTextData conn) -------------------------------------------------------------------------------- -- | This is a bit ugly but it seems CI services don't support ipv6 in 2018. skipIpv6Incompatible :: Assertion -> Assertion skipIpv6Incompatible assertion = do env <- getEnvironment case lookup "TRAVIS" env <|> lookup "CIRCLECI" env of Just "true" -> return () _ -> assertion -------------------------------------------------------------------------------- testIpv6Server :: Assertion testIpv6Server = skipIpv6Incompatible $ testServerClient "::1" $ \conn -> mapM_ (sendTextData conn) -------------------------------------------------------------------------------- testBulkServerClient :: Assertion testBulkServerClient = testServerClient "127.0.0.1" sendTextDatas -------------------------------------------------------------------------------- testServerClient :: String -> (Connection -> [BL.ByteString] -> IO ()) -> Assertion testServerClient host sendMessages = withEchoServer host 42940 "Bye" $ do texts <- map unArbitraryUtf8 <$> sample texts' <- retry $ runClient host 42940 "/chat" $ client texts texts @=? texts' where client :: [BL.ByteString] -> ClientApp [BL.ByteString] client texts conn = do sendMessages conn texts texts' <- replicateM (length texts) (receiveData conn) sendClose conn ("Bye" :: BL.ByteString) expectCloseException conn "Bye" return texts' -------------------------------------------------------------------------------- testOnPong :: Assertion testOnPong = withEchoServer "127.0.0.1" 42941 "Bye" $ 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 sendCloseCode conn 1000 ("Bye" :: BL.ByteString) expectCloseException conn "Bye" return $ "A fsh!" == (msg :: Text) -------------------------------------------------------------------------------- sample :: Arbitrary a => IO [a] sample = do gen <- newQCGen 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 :: String -> Int -> BL.ByteString -> IO a -> IO a withEchoServer host port expectedClose action = do cRef <- newIORef False serverThread <- forkIO $ retry $ runServer host port (\c -> server c `catch` handleClose cRef) waitSome result <- action waitSome killThread serverThread closeCalled <- readIORef cRef unless closeCalled $ error "Expecting the CloseRequest exception" return result where server :: ServerApp server pc = do conn <- acceptRequest pc forever $ do msg <- receiveDataMessage conn sendDataMessage conn msg handleClose :: IORef Bool -> ConnectionException -> IO () handleClose cRef (CloseRequest i msg) = do i @=? 1000 msg @=? expectedClose writeIORef cRef True handleClose _ ConnectionClosed = error "Unexpected connection closed exception" handleClose _ (ParseException _) = error "Unexpected parse exception" handleClose _ (UnicodeException _) = error "Unexpected unicode exception" -------------------------------------------------------------------------------- expectCloseException :: Connection -> BL.ByteString -> IO () expectCloseException conn msg = act `catch` handler where act = receiveDataMessage conn >> error "Expecting CloseRequest exception" handler (CloseRequest i msg') = do i @=? 1000 msg' @=? msg handler ConnectionClosed = error "Unexpected connection closed" handler (ParseException _) = error "Unexpected parse exception" handler (UnicodeException _) = error "Unexpected unicode exception" websockets-0.12.5.3/tests/haskell/Network/WebSockets/Tests.hs0000644000000000000000000002302313251754463022236 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.WebSockets.Tests ( tests ) where -------------------------------------------------------------------------------- import qualified Data.ByteString.Builder as Builder import Control.Applicative ((<$>)) import Control.Concurrent (forkIO) import Control.Exception (try) import Control.Monad (replicateM) import Data.Binary.Get (runGetOrFail) import qualified Data.ByteString.Lazy as BL import Data.List (intersperse) import Data.Maybe (catMaybes) import Data.Monoid (mempty, mconcat) import Network.WebSockets import qualified Network.WebSockets.Hybi13 as Hybi13 import Network.WebSockets.Hybi13.Demultiplex import Network.WebSockets.Protocol import qualified Network.WebSockets.Stream as Stream import Network.WebSockets.Tests.Util import Network.WebSockets.Types import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) 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 Prelude -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Network.WebSockets.Test" [ testProperty "simple encode/decode Hybi13" (testSimpleEncodeDecode Hybi13) , testProperty "fragmented Hybi13" testFragmentedHybi13 , testRfc_6455_5_5_1 , testRfc_6455_5_5_2 , testFramePayloadSizeLimit ] -------------------------------------------------------------------------------- testSimpleEncodeDecode :: Protocol -> Property testSimpleEncodeDecode protocol = QC.monadicIO $ QC.forAllM QC.arbitrary $ \msgs -> QC.run $ do echo <- Stream.makeEchoStream parse <- decodeMessages protocol mempty mempty echo write <- encodeMessages protocol ClientConnection echo _ <- forkIO $ write msgs msgs' <- catMaybes <$> replicateM (length msgs) parse Stream.close echo msgs @=? msgs' -------------------------------------------------------------------------------- testFragmentedHybi13 :: Property testFragmentedHybi13 = QC.monadicIO $ QC.forAllM QC.arbitrary $ \fragmented -> QC.run $ do echo <- Stream.makeEchoStream parse <- Hybi13.decodeMessages mempty mempty echo -- is' <- Streams.filter isDataMessage =<< Hybi13.decodeMessages is -- Simple hacky encoding of all frames _ <- forkIO $ do mapM_ (Stream.write echo) [ Builder.toLazyByteString (Hybi13.encodeFrame Nothing f) | FragmentedMessage _ frames <- fragmented , f <- frames ] Stream.close echo -- Check if we got all data msgs <- filter isDataMessage <$> parseAll parse [msg | FragmentedMessage msg _ <- fragmented] @=? msgs where isDataMessage (ControlMessage _) = False isDataMessage (DataMessage _ _ _ _) = True parseAll parse = do mbMsg <- try parse case mbMsg of Left ConnectionClosed -> return [] Left _ -> return [] Right (Just msg) -> (msg :) <$> parseAll parse Right Nothing -> return [] -------------------------------------------------------------------------------- testRfc_6455_5_5_1 :: Test testRfc_6455_5_5_1 = testCase "RFC 6455, 5.5: Frame encoder shall truncate control frame payload to 125 bytes" $ do 260 @=? BL.length (encodedFrame ContinuationFrame) 260 @=? BL.length (encodedFrame TextFrame) 260 @=? BL.length (encodedFrame BinaryFrame) 127 @=? BL.length (encodedFrame CloseFrame) 127 @=? BL.length (encodedFrame PingFrame) 127 @=? BL.length (encodedFrame PongFrame) where payload256 = BL.replicate 256 0 encodedFrame ft = Builder.toLazyByteString $ Hybi13.encodeFrame Nothing (Frame True False False False ft payload256) -------------------------------------------------------------------------------- testRfc_6455_5_5_2 :: Test testRfc_6455_5_5_2 = testCase "RFC 6455, 5.5: Frame decoder shall fail if control frame payload length > 125 bytes" $ Left (BL.drop 4 ping126, 4, errMsg) @=? runGetOrFail (Hybi13.parseFrame mempty) ping126 where errMsg = "Control Frames must not carry payload > 125 bytes!" ping126 = mconcat [ "\137\254\NUL~\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" , "\SI\190\252\219\SI" ] testFramePayloadSizeLimit :: Test testFramePayloadSizeLimit = testGroup "FramePayloadSizeLimit Hybi13" [ testCase "OK 1" $ case parse (frame 99) of Right _ -> return () Left _ -> fail "Expecting successful parse." , testCase "OK 2" $ case parse (frame 100) of Right _ -> return () Left _ -> fail "Expecting successful parse." , testCase "Exceed" $ case parse (frame 101) of Right _ -> fail "Expecting parse to fail." Left _ -> return () ] where parse = runGetOrFail (Hybi13.parseFrame (SizeLimit 100)) frame n = Builder.toLazyByteString $ Hybi13.encodeFrame Nothing $ Frame True False False False BinaryFrame (BL.replicate n 20) -------------------------------------------------------------------------------- instance Arbitrary Message where arbitrary = QC.oneof [ do payload <- BL.take 125 . BL.pack <$> arbitrary return $ ControlMessage (Ping payload) , do payload <- BL.take 125 . BL.pack <$> arbitrary return $ ControlMessage (Pong payload) , do payload <- BL.pack <$> arbitrary return $ DataMessage False False False (Text payload Nothing) , do payload <- BL.pack <$> arbitrary return $ DataMessage False False False (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 False False False (Text payload Nothing) BinaryFrame -> DataMessage False False False (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 False False False 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.12.5.3/tests/haskell/Network/WebSockets/Tests/Util.hs0000644000000000000000000000254512722550455023156 0ustar0000000000000000-------------------------------------------------------------------------------- module Network.WebSockets.Tests.Util ( ArbitraryUtf8 (..) , arbitraryUtf8 , arbitraryByteString ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import qualified Data.ByteString.Lazy as BL import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL 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 websockets-0.12.5.3/benchmarks/mask.hs0000644000000000000000000000606413105562161015711 0ustar0000000000000000{-# language BangPatterns #-} {-# language OverloadedStrings #-} import Criterion import Criterion.Main import qualified Data.Binary.Get as Get import Network.WebSockets.Hybi13.Mask import Data.Bits (shiftR, xor) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL setupEnv = do let kilo = BL.replicate 1024 37 mega = BL.replicate (1024 * 1024) 37 megaU = BL.fromChunks [B.drop 1 (B.replicate (1024 * 1024) 37)] megaS = BL.fromChunks [B.replicate (1024 * 1024) 37] return (kilo, mega, megaU, megaS) maskPayload' :: Maybe B.ByteString -> BL.ByteString -> BL.ByteString maskPayload' Nothing = id maskPayload' (Just mask) = snd . BL.mapAccumL f (cycle $ B.unpack mask) where f [] !c = ([], c) f (m:ms) !c = (ms, m `xor` c) main = defaultMain [ env setupEnv $ \ ~(kilo, mega, megaU, megaS) -> bgroup "main" [ bgroup "kilobyte payload" [ bgroup "zero_mask" [ bench "current" $ nf (maskPayload (mkMask $ "\x00\x00\x00\x00")) kilo , bench "old" $ nf (maskPayload' (Just "\x00\x00\x00\x00")) kilo ] , bgroup "full_mask" [ bench "current" $ nf (maskPayload (mkMask "\xFF\xFF\xFF\xFF")) kilo , bench "current-unaligned" $ nf (maskPayload (mkMask "\xFF\xFF\xFF\xFF")) (BL.drop 1 kilo) , bench "old" $ nf (maskPayload' (Just "\xFF\xFF\xFF\xFF")) kilo ] , bgroup "one_byte_mask" [ bench "current" $ nf (maskPayload (mkMask "\xCC\xCC\xCC\xCC")) kilo , bench "old" $ nf (maskPayload' (Just "\xCC\xCC\xCC\xCC")) kilo ] , bgroup "other_mask" [ bench "current" $ nf (maskPayload (mkMask "\xB0\xA2\xB0\xA2")) kilo , bench "old" $ nf (maskPayload' (Just "\xB0\xA2\xB0\xA2")) kilo ] ] , bgroup "megabyte payload" [ bgroup "zero_mask" [ bench "current" $ nf (maskPayload (mkMask "\x00\x00\x00\x00")) mega , bench "old" $ nf (maskPayload' (Just "\x00\x00\x00\x00")) mega ] , bgroup "full_mask" [ bench "current" $ nf (maskPayload (mkMask "\xFF\xFF\xFF\xFF")) mega , bench "current-unaligned" $ nf (maskPayload (mkMask "\xFF\xFF\xFF\xFF")) megaU , bench "current-aligned" $ nf (maskPayload (mkMask "\xFF\xFF\xFF\xFF")) megaS , bench "old" $ nf (maskPayload' (Just "\xFF\xFF\xFF\xFF")) mega ] , bgroup "one_byte_mask" [ bench "current" $ nf (maskPayload (mkMask "\xCC\xCC\xCC\xCC")) mega , bench "old" $ nf (maskPayload' (Just "\xCC\xCC\xCC\xCC")) mega ] , bgroup "other_mask" [ bench "current" $ nf (maskPayload (mkMask "\xB0\xA2\xB0\xA2")) mega , bench "old" $ nf (maskPayload' (Just "\xB0\xA2\xB0\xA2")) mega ] ] ] ] where mkMask b = Just $ Get.runGet parseMask b websockets-0.12.5.3/LICENCE0000644000000000000000000000277012722550455013301 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.12.5.3/Setup.hs0000644000000000000000000000005612722550455013743 0ustar0000000000000000import Distribution.Simple main = defaultMain websockets-0.12.5.3/websockets.cabal0000644000000000000000000001641313424557066015455 0ustar0000000000000000Name: websockets Version: 0.12.5.3 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-2018 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 Extra-source-files: CHANGELOG Source-repository head Type: git Location: https://github.com/jaspervdj/websockets Flag Example Description: Build the example server Default: False Manual: True Library Hs-source-dirs: src Ghc-options: -Wall C-sources: cbits/cbits.c Exposed-modules: Network.WebSockets Network.WebSockets.Connection Network.WebSockets.Extensions Network.WebSockets.Stream -- Network.WebSockets.Util.PubSub TODO Other-modules: Network.WebSockets.Client Network.WebSockets.Connection.Options Network.WebSockets.Extensions.Description Network.WebSockets.Extensions.PermessageDeflate Network.WebSockets.Extensions.StrictUnicode 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.10 && < 0.14, base >= 4.6 && < 5, base64-bytestring >= 0.1 && < 1.1, binary >= 0.8.1 && < 0.11, bytestring >= 0.9 && < 0.11, bytestring-builder < 0.11, case-insensitive >= 0.3 && < 1.3, containers >= 0.3 && < 0.7, network >= 2.3 && < 3.1, random >= 1.0 && < 1.2, SHA >= 1.5 && < 1.7, streaming-commons >= 0.1 && < 0.3, text >= 0.10 && < 1.3, entropy >= 0.2.1 && < 0.5 Test-suite websockets-tests Type: exitcode-stdio-1.0 Hs-source-dirs: src tests/haskell Main-is: TestSuite.hs Ghc-options: -Wall C-sources: cbits/cbits.c Other-modules: Network.WebSockets Network.WebSockets.Client Network.WebSockets.Connection Network.WebSockets.Connection.Options Network.WebSockets.Extensions Network.WebSockets.Extensions.Description Network.WebSockets.Extensions.PermessageDeflate Network.WebSockets.Extensions.PermessageDeflate.Tests Network.WebSockets.Extensions.StrictUnicode Network.WebSockets.Extensions.Tests Network.WebSockets.Handshake.Tests Network.WebSockets.Http Network.WebSockets.Http.Tests Network.WebSockets.Hybi13 Network.WebSockets.Hybi13.Demultiplex Network.WebSockets.Hybi13.Demultiplex.Tests Network.WebSockets.Hybi13.Mask Network.WebSockets.Mask.Tests Network.WebSockets.Protocol Network.WebSockets.Server Network.WebSockets.Server.Tests Network.WebSockets.Stream Network.WebSockets.Tests Network.WebSockets.Tests.Util Network.WebSockets.Types Paths_websockets Build-depends: HUnit >= 1.2 && < 1.7, QuickCheck >= 2.7 && < 2.13, 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.10 && < 0.14, base >= 4 && < 5, base64-bytestring >= 0.1 && < 1.1, binary >= 0.8.1 && < 0.11, bytestring >= 0.9 && < 0.11, bytestring-builder < 0.11, case-insensitive >= 0.3 && < 1.3, containers >= 0.3 && < 0.7, network >= 2.3 && < 3.1, random >= 1.0 && < 1.2, SHA >= 1.5 && < 1.7, streaming-commons >= 0.1 && < 0.3, text >= 0.10 && < 1.3, entropy >= 0.2.1 && < 0.5 Executable websockets-example If !flag(Example) Buildable: False Hs-source-dirs: example Main-is: server.lhs Ghc-options: -Wall Build-depends: websockets, -- Copied from regular dependencies... attoparsec >= 0.10 && < 0.14, base >= 4 && < 5, base64-bytestring >= 0.1 && < 1.1, binary >= 0.8.1 && < 0.11, bytestring >= 0.9 && < 0.11, bytestring-builder < 0.11, case-insensitive >= 0.3 && < 1.3, containers >= 0.3 && < 0.7, network >= 2.3 && < 3.1, random >= 1.0 && < 1.2, SHA >= 1.5 && < 1.7, text >= 0.10 && < 1.3, entropy >= 0.2.1 && < 0.5 Executable websockets-autobahn If !flag(Example) Buildable: False Hs-source-dirs: tests/autobahn Main-is: server.hs Ghc-options: -Wall -threaded -O2 -rtsopts "-with-rtsopts=-N" Other-modules: Paths_websockets Build-depends: websockets, -- Copied from regular dependencies... attoparsec >= 0.10 && < 0.14, base >= 4 && < 5, base64-bytestring >= 0.1 && < 1.1, binary >= 0.8.1 && < 0.11, bytestring >= 0.9 && < 0.11, bytestring-builder < 0.11, case-insensitive >= 0.3 && < 1.3, containers >= 0.3 && < 0.7, network >= 2.3 && < 3.1, random >= 1.0 && < 1.2, SHA >= 1.5 && < 1.7, text >= 0.10 && < 1.3, entropy >= 0.2.1 && < 0.5 Benchmark bench-mask Type: exitcode-stdio-1.0 Main-is: mask.hs C-sources: cbits/cbits.c Hs-source-dirs: benchmarks, src Other-modules: Network.WebSockets.Hybi13.Mask Build-depends: criterion, -- Copied from regular dependencies... attoparsec >= 0.10 && < 0.14, base >= 4 && < 5, base64-bytestring >= 0.1 && < 1.1, binary >= 0.8.1 && < 0.11, bytestring >= 0.9 && < 0.11, bytestring-builder < 0.11, case-insensitive >= 0.3 && < 1.3, containers >= 0.3 && < 0.7, network >= 2.3 && < 3.1, random >= 1.0 && < 1.2, SHA >= 1.5 && < 1.7, text >= 0.10 && < 1.3, entropy >= 0.2.1 && < 0.5 websockets-0.12.5.3/CHANGELOG0000644000000000000000000001122213424557120013512 0ustar0000000000000000# CHANGELOG - 0.12.5.3 (2019-01-31) * Bump `network` dependency to 3.0 - 0.12.5.2 (2018-09-25) * Bump `containers` dependency to 0.6 * Bump `network` dependency to 2.8 * Bump `QuickCheck` dependency to 2.12 * Bump `binary` dependency to 0.10 - 0.12.5.1 (2018-06-12) * Fix build with GHC 7.6 and 7.8 - 0.12.5.0 (2018-06-01) * Add `newClientConnection` (by Renzo Carbonara) - 0.12.4.1 (2018-05-11) * Bump `network` dependency to 2.7 - 0.12.4.0 (2018-03-13) * Remove `blaze-builder` dependency * Bump `streaming-commons` dependency to 0.2 * Bump `QuickCheck` dependency to 2.11 * Fix compatibility with old GHC versions * Re-export more functions from `Network.WebSockets` - `sendDataMessages` - `sendBinaryDatas` - `sendCloseCode` * Don't crash when sending the empty list of messages * Add `SemiGroup` instance for `SizeLimit` - 0.12.3.1 (2018-01-10) * Bump CHANGELOG with IPv6 warning * Run all autobahn tests during CI - 0.12.3.0 (2018-01-02) * Fix error thrown from runClient functions * Bump `QuickCheck` dependency to 2.10 * Bump `entropy` dependency to 0.4 * Bump `binary` dependency to 0.10 - 0.12.2.0 (2017-07-28) * Don't use LambdaCase, we want to support older GHC versions - 0.12.1.0 (2017-07-22) * Fix Monoid import on older base versions * Increase lower bound on `binary` to 0.8.1 (by Jonathan Daugherty) - 0.12.0.0 * Add limit options for frame and message size to prevent against (D)DoS attacks * Fix space leak in encodeMessages (by Roman Borschel) * Stricter frame/encoding decoding for ping/close frames (by Lars Petersen) - 0.11.2.0 * Fix 0-width reason phrase parsing * Change receive buffer from 1024 to 8192 bytes (by Ondrej Palkovsky) * Implement fast masking in C (by Ondrej Palkovsky and myself) * Some haddock improvements * Bump `HUnit` dependency to 1.6 - 0.11.1.0 * Fix compilation issue with GHC-7.8 - 0.11.0.0 * Support for IPv6 in the built-in server, client and tests (by agentm). This can cause issues on backends that do not enable IPv6. For more information and a workaround, see this issue: . * Faster masking (by Dmitry Ivanov) * Support for `permessage-deflate` extension (by Marcin Tolysz) * Strict unicode checking and proper extension mechanism - 0.10.0.0 * Fix client specifying empty path * Allow sending collections of messages (by David Turner) * Allow sending extra headers when accepting request (by James Deery) - 0.9.8.2 * Bump `HUnit` dependency to 1.5 - 0.9.8.1 * Restore state of the package to version `0.9.7.0` - 0.9.8.0 * This release contained a feature which broke backwards-compatibility. Hence, it was marked as broken a new release containing the changes will be uploaded as `0.10.0.0`. - 0.9.7.0 * Fix issue trying to kill builtin server * Bump `QuickCheck` dependency to 2.9 - 0.9.6.2 * Bump `binary` dependency for GHC 8.0 compatibility - 0.9.6.1 * Fix issue with fragmentation test - 0.9.6.0 * Optionally include example server in the cabal file * Send correct port from client * Set `TCP_NO_DELAY` in builtin server * Bump `HUnit` dependency * Drop dependency on `mtl` * Fix `QuickCheck` dependency lower bound - 0.9.5.0 * Bugfixes wrt closing sockets and streams - 0.9.4.0 * Add `makePendingConnectionFromStream` function * Bump `attoparsec` dependency - 0.9.3.1 * Bump `QuickCheck` dependency - 0.9.3.0 * Use a shared closed state for connection input/output stream * Make sure `runServer` doesn't leak any sockets * Bump `blaze-builder` dependency - 0.9.2.2 * Bump `random` dependency - 0.9.2.1 * Fix exception handling issues - 0.9.2.0 * Make sending and receiving messages thread-safe by default * Export `forkPingThread` * Fix Windows `withSocketsDo` issue - 0.9.1.0 * Don't use Network.ByteString.Lazy.sendAll on Windows - 0.9.0.1 * Allow compilation with older bytestring versions * Bump text dependency - 0.9.0.0 * Bump various dependencies * Remove io-streams dependency * New close mechanism * More flexible API interface - 0.8.2.6 * Bump QuickCheck dependency - 0.8.2.5 * Bump attoparsec dependency - 0.8.2.4 * Bump entropy dependency - 0.8.2.3 * Bump mtl dependency - 0.8.2.2 * Bump network dependency - 0.8.2.1 * Add benchmark with many open connections * Update example to use gender-neutral language - 0.8.2.0 * Fix possible leaking of client sockets when connection times out