websockets-0.9.7.0/0000755000000000000000000000000012745136007012231 5ustar0000000000000000websockets-0.9.7.0/websockets.cabal0000644000000000000000000001065712745136007015377 0ustar0000000000000000Name: websockets Version: 0.9.7.0 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell. Description: This library allows you to write WebSocket-capable servers. . An example server: . An example client: . See also: . * The specification of the WebSocket protocol: . * The JavaScript API for dealing with WebSockets: License: BSD3 License-file: LICENCE Copyright: (c) 2010-2011 Siniša Biđin (c) 2011-2013 Jasper Van der Jeugt (c) 2011 Steffen Schuldenzucker (c) 2011 Alex Lang Author: Siniša Biđin Jasper Van der Jeugt Steffen Schuldenzucker Alex Lang Maintainer: Jasper Van der Jeugt Stability: experimental Category: Network Build-type: Simple Cabal-version: >= 1.8 Homepage: http://jaspervdj.be/websockets Bug-reports: https://github.com/jaspervdj/websockets/issues Extra-source-files: CHANGELOG Flag Example Description: Build the example server Default: False Manual: True Library Hs-source-dirs: src Ghc-options: -Wall Exposed-modules: Network.WebSockets Network.WebSockets.Connection Network.WebSockets.Stream -- Network.WebSockets.Util.PubSub TODO Other-modules: Network.WebSockets.Client Network.WebSockets.Http Network.WebSockets.Hybi13 Network.WebSockets.Hybi13.Demultiplex Network.WebSockets.Hybi13.Mask Network.WebSockets.Protocol Network.WebSockets.Server Network.WebSockets.Types Build-depends: attoparsec >= 0.10 && < 0.14, base >= 4.4 && < 5, base64-bytestring >= 0.1 && < 1.1, binary >= 0.5 && < 0.9, blaze-builder >= 0.3 && < 0.5, bytestring >= 0.9 && < 0.11, case-insensitive >= 0.3 && < 1.3, containers >= 0.3 && < 0.6, network >= 2.3 && < 2.7, random >= 1.0 && < 1.2, SHA >= 1.5 && < 1.7, text >= 0.10 && < 1.3, entropy >= 0.2.1 && < 0.4 Test-suite websockets-tests Type: exitcode-stdio-1.0 Hs-source-dirs: src tests/haskell Main-is: TestSuite.hs Ghc-options: -Wall Other-modules: Network.WebSockets.Handshake.Tests Network.WebSockets.Http.Tests Network.WebSockets.Server.Tests Network.WebSockets.Tests Network.WebSockets.Tests.Util Build-depends: HUnit >= 1.2 && < 1.4, QuickCheck >= 2.7 && < 2.10, 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.5 && < 0.9, blaze-builder >= 0.3 && < 0.5, bytestring >= 0.9 && < 0.11, case-insensitive >= 0.3 && < 1.3, containers >= 0.3 && < 0.6, network >= 2.3 && < 2.7, random >= 1.0 && < 1.2, SHA >= 1.5 && < 1.7, text >= 0.10 && < 1.3, entropy >= 0.2.1 && < 0.4 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.5 && < 0.9, blaze-builder >= 0.3 && < 0.5, bytestring >= 0.9 && < 0.11, case-insensitive >= 0.3 && < 1.3, containers >= 0.3 && < 0.6, network >= 2.3 && < 2.7, random >= 1.0 && < 1.2, SHA >= 1.5 && < 1.7, text >= 0.10 && < 1.3, entropy >= 0.2.1 && < 0.4 Source-repository head Type: git Location: https://github.com/jaspervdj/websockets websockets-0.9.7.0/Setup.hs0000644000000000000000000000005612745136007013666 0ustar0000000000000000import Distribution.Simple main = defaultMain websockets-0.9.7.0/CHANGELOG0000644000000000000000000000336312745136007013450 0ustar0000000000000000- 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 websockets-0.9.7.0/LICENCE0000644000000000000000000000277012745136007013224 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.9.7.0/example/0000755000000000000000000000000012745136007013664 5ustar0000000000000000websockets-0.9.7.0/example/server.lhs0000644000000000000000000001241012745136007015700 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](http://jaspervdj.be/websockets-example). In order to understand this example, keep the [reference](http://jaspervdj.be/websockets/reference) nearby to check out the functions we use. > {-# LANGUAGE OverloadedStrings #-} > 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 "0.0.0.0" 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 conn state client > 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 :: WS.Connection -> MVar ServerState -> Client -> IO () > talk conn state (user, _) = forever $ do > msg <- WS.receiveData conn > readMVar state >>= broadcast > (user `mappend` ": " `mappend` msg) websockets-0.9.7.0/tests/0000755000000000000000000000000012745136007013373 5ustar0000000000000000websockets-0.9.7.0/tests/haskell/0000755000000000000000000000000012745136007015016 5ustar0000000000000000websockets-0.9.7.0/tests/haskell/TestSuite.hs0000644000000000000000000000131012745136007017276 0ustar0000000000000000-------------------------------------------------------------------------------- import Test.Framework (defaultMain) -------------------------------------------------------------------------------- import qualified Network.WebSockets.Handshake.Tests import qualified Network.WebSockets.Http.Tests import qualified Network.WebSockets.Server.Tests import qualified Network.WebSockets.Tests -------------------------------------------------------------------------------- main :: IO () main = defaultMain [ Network.WebSockets.Handshake.Tests.tests , Network.WebSockets.Http.Tests.tests , Network.WebSockets.Server.Tests.tests , Network.WebSockets.Tests.tests ] websockets-0.9.7.0/tests/haskell/Network/0000755000000000000000000000000012745136007016447 5ustar0000000000000000websockets-0.9.7.0/tests/haskell/Network/WebSockets/0000755000000000000000000000000012745136007020520 5ustar0000000000000000websockets-0.9.7.0/tests/haskell/Network/WebSockets/Tests.hs0000644000000000000000000001640412745136007022163 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.WebSockets.Tests ( tests ) where -------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as Builder import Control.Applicative ((<$>)) import Control.Concurrent (forkIO) import Control.Exception (try) import Control.Monad (forM_, replicateM) import qualified Data.ByteString.Lazy as BL import Data.List (intersperse) import Data.Maybe (catMaybes) import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit ((@=?)) import Test.QuickCheck (Arbitrary (..), Gen, Property) import qualified Test.QuickCheck as QC import qualified Test.QuickCheck.Monadic as QC -------------------------------------------------------------------------------- import Network.WebSockets import qualified Network.WebSockets.Hybi13 as Hybi13 import Network.WebSockets.Hybi13.Demultiplex import Network.WebSockets.Protocol import qualified Network.WebSockets.Stream as Stream import Network.WebSockets.Tests.Util import Network.WebSockets.Types -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Network.WebSockets.Test" [ testProperty "simple encode/decode Hybi13" (testSimpleEncodeDecode Hybi13) , testProperty "fragmented Hybi13" testFragmentedHybi13 ] -------------------------------------------------------------------------------- testSimpleEncodeDecode :: Protocol -> Property testSimpleEncodeDecode protocol = QC.monadicIO $ QC.forAllM QC.arbitrary $ \msgs -> QC.run $ do echo <- Stream.makeEchoStream parse <- decodeMessages protocol echo write <- encodeMessages protocol ClientConnection echo _ <- forkIO $ forM_ msgs write 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 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 [] -------------------------------------------------------------------------------- instance Arbitrary FrameType where arbitrary = QC.elements [ ContinuationFrame , TextFrame , BinaryFrame , CloseFrame , PingFrame , PongFrame ] -------------------------------------------------------------------------------- instance Arbitrary Frame where arbitrary = do fin <- arbitrary rsv1 <- arbitrary rsv2 <- arbitrary rsv3 <- arbitrary t <- arbitrary payload <- case t of TextFrame -> arbitraryUtf8 _ -> BL.pack <$> arbitrary return $ Frame fin rsv1 rsv2 rsv3 t payload -------------------------------------------------------------------------------- instance Arbitrary Message where arbitrary = do payload <- BL.pack <$> arbitrary closecode <- arbitrary QC.elements [ ControlMessage (Close closecode payload) , ControlMessage (Ping payload) , ControlMessage (Pong payload) , DataMessage (Text payload) , DataMessage (Binary payload) ] -------------------------------------------------------------------------------- data FragmentedMessage = FragmentedMessage Message [Frame] deriving (Show) -------------------------------------------------------------------------------- instance Arbitrary FragmentedMessage where arbitrary = do -- Pick a frametype and a corresponding random payload ft <- QC.elements [TextFrame, BinaryFrame] payload <- case ft of TextFrame -> arbitraryUtf8 _ -> arbitraryByteString fragments <- arbitraryFragmentation payload let fs = makeFrames $ zip (ft : repeat ContinuationFrame) fragments msg = case ft of TextFrame -> DataMessage (Text payload) BinaryFrame -> DataMessage (Binary payload) _ -> error "Arbitrary FragmentedMessage crashed" interleaved <- arbitraryInterleave genControlFrame fs return $ FragmentedMessage msg interleaved -- return $ FragmentedMessage msg fs where makeFrames [] = [] makeFrames [(ft, pl)] = [Frame True False False False ft pl] makeFrames ((ft, pl) : fr) = Frame False False False False ft pl : makeFrames fr genControlFrame = QC.elements [ Frame True False False False PingFrame "Herp" , Frame True True True True PongFrame "Derp" ] -------------------------------------------------------------------------------- arbitraryFragmentation :: BL.ByteString -> Gen [BL.ByteString] arbitraryFragmentation bs = arbitraryFragmentation' bs where len :: Int len = fromIntegral $ BL.length bs arbitraryFragmentation' bs' = do -- TODO: we currently can't send packets of length 0. We should -- investigate why (regardless of the spec). n <- QC.choose (1, len - 1) let (l, r) = BL.splitAt (fromIntegral n) bs' case r of "" -> return [l] _ -> (l :) <$> arbitraryFragmentation' r -------------------------------------------------------------------------------- arbitraryInterleave :: Gen a -> [a] -> Gen [a] arbitraryInterleave sep xs = fmap concat $ sequence $ [sep'] ++ intersperse sep' [return [x] | x <- xs] ++ [sep'] where sep' = QC.sized $ \size -> do num <- QC.choose (1, size) replicateM num sep websockets-0.9.7.0/tests/haskell/Network/WebSockets/Http/0000755000000000000000000000000012745136007021437 5ustar0000000000000000websockets-0.9.7.0/tests/haskell/Network/WebSockets/Http/Tests.hs0000644000000000000000000000421412745136007023076 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 ] -------------------------------------------------------------------------------- -- | This is a specific response sent by jwebsockets which caused trouble jWebSocketsResponse :: Assertion jWebSocketsResponse = assert $ case A.parseOnly decodeResponseHead input of Left err -> error err Right _ -> True where input = BC.intercalate "\r\n" [ "HTTP/1.1 101 Switching Protocols" , "Upgrade: websocket" , "Connection: Upgrade" , "Sec-WebSocket-Accept: Ha0QR1T9CoYx/nqwHsVnW8KVTSo=" , "Sec-WebSocket-Origin: " , "Sec-WebSocket-Location: ws://127.0.0.1" , "Set-Cookie: JWSSESSIONID=2e0690e2e328f327056a5676b6a890e3; HttpOnly" , "" , "" ] -------------------------------------------------------------------------------- -- | This is a specific response sent by chromium which caused trouble chromiumResponse :: Assertion chromiumResponse = assert $ case A.parseOnly decodeResponseHead input of Left err -> error err Right _ -> True where input = BC.intercalate "\r\n" [ "HTTP/1.1 500 Internal Error" , "Content-Type:text/html" , "Content-Length:23" , "" , "No such target id: 20_1" ] websockets-0.9.7.0/tests/haskell/Network/WebSockets/Handshake/0000755000000000000000000000000012745136007022406 5ustar0000000000000000websockets-0.9.7.0/tests/haskell/Network/WebSockets/Handshake/Tests.hs0000644000000000000000000001227112745136007024047 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 reject" testHandshakeReject , 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" -------------------------------------------------------------------------------- testHandshakeReject :: Assertion testHandshakeReject = do ResponseHead code _ _ <- testHandshake rq13 $ \pc -> rejectRequest pc "YOU SHALL NOT PASS" code @?= 400 -------------------------------------------------------------------------------- -- I don't believe this one is supported yet rq9000 :: RequestHead rq9000 = RequestHead "/chat" [ ("Host", "server.example.com") , ("Upgrade", "websocket") , ("Connection", "Upgrade") , ("Sec-WebSocket-Key", "dGhlIHNhbXBsZSBub25jZQ==") , ("Sec-WebSocket-Origin", "http://example.com") , ("Sec-WebSocket-Protocol", "chat, superchat") , ("Sec-WebSocket-Version", "9000") ] False -------------------------------------------------------------------------------- testHandshakeHybi9000 :: Assertion testHandshakeHybi9000 = do ResponseHead code _ headers <- testHandshake rq9000 $ \pc -> flip handle (acceptRequest pc) $ \e -> case e of NotSupported -> return undefined _ -> error $ "Unexpected Exception: " ++ show e code @?= 400 headers ! "Sec-WebSocket-Version" @?= "13" websockets-0.9.7.0/tests/haskell/Network/WebSockets/Tests/0000755000000000000000000000000012745136007021622 5ustar0000000000000000websockets-0.9.7.0/tests/haskell/Network/WebSockets/Tests/Util.hs0000644000000000000000000000254512745136007023101 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.9.7.0/tests/haskell/Network/WebSockets/Server/0000755000000000000000000000000012745136007021766 5ustar0000000000000000websockets-0.9.7.0/tests/haskell/Network/WebSockets/Server/Tests.hs0000644000000000000000000001310712745136007023426 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.WebSockets.Server.Tests ( tests ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Exception (SomeException, handle, catch) import Control.Monad (forM_, forever, replicateM, unless) import Data.IORef (newIORef, readIORef, IORef, writeIORef) -------------------------------------------------------------------------------- import qualified Data.ByteString.Lazy as BL import Data.Text (Text) 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.Connection import Network.WebSockets.Tests.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Network.WebSockets.Server.Tests" [ testCase "simple server/client" testSimpleServerClient , testCase "onPong" testOnPong ] -------------------------------------------------------------------------------- testSimpleServerClient :: Assertion testSimpleServerClient = withEchoServer 42940 "Bye" $ do texts <- map unArbitraryUtf8 <$> sample texts' <- retry $ runClient "127.0.0.1" 42940 "/chat" $ client texts texts @=? texts' where client :: [BL.ByteString] -> ClientApp [BL.ByteString] client texts conn = do forM_ texts (sendTextData conn) texts' <- replicateM (length texts) (receiveData conn) sendClose conn ("Bye" :: BL.ByteString) expectCloseException conn "Bye" return texts' -------------------------------------------------------------------------------- testOnPong :: Assertion testOnPong = withEchoServer 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 :: Int -> BL.ByteString -> IO a -> IO a withEchoServer port expectedClose action = do cRef <- newIORef False serverThread <- forkIO $ retry $ runServer "0.0.0.0" 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" -------------------------------------------------------------------------------- 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" websockets-0.9.7.0/src/0000755000000000000000000000000012745136007013020 5ustar0000000000000000websockets-0.9.7.0/src/Network/0000755000000000000000000000000012745136007014451 5ustar0000000000000000websockets-0.9.7.0/src/Network/WebSockets.hs0000644000000000000000000000333712745136007017064 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE ScopedTypeVariables #-} module Network.WebSockets ( -- * Incoming connections and handshaking PendingConnection , pendingRequest , AcceptRequest(..) , acceptRequest , acceptRequestWith , rejectRequest -- * Main connection type , Connection -- * Options for connections , ConnectionOptions (..) , defaultConnectionOptions -- * Sending and receiving messages , receive , receiveDataMessage , receiveData , send , sendDataMessage , sendTextData , sendBinaryData , sendClose , sendPing -- * HTTP Types , Headers , Request (..) , RequestHead (..) , 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 -- * 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.9.7.0/src/Network/WebSockets/0000755000000000000000000000000012745136007016522 5ustar0000000000000000websockets-0.9.7.0/src/Network/WebSockets/Hybi13.hs0000644000000000000000000002206512745136007020122 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Hybi13 ( headerVersions , finishRequest , finishResponse , encodeMessages , decodeMessages , createRequest -- Internal (used for testing) , encodeFrame ) where -------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as B import Control.Applicative (pure, (<$>)) import Control.Exception (throw) import Control.Monad (liftM) import qualified Data.Attoparsec.ByteString as A import Data.Binary.Get (getWord16be, getWord64be, runGet) 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.Int (Int64) 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.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 -> Response finishRequest reqHttp headers = let !key = getRequestHeader reqHttp "Sec-WebSocket-Key" !hash = hashKey key !encoded = B64.encode hash in response101 (("Sec-WebSocket-Accept", encoded):headers) "" -------------------------------------------------------------------------------- finishResponse :: RequestHead -> ResponseHead -> Response finishResponse request response -- Response message should be one of -- -- - WebSocket Protocol Handshake -- - Switching Protocols -- -- But we don't check it for now | responseCode response /= 101 = throw $ MalformedResponse response "Wrong response status or message." | responseHash /= challengeHash = throw $ MalformedResponse response "Challenge and response hashes do not match." | otherwise = Response response "" where key = getRequestHeader request "Sec-WebSocket-Key" responseHash = getResponseHeader response "Sec-WebSocket-Accept" challengeHash = B64.encode $ hashKey key -------------------------------------------------------------------------------- encodeMessage :: RandomGen g => ConnectionType -> g -> Message -> (g, B.Builder) encodeMessage conType gen msg = (gen', builder `mappend` B.flush) where mkFrame = Frame True False False False (mask, gen') = case conType of ServerConnection -> (Nothing, gen) ClientConnection -> randomMask gen builder = encodeFrame mask $ case msg of (ControlMessage (Close code pl)) -> mkFrame CloseFrame $ runPut (putWord16be code) `mappend` pl (ControlMessage (Ping pl)) -> mkFrame PingFrame pl (ControlMessage (Pong pl)) -> mkFrame PongFrame pl (DataMessage (Text pl)) -> mkFrame TextFrame pl (DataMessage (Binary pl)) -> mkFrame BinaryFrame pl -------------------------------------------------------------------------------- encodeMessages :: ConnectionType -> Stream -> IO (Message -> IO ()) encodeMessages conType stream = do genRef <- newIORef =<< newStdGen return $ \msg -> do builder <- atomicModifyIORef genRef $ \s -> encodeMessage conType s msg Stream.write stream (B.toLazyByteString builder) -------------------------------------------------------------------------------- encodeFrame :: Mask -> Frame -> B.Builder encodeFrame mask f = B.fromWord8 byte0 `mappend` B.fromWord8 byte1 `mappend` len `mappend` maskbytes `mappend` B.fromLazyByteString (maskPayload mask (framePayload f)) where byte0 = fin .|. rsv1 .|. rsv2 .|. rsv3 .|. opcode fin = if frameFin f then 0x80 else 0x00 rsv1 = if frameRsv1 f then 0x40 else 0x00 rsv2 = if frameRsv2 f then 0x20 else 0x00 rsv3 = if frameRsv3 f then 0x10 else 0x00 opcode = case frameType f of ContinuationFrame -> 0x00 TextFrame -> 0x01 BinaryFrame -> 0x02 CloseFrame -> 0x08 PingFrame -> 0x09 PongFrame -> 0x0a (maskflag, maskbytes) = case mask of Nothing -> (0x00, mempty) Just m -> (0x80, B.fromByteString m) byte1 = maskflag .|. lenflag len' = BL.length (framePayload f) (lenflag, len) | len' < 126 = (fromIntegral len', mempty) | len' < 0x10000 = (126, B.fromWord16be (fromIntegral len')) | otherwise = (127, B.fromWord64be (fromIntegral len')) -------------------------------------------------------------------------------- decodeMessages :: Stream -> IO (IO (Maybe Message)) decodeMessages stream = do dmRef <- newIORef emptyDemultiplexState return $ go dmRef where go dmRef = do mbFrame <- Stream.parse stream parseFrame case mbFrame of Nothing -> return Nothing Just frame -> do mbMsg <- atomicModifyIORef dmRef $ \s -> swap $ demultiplex s frame case mbMsg of Nothing -> go dmRef Just msg -> return (Just msg) -------------------------------------------------------------------------------- -- | Parse a frame parseFrame :: A.Parser Frame parseFrame = do byte0 <- A.anyWord8 let fin = byte0 .&. 0x80 == 0x80 rsv1 = byte0 .&. 0x40 == 0x40 rsv2 = byte0 .&. 0x20 == 0x20 rsv3 = byte0 .&. 0x10 == 0x10 opcode = byte0 .&. 0x0f ft <- case opcode of 0x00 -> return ContinuationFrame 0x01 -> return TextFrame 0x02 -> return BinaryFrame 0x08 -> return CloseFrame 0x09 -> return PingFrame 0x0a -> return PongFrame _ -> fail $ "Unknown opcode: " ++ show opcode byte1 <- A.anyWord8 let mask = byte1 .&. 0x80 == 0x80 lenflag = fromIntegral (byte1 .&. 0x7f) len <- case lenflag of 126 -> fromIntegral . runGet' getWord16be <$> A.take 2 127 -> fromIntegral . runGet' getWord64be <$> A.take 8 _ -> return lenflag masker <- maskPayload <$> if mask then Just <$> A.take 4 else pure Nothing chunks <- take64 len return $ Frame fin rsv1 rsv2 rsv3 ft (masker $ BL.fromChunks chunks) where runGet' g = runGet g . BL.fromChunks . return take64 :: Int64 -> A.Parser [ByteString] take64 n | n <= 0 = return [] | otherwise = do let n' = min intMax n chunk <- A.take (fromIntegral n') (chunk :) <$> take64 (n - n') where intMax :: Int64 intMax = fromIntegral (maxBound :: Int) -------------------------------------------------------------------------------- hashKey :: ByteString -> ByteString hashKey key = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid where guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" lazy = BL.fromChunks . return unlazy = mconcat . BL.toChunks -------------------------------------------------------------------------------- createRequest :: ByteString -> ByteString -> Bool -> Headers -> IO RequestHead createRequest hostname path secure customHeaders = do key <- B64.encode `liftM` getEntropy 16 return $ RequestHead path (headers key ++ customHeaders) secure where headers key = [ ("Host" , hostname ) , ("Connection" , "Upgrade" ) , ("Upgrade" , "websocket" ) , ("Sec-WebSocket-Key" , key ) , ("Sec-WebSocket-Version" , versionNumber) ] versionNumber = head headerVersions websockets-0.9.7.0/src/Network/WebSockets/Stream.hs0000644000000000000000000001405512745136007020316 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Lightweight abstraction over an input/output stream. {-# LANGUAGE CPP #-} module Network.WebSockets.Stream ( Stream , makeStream , makeSocketStream , makeEchoStream , parse , write , close ) where import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar, withMVar) import Control.Exception (onException, throwIO) import Control.Monad (forM_, when) import qualified Data.Attoparsec.ByteString as Atto 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, ()) assertNotClosed :: IORef StreamState -> IO a -> IO a assertNotClosed ref io = do state <- readIORef ref case state of Closed _ -> throwIO ConnectionClosed Open _ -> io receive' :: IORef StreamState -> MVar () -> IO (Maybe B.ByteString) receive' ref lock = withMVar lock $ \() -> assertNotClosed ref $ do 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 $ \() -> assertNotClosed ref $ do when (mbBs == Nothing) (closeRef ref) onException (send mbBs) (closeRef ref) -------------------------------------------------------------------------------- makeSocketStream :: S.Socket -> IO Stream makeSocketStream socket = makeStream receive send where receive = do bs <- SB.recv socket 1024 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) -------------------------------------------------------------------------------- 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.9.7.0/src/Network/WebSockets/Protocol.hs0000644000000000000000000000531412745136007020662 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.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 -> Response finishRequest Hybi13 = Hybi13.finishRequest -------------------------------------------------------------------------------- finishResponse :: Protocol -> RequestHead -> ResponseHead -> Response finishResponse Hybi13 = Hybi13.finishResponse -------------------------------------------------------------------------------- encodeMessages :: Protocol -> ConnectionType -> Stream -> IO (Message -> IO ()) encodeMessages Hybi13 = Hybi13.encodeMessages -------------------------------------------------------------------------------- decodeMessages :: Protocol -> Stream -> IO (IO (Maybe Message)) decodeMessages Hybi13 = Hybi13.decodeMessages -------------------------------------------------------------------------------- createRequest :: Protocol -> B.ByteString -> B.ByteString -> Bool -> Headers -> IO RequestHead createRequest Hybi13 = Hybi13.createRequest websockets-0.9.7.0/src/Network/WebSockets/Types.hs0000644000000000000000000001127412745136007020167 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Primary types {-# LANGUAGE DeriveDataTypeable #-} module Network.WebSockets.Types ( Message (..) , ControlMessage (..) , DataMessage (..) , WebSocketsData (..) , HandshakeException (..) , ConnectionException (..) , ConnectionType (..) ) where -------------------------------------------------------------------------------- import Control.Exception (Exception (..)) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Data.Typeable (Typeable) import Data.Word (Word16) -------------------------------------------------------------------------------- import Network.WebSockets.Http -------------------------------------------------------------------------------- -- | The kind of message a server application typically deals with data Message = ControlMessage ControlMessage | DataMessage DataMessage deriving (Eq, Show) -------------------------------------------------------------------------------- -- | Different control messages data ControlMessage = Close 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. data DataMessage = Text BL.ByteString | Binary BL.ByteString deriving (Eq, Show) -------------------------------------------------------------------------------- -- | In order to have an even more high-level API, we define a typeclass for -- values the user can receive from and send to the socket. A few warnings -- apply: -- -- * Natively, everything is represented as a 'BL.ByteString', so this is the -- fastest instance -- -- * You should only use the 'TL.Text' or the 'T.Text' instance when you are -- sure that the data is UTF-8 encoded (which is the case for 'Text' -- messages). -- -- * Messages can be very large. If this is the case, it might be inefficient to -- use the strict 'B.ByteString' and 'T.Text' instances. class WebSocketsData a where fromLazyByteString :: BL.ByteString -> a toLazyByteString :: a -> BL.ByteString -------------------------------------------------------------------------------- instance WebSocketsData BL.ByteString where fromLazyByteString = id toLazyByteString = id -------------------------------------------------------------------------------- instance WebSocketsData B.ByteString where fromLazyByteString = B.concat . BL.toChunks toLazyByteString = BL.fromChunks . return -------------------------------------------------------------------------------- instance WebSocketsData TL.Text where fromLazyByteString = TL.decodeUtf8 toLazyByteString = TL.encodeUtf8 -------------------------------------------------------------------------------- instance WebSocketsData T.Text where fromLazyByteString = T.concat . TL.toChunks . fromLazyByteString toLazyByteString = toLazyByteString . TL.fromChunks . return -------------------------------------------------------------------------------- -- | 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 deriving (Show, Typeable) -------------------------------------------------------------------------------- instance Exception ConnectionException -------------------------------------------------------------------------------- data ConnectionType = ServerConnection | ClientConnection deriving (Eq, Ord, Show) websockets-0.9.7.0/src/Network/WebSockets/Connection.hs0000644000000000000000000002547512745136007021172 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 , acceptRequestWith , rejectRequest , Connection (..) , ConnectionOptions (..) , defaultConnectionOptions , receive , receiveDataMessage , receiveData , send , sendDataMessage , sendTextData , sendBinaryData , sendClose , sendCloseCode , sendPing , forkPingThread ) where -------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as Builder import Control.Concurrent (forkIO, threadDelay) import Control.Exception (AsyncException, fromException, handle, throwIO) import Control.Monad (unless) import qualified Data.ByteString as B import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.List (find) import qualified Data.Text as T import Data.Word (Word16) -------------------------------------------------------------------------------- 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 } -------------------------------------------------------------------------------- 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. } -------------------------------------------------------------------------------- -- | Utility sendResponse :: PendingConnection -> Response -> IO () sendResponse pc rsp = Stream.write (pendingStream pc) (Builder.toLazyByteString (encodeResponse rsp)) -------------------------------------------------------------------------------- acceptRequest :: PendingConnection -> IO Connection acceptRequest pc = acceptRequestWith pc $ AcceptRequest Nothing -------------------------------------------------------------------------------- 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 let subproto = maybe [] (\p -> [("Sec-WebSocket-Protocol", p)]) $ acceptSubprotocol ar response = finishRequest protocol request subproto sendResponse pc response parse <- decodeMessages protocol (pendingStream pc) write <- encodeMessages protocol ServerConnection (pendingStream pc) sentRef <- newIORef False let connection = Connection { connectionOptions = pendingOptions pc , connectionType = ServerConnection , connectionProtocol = protocol , connectionParse = parse , connectionWrite = write , connectionSentClose = sentRef } pendingOnAccept pc connection return connection where request = pendingRequest pc versionHeader = [("Sec-WebSocket-Version", B.intercalate ", " $ concatMap headerVersions protocols)] -------------------------------------------------------------------------------- rejectRequest :: PendingConnection -> B.ByteString -> IO () rejectRequest pc message = sendResponse pc $ response400 [] message -------------------------------------------------------------------------------- data Connection = Connection { connectionOptions :: !ConnectionOptions , connectionType :: !ConnectionType , connectionProtocol :: !Protocol , 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. } -------------------------------------------------------------------------------- -- | Set options for a 'Connection'. 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. } -------------------------------------------------------------------------------- defaultConnectionOptions :: ConnectionOptions defaultConnectionOptions = ConnectionOptions { connectionOnPong = return () } -------------------------------------------------------------------------------- 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 = do dm <- receiveDataMessage conn case dm of Text x -> return (fromLazyByteString x) Binary x -> return (fromLazyByteString x) -------------------------------------------------------------------------------- send :: Connection -> Message -> IO () send conn msg = do case msg of (ControlMessage (Close _ _)) -> writeIORef (connectionSentClose conn) True _ -> return () connectionWrite conn msg -------------------------------------------------------------------------------- -- | Send a 'DataMessage' sendDataMessage :: Connection -> DataMessage -> IO () sendDataMessage conn = send conn . DataMessage -------------------------------------------------------------------------------- -- | Send a message as text sendTextData :: WebSocketsData a => Connection -> a -> IO () sendTextData conn = sendDataMessage conn . Text . toLazyByteString -------------------------------------------------------------------------------- -- | Send a message as binary data sendBinaryData :: WebSocketsData a => Connection -> a -> IO () sendBinaryData conn = sendDataMessage conn . Binary . toLazyByteString -------------------------------------------------------------------------------- -- | Send a friendly close message. 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. 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.9.7.0/src/Network/WebSockets/Http.hs0000644000000000000000000002174512745136007020006 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 ) where -------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as Builder import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder import Control.Applicative (pure, (*>), (<$>), (<*), (<*>)) import Control.Exception (Exception, throw) import 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) -------------------------------------------------------------------------------- -- | 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.copyByteString "GET " `mappend` Builder.copyByteString path `mappend` Builder.copyByteString " HTTP/1.1" `mappend` Builder.fromByteString "\r\n" `mappend` mconcat (map header headers) `mappend` Builder.copyByteString "\r\n" where header (k, v) = mconcat $ map Builder.copyByteString [CI.original k, ": ", v, "\r\n"] -------------------------------------------------------------------------------- encodeRequest :: Request -> Builder.Builder encodeRequest (Request head' body) = encodeRequestHead head' `mappend` Builder.copyByteString body -------------------------------------------------------------------------------- -- | Parse an initial request decodeRequestHead :: Bool -> A.Parser RequestHead decodeRequestHead isSecure = RequestHead <$> requestLine <*> A.manyTill decodeHeaderLine newline <*> pure isSecure where space = A.word8 (c2w ' ') newline = A.string "\r\n" requestLine = A.string "GET" *> space *> A.takeWhile1 (/= c2w ' ') <* space <* A.string "HTTP/1.1" <* newline -------------------------------------------------------------------------------- -- | Encode an HTTP upgrade response encodeResponseHead :: ResponseHead -> Builder.Builder encodeResponseHead (ResponseHead code msg headers) = Builder.copyByteString "HTTP/1.1 " `mappend` Builder.fromString (show code) `mappend` Builder.fromChar ' ' `mappend` Builder.fromByteString msg `mappend` Builder.fromByteString "\r\n" `mappend` mconcat (map header headers) `mappend` Builder.copyByteString "\r\n" where header (k, v) = mconcat $ map Builder.copyByteString [CI.original k, ": ", v, "\r\n"] -------------------------------------------------------------------------------- encodeResponse :: Response -> Builder.Builder encodeResponse (Response head' body) = encodeResponseHead head' `mappend` Builder.copyByteString body -------------------------------------------------------------------------------- -- | An upgrade response response101 :: Headers -> B.ByteString -> Response response101 headers = Response (ResponseHead 101 "WebSocket Protocol Handshake" (("Upgrade", "websocket") : ("Connection", "Upgrade") : headers)) -------------------------------------------------------------------------------- -- | Bad request response400 :: Headers -> B.ByteString -> Response response400 headers = Response (ResponseHead 400 "Bad Request" headers) -------------------------------------------------------------------------------- -- | HTTP response parser decodeResponseHead :: A.Parser ResponseHead decodeResponseHead = ResponseHead <$> fmap (read . BC.unpack) code <*> message <*> A.manyTill decodeHeaderLine newline where space = A.word8 (c2w ' ') newline = A.string "\r\n" code = A.string "HTTP/1.1" *> space *> A.takeWhile1 (/= c2w ' ') <* space message = A.takeWhile1 (/= c2w '\r') <* newline -------------------------------------------------------------------------------- decodeResponse :: A.Parser Response decodeResponse = Response <$> decodeResponseHead <*> A.takeByteString -------------------------------------------------------------------------------- getRequestHeader :: RequestHead -> CI.CI ByteString -> ByteString getRequestHeader rq key = case lookup key (requestHeaders rq) of Just t -> t Nothing -> throw $ MalformedRequest rq $ "Header missing: " ++ BC.unpack (CI.original key) -------------------------------------------------------------------------------- getResponseHeader :: ResponseHead -> CI.CI ByteString -> ByteString getResponseHeader rsp key = case lookup key (responseHeaders rsp) of Just t -> t Nothing -> throw $ MalformedResponse rsp $ "Header missing: " ++ BC.unpack (CI.original key) -------------------------------------------------------------------------------- -- | Get the @Sec-WebSocket-Version@ header getRequestSecWebSocketVersion :: RequestHead -> Maybe B.ByteString getRequestSecWebSocketVersion p = lookup "Sec-WebSocket-Version" (requestHeaders p) -------------------------------------------------------------------------------- -- | 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 == ' ') -------------------------------------------------------------------------------- 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.9.7.0/src/Network/WebSockets/Server.hs0000644000000000000000000001151612745136007020330 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 standalone applications, for real -- applications, you should use a real server. -- -- 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.sClose (\sock -> mask_ $ forever $ do allowInterrupt (conn, _) <- S.accept sock void $ forkIOWithUnmask $ \unmask -> finally (unmask $ runApp conn opts app) (S.sClose 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 = bracketOnError (S.socket S.AF_INET S.Stream S.defaultProtocol) S.sClose (\sock -> do _ <- S.setSocketOption sock S.ReuseAddr 1 _ <- S.setSocketOption sock S.NoDelay 1 host' <- S.inet_addr host S.bindSocket sock (S.SockAddrInet (fromIntegral port) host') S.listen sock 5 return sock ) -------------------------------------------------------------------------------- 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.9.7.0/src/Network/WebSockets/Client.hs0000644000000000000000000001210212745136007020270 0ustar0000000000000000-------------------------------------------------------------------------------- -- | This part of the library provides you with utilities to create WebSockets -- clients (in addition to servers). module Network.WebSockets.Client ( ClientApp , runClient , runClientWith , runClientWithSocket , runClientWithStream ) where -------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as Builder import Control.Exception (bracket, finally, throwIO) 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 path opts customHeaders app = do -- Create and connect socket let hints = S.defaultHints {S.addrFamily = S.AF_INET, S.addrSocketType = S.Stream} fullHost = if port == 80 then host else (host ++ ":" ++ show port) addrInfos <- S.getAddrInfo (Just hints) (Just host) (Just $ show port) sock <- S.socket S.AF_INET S.Stream S.defaultProtocol S.setSocketOption sock S.NoDelay 1 -- Connect WebSocket and run client res <- finally (S.connect sock (S.addrAddress $ head addrInfos) >> runClientWithSocket sock fullHost path opts customHeaders app) (S.sClose 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 -- 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.runClientWithStream: no handshake " ++ "response from server" -- Note that we pattern match to evaluate the result here Response _ _ <- return $ finishResponse protocol request response parse <- decodeMessages protocol stream write <- encodeMessages protocol ClientConnection stream sentRef <- newIORef False app 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.9.7.0/src/Network/WebSockets/Hybi13/0000755000000000000000000000000012745136007017561 5ustar0000000000000000websockets-0.9.7.0/src/Network/WebSockets/Hybi13/Mask.hs0000644000000000000000000000314012745136007021006 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Masking of fragmes using a simple XOR algorithm {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.WebSockets.Hybi13.Mask ( Mask , maskPayload , randomMask ) where -------------------------------------------------------------------------------- import Data.Bits (shiftR, xor) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import System.Random (RandomGen, random) -------------------------------------------------------------------------------- -- | ByteString should be exactly 4 bytes long type Mask = Maybe B.ByteString -------------------------------------------------------------------------------- -- | Apply mask maskPayload :: Mask -> BL.ByteString -> BL.ByteString maskPayload Nothing = id maskPayload (Just mask) = snd . BL.mapAccumL f 0 where len = B.length mask f !i !c = let i' = (i + 1) `mod` len m = mask `B.index` i in (i', m `xor` c) -------------------------------------------------------------------------------- -- | Create a random mask randomMask :: forall g. RandomGen g => g -> (Mask, g) randomMask gen = (Just (B.pack [b1, b2, b3, b4]), gen') where (!int, !gen') = random gen :: (Int, g) !b1 = fromIntegral $ int `mod` 0x100 !b2 = fromIntegral $ int `shiftR` 8 `mod` 0x100 !b3 = fromIntegral $ int `shiftR` 16 `mod` 0x100 !b4 = fromIntegral $ int `shiftR` 24 `mod` 0x100 websockets-0.9.7.0/src/Network/WebSockets/Hybi13/Demultiplex.hs0000644000000000000000000001100412745136007022405 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Demultiplexing of frames into messages {-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} module Network.WebSockets.Hybi13.Demultiplex ( FrameType (..) , Frame (..) , DemultiplexState , emptyDemultiplexState , demultiplex ) where -------------------------------------------------------------------------------- import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder as B import Control.Exception (Exception, throw) import Data.Binary.Get (runGet, getWord16be) import qualified Data.ByteString.Lazy as BL import Data.Monoid (mappend) import Data.Typeable (Typeable) -------------------------------------------------------------------------------- import Network.WebSockets.Types -------------------------------------------------------------------------------- -- | A low-level representation of a WebSocket packet data Frame = Frame { frameFin :: !Bool , frameRsv1 :: !Bool , frameRsv2 :: !Bool , frameRsv3 :: !Bool , frameType :: !FrameType , framePayload :: !BL.ByteString } deriving (Eq, Show) -------------------------------------------------------------------------------- -- | The type of a frame. Not all types are allowed for all protocols. data FrameType = ContinuationFrame | TextFrame | BinaryFrame | CloseFrame | PingFrame | PongFrame deriving (Eq, Show) -------------------------------------------------------------------------------- -- | Thrown if the client sends invalid multiplexed data data DemultiplexException = DemultiplexException deriving (Show, Typeable) -------------------------------------------------------------------------------- instance Exception DemultiplexException -------------------------------------------------------------------------------- -- | Internal state used by the demultiplexer data DemultiplexState = EmptyDemultiplexState | DemultiplexState !FrameType !Builder -------------------------------------------------------------------------------- emptyDemultiplexState :: DemultiplexState emptyDemultiplexState = EmptyDemultiplexState -------------------------------------------------------------------------------- demultiplex :: DemultiplexState -> Frame -> (Maybe Message, DemultiplexState) demultiplex state (Frame fin _ _ _ tp pl) = case tp of -- Return control messages immediately, they have no influence on the state CloseFrame -> (Just (ControlMessage (uncurry Close parsedClose)), state) PingFrame -> (Just (ControlMessage (Ping pl)), state) PongFrame -> (Just (ControlMessage (Pong pl)), state) -- If we're dealing with a continuation... ContinuationFrame -> case state of -- We received a continuation but we don't have any state. Let's ignore -- this fragment... EmptyDemultiplexState -> (Nothing, EmptyDemultiplexState) -- Append the payload to the state -- TODO: protect against overflows DemultiplexState amt b | not fin -> (Nothing, DemultiplexState amt b') | otherwise -> case amt of TextFrame -> (Just (DataMessage (Text m)), e) BinaryFrame -> (Just (DataMessage (Binary m)), e) _ -> throw DemultiplexException where b' = b `mappend` plb m = B.toLazyByteString b' TextFrame | fin -> (Just (DataMessage (Text pl)), e) | otherwise -> (Nothing, DemultiplexState TextFrame plb) BinaryFrame | fin -> (Just (DataMessage (Binary pl)), e) | otherwise -> (Nothing, DemultiplexState BinaryFrame plb) where e = emptyDemultiplexState plb = B.fromLazyByteString pl -- 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 = (runGet getWord16be pl, BL.drop 2 pl) | otherwise = (1000, BL.empty)