websockets 0.9.5.0 → 0.9.6.0
raw patch · 5 files changed
+196/−6 lines, 5 filesdep +websocketsdep −mtldep ~HUnitdep ~QuickCheckdep ~basenew-component:exe:websockets-example
Dependencies added: websockets
Dependencies removed: mtl
Dependency ranges changed: HUnit, QuickCheck, base
Files
- CHANGELOG +8/−0
- example/server.lhs +151/−0
- src/Network/WebSockets/Client.hs +3/−1
- src/Network/WebSockets/Server.hs +1/−0
- websockets.cabal +33/−5
CHANGELOG view
@@ -1,3 +1,11 @@+- 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
+ example/server.lhs view
@@ -0,0 +1,151 @@+websockets 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 exception 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)
src/Network/WebSockets/Client.hs view
@@ -57,13 +57,15 @@ -- 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 host path opts customHeaders app)+ runClientWithSocket sock fullHost path opts customHeaders app) (S.sClose sock) -- Clean up
src/Network/WebSockets/Server.hs view
@@ -72,6 +72,7 @@ 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
websockets.cabal view
@@ -1,5 +1,5 @@ Name: websockets-Version: 0.9.5.0+Version: 0.9.6.0 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell.@@ -43,6 +43,11 @@ Extra-source-files: CHANGELOG +Flag Example+ Description: Build the example server+ Default: False+ Manual: True+ Library Hs-source-dirs: src Ghc-options: -Wall@@ -72,7 +77,6 @@ bytestring >= 0.9 && < 0.11, case-insensitive >= 0.3 && < 1.3, containers >= 0.3 && < 0.6,- mtl >= 2.0 && < 2.3, network >= 2.3 && < 2.7, random >= 1.0 && < 1.2, SHA >= 1.5 && < 1.7,@@ -93,8 +97,8 @@ Network.WebSockets.Tests.Util Build-depends:- HUnit >= 1.2 && < 1.3,- QuickCheck >= 2.4 && < 2.9,+ HUnit >= 1.2 && < 1.4,+ QuickCheck >= 2.7 && < 2.9, test-framework >= 0.4 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, test-framework-quickcheck2 >= 0.2 && < 0.4,@@ -107,7 +111,31 @@ bytestring >= 0.9 && < 0.11, case-insensitive >= 0.3 && < 1.3, containers >= 0.3 && < 0.6,- mtl >= 2.0 && < 2.3,+ 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.8,+ 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,