diff --git a/Network/Websocket.hs b/Network/Websocket.hs --- a/Network/Websocket.hs +++ b/Network/Websocket.hs @@ -1,28 +1,54 @@ +{-# LANGUAGE ScopedTypeVariables #-} + -- | Library for creating Websocket servers. Some parts cribbed from -- Jeff Foster's blog post at -- -module Network.Websocket( Config(..), WS(..), startServer, send) where +module Network.Websocket( Config(..), ConfigRestriction(..), WS(..), + startServer, send ) where - import Char + import Char (chr) import Control.Concurrent - import Control.Monad (forever) + import Control.Exception hiding (catch) + import Control.Monad + import Data.Char (isSpace) + import Data.Maybe import qualified Network as N import qualified Network.Socket as NS + import Network.Web.HTTP + import Network.URI + import Network.Web.Server import System.IO + trim = f . f + where f = reverse.dropWhile isSpace + whenM b f = b >>= \b' -> when b' f + + instance Show Request where + show req = let method = show $ reqMethod req + uri = show $ reqURI req + fields = show $ reqFields req + in method ++ " " ++ uri ++ "\n" ++ fields + + data ConfigRestriction = Any | Only [String] + restrictionValid x Any = True + restrictionValid x (Only xs) = elem x xs + + instance Eq Status + + -- | Server configuration structure data Config = Config { -- | The port to bind to configPort :: Int, -- | The origin URL used in the handshake - configOrigin :: String, + configOrigins :: ConfigRestriction, -- |The location URL used in the handshake. This must match -- the Websocket url that the browsers connect to. - configLocation :: String, + configDomains :: ConfigRestriction, -- | The onopen callback, called when a socket is opened configOnOpen :: WS -> IO (), @@ -35,28 +61,35 @@ } -- | Connection state structure - data WS = WS { + data WS = WS { -- | The server's configuration - config :: Config, + wsConfig :: Config, -- | The handle of the connected socket - handle :: Handle + wsHandle :: Handle } - - -- |Calls the server's onopen callback, then start reading - -- |messages. When the connection is terminated, the server's - -- |onclose callback is called. + + + + + -- | Calls the server's onopen callback, then start reading + -- messages. When the connection is terminated, the server's + -- onclose callback is called. listenLoop ws = do onopen ws - + (forever $ do msg <- readFrame h - onmessage ws msg) `catch` (\e -> onclose ws) + onmessage ws msg) + `catch` + (\e -> onclose ws) - where c = config ws - h = handle ws + return () - onopen = configOnOpen c + where c = wsConfig ws + h = wsHandle ws + + onopen = configOnOpen c onmessage = configOnMessage c onclose = configOnClose c @@ -73,27 +106,68 @@ sendFrame :: Handle -> String -> IO () sendFrame h s = do + putStrLn $ "Sending message: " ++ s hPutChar h (chr 0) - hPutStr h s + hPutStr h s hPutChar h (chr 255) + hFlush h -- | Send a message to the connected browser. - send ws = sendFrame (handle ws) + send ws = sendFrame (wsHandle ws) - accept config socket = - forever $ do - (h, _, _) <- N.accept socket - hPutStr h handshake - hSetBuffering h NoBuffering - let ws = WS { config = config, handle = h } - forkIO $ listenLoop ws + parseRequest req = do + upgrade <- lookupField (FkOther "Upgrade") req + origin <- lookupField (FkOther "Origin") req + host <- lookupField FkHost req + hostURI <- parseURI ("ws://" ++ host ++ "/") + hostAuth <- uriAuthority hostURI + let domain = uriRegName hostAuth + return (upgrade, origin, domain) + + doWebSocket socket f = + bracket (do (h :: Handle, _, _) <- N.accept socket + maybeReq <- receive h + return (h, maybeReq)) + + (\(h,_) -> hClose h) + + (\(h, maybeReq) -> + case maybeReq of + Nothing -> putStrLn "Got bad request" + Just req -> f h req) + + sendHandshake h origin location = hPutStr h handshake >> hFlush h where handshake = "HTTP/1.1 101 Web Socket Protocol Handshake\r\n\ \Upgrade: WebSocket\r\n\ \Connection: Upgrade\r\n\ - \WebSocket-Origin: " ++ (configOrigin config) ++ "\r\n\ - \WebSocket-Location: "++ (configLocation config) ++ "\r\n\ + \WebSocket-Origin: " ++ origin ++ "\r\n\ + \WebSocket-Location: "++ show location ++ "\r\n\ \WebSocket-Protocol: sample\r\n\r\n" + + + accept config socket = + forever $ doWebSocket socket $ \h req -> + do let (upgrade, origin, hostDomain) = case parseRequest req of + Nothing -> throw (userError "Invalid request") + Just a -> a + location = (reqURI req) { uriScheme = "ws:" } + ws = WS { wsConfig = config, wsHandle = h } + + return $ assert (upgrade == "WebSocket") () + return $ assert (restrictionValid origin (configOrigins config)) () + return $ assert (restrictionValid hostDomain (configDomains config)) () + + sendHandshake h origin location + + onOpen ws + (forever $ do msg <- readFrame h + onMessage ws msg) `catch` (\e -> onClose ws) + + where onOpen = configOnOpen config + onMessage = configOnMessage config + onClose = configOnClose config + -- | Start a websocket server startServer config = diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs diff --git a/examples/echo.hs b/examples/echo.hs new file mode 100644 --- /dev/null +++ b/examples/echo.hs @@ -0,0 +1,25 @@ + +import Network +import qualified Network.Websocket as WS + +config = WS.Config { + WS.configPort = 9876, + WS.configOrigins = WS.Any, + WS.configDomains = WS.Any, + WS.configOnOpen = onOpen, + WS.configOnMessage = onMessage, + WS.configOnClose = onClose + } + +main = withSocketsDo $ WS.startServer config + + +onOpen ws = do + putStrLn "Connection opened" + +onMessage ws msg = do + putStrLn $ "Received message: " ++ msg + WS.send ws msg + +onClose ws = do + putStrLn "Connection closed" diff --git a/network-websocket.cabal b/network-websocket.cabal --- a/network-websocket.cabal +++ b/network-websocket.cabal @@ -1,15 +1,32 @@ -Name: network-websocket -Synopsis: WebSocket library -Version: 0.1 -Cabal-Version: >= 1.2 -License: BSD3 -License-File: LICENSE -Author: Michael Melanson -Maintainer: Michael Melanson -Category: Network -Build-Type: Simple +Name: network-websocket +Version: 0.2 +Stability: experimental +Synopsis: WebSocket library +Description: A library for creating Websocket servers +Copyright: (c) Michael Melanson, 2010 +License: BSD3 +License-file: LICENSE +Homepage: http://github.com/michaelmelanson/network-websocket +Author: Michael Melanson +Maintainer: Michael Melanson +Category: Network +Cabal-version: >=1.2 +Build-type: Simple +Tested-with: GHC ==6.10 +Flag BuildExamples + Description: Build the example programs + Default: False + + Library - Build-Depends: base >= 2 && < 4, network, haskell98 - Exposed-Modules: Network.Websocket + Exposed-Modules: Network.Websocket + Build-depends: base >=2 && <4, haskell98 -any, network -any, + webserver -any + +Executable websocket-echo + Main-is: examples/echo.hs + + if !flag(buildexamples) + Buildable: False