websockets (empty) → 0.1.1.2
raw patch · 4 files changed
+286/−0 lines, 4 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, containers, network, pureMD5
Files
- LICENCE +30/−0
- Network/WebSockets.hs +224/−0
- Setup.hs +2/−0
- websockets.cabal +30/−0
+ LICENCE view
@@ -0,0 +1,30 @@+Copyright Siniša Biđin, 2010++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.
+ Network/WebSockets.hs view
@@ -0,0 +1,224 @@+{- | A library for creating WebSocket-capable servers, where the implemented protocol is defined here: <http://is.gd/eSdLB>.++This library was only tested with Chromium 7.* and Firefox 4.*, currently doesn't implement the entire WebSocket protocol, will never implement older versions of the WebSocket protocol and is a work in progress.++How do you use this library? Here's how:++* Get a 'Handle' to your connected client.++* Perform the initial handshake with 'shakeHands' (or 'getRequest' and 'putResponse').++* Send and receive strict bytestrings with 'putFrame' and 'getFrame'.++And here's a short, complete example of a server that accepts clients, greets them with a welcome message and replies to all messages by echoing them back with an appended meow:++@+import Network.WebSockets ('shakeHands', 'getFrame', 'putFrame')+import Network (listenOn, PortID(PortNumber), accept, withSocketsDo)+import System.IO (Handle, hClose)+import Data.ByteString (append)+import Data.ByteString.UTF8 (fromString) -- this is from utf8-string+import Control.Monad (forever)+import Control.Concurrent (forkIO)++main :: IO ()+main = withSocketsDo $ do+ socket <- listenOn $ PortNumber 12345+ putStrLn \"Listening on 0.0.0.0:12345.\"+ forever $ do+ (h, _, _) <- accept socket+ forkIO $ talkToClient h++talkToClient :: Handle -> IO ()+talkToClient h = do+ request <- 'shakeHands' h+ case request of+ Left error -> putStrLn error >> hClose h+ Right req -> do+ 'putFrame' h . fromString $ \"滴水之恩当以涌泉相报\<br\>\" ++ show req+ forever $ do+ msg <- 'getFrame' h+ 'putFrame' h . append msg $ fromString \", MEOW!\"+@++The example above will suffice if you wish to accept any WebSocket-capable client, regardless of its origin or target. It won't suffice if you have to filter the incoming clients by the contents of their requests. For that, you can use 'getRequest' and 'putResponse', which allow you to inspect the request details /before/ you send back a response, if any.++If you have any suggestions, bug reports and\/or fixes, feel free to send them to <mailto:sinisa@bidin.cc>. -}+module Network.WebSockets (+ shakeHands, + getRequest, putResponse, + getFrame, putFrame, + reqHost, reqPath, reqOrigin, reqLocation,+ Request()) where+++import System.IO (Handle, hPutChar, hFlush, hGetChar, hPutStr, hGetLine)+import Data.Binary (encode)+import Data.Int (Int32)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Digest.Pure.MD5 (md5)+import Data.Char (isDigit, chr, ord)+import Data.List (isPrefixOf, isSuffixOf)+import qualified Control.Exception as E+import qualified Data.Map as M+++-- Quick and dirty String<->ByteString conversion.+fromString = B.pack . map (fromIntegral.ord)+toString = map (chr.fromIntegral) . B.unpack+++{- | Accept and perform a handshake, no matter the request contents.++As long as the request is well-formed, the client will receive a response saying, essentially, \"proceed\". Use this function if you don't care who you're connected to, as long as that someone speaks the WebSocket protocol.++The function returns either a String in case of error, or a 'Request' on success. The 'Request' is returned purely for logging purposes, since the handshake has already been executed. Use this function immediately after establishing the WebSocket connection.++If you wish not to blindly accept requests but to filter them according to their contents, use the 'getRequest' and 'putResponse' functions. -}+shakeHands :: Handle -> IO (Either String Request)+shakeHands h = do+ request <- getRequest h+ case request of+ Right req -> do putResponse h req+ return request+ otherwise -> do return request -- return error+ ++{- | Contains the request details, accessible via the 'reqHost', 'reqPath', 'reqOrigin' and 'reqLocation' functions. -}+data Request = Request {+ reqHost :: String, -- ^ Returns the requested host. + reqPath :: String, -- ^ Returns the requested path.+ reqOrigin :: String, -- ^ Returns the origin of the request.+ reqKey1, reqKey2, reqToken :: String+}++{- | Returns the requested location. Equal to @(\\r -> \"ws:\/\/\" ++ reqHost r ++ reqPath r)@. -}+reqLocation :: Request -> String+reqLocation r = "ws://" ++ reqHost r ++ reqPath r++instance Show Request where+ show r = "requested " ++ reqLocation r ++ " from " ++ reqOrigin r++{- Contains the client's request. The eight-byte token is under key \"Token\", while the requested path is under key \"Path\". Others are the same as in the request header: \"Origin\", \"Upgrade\" and \"Sec-WebSocket-Key2\", to name a few. -}+type RawRequest = M.Map String String+++{- | Reads the client's opening handshake and returns either a 'Request' based on its contents, or a String in case of an error. -}+getRequest :: Handle -> IO (Either String Request)+getRequest h = do+ -- the first line should be a "GET :path: HTTP/1.1 + first <- toString `fmap` B.hGetLine h+ if "GET " `isPrefixOf` first && " HTTP/1.1\r" `isSuffixOf` first+ then do (step . M.singleton "Path" $ words first !! 1)+ `E.catch` + (\e -> return.Left $ show (e :: E.SomeException))+ + else return.Left $ "First line is not a valid GET request: " ++ show first+ + where+ -- reads and stores all of the header values, stopping when+ -- it encounters an unrecognized header key, duplicate header keys+ -- or an empty line followed by the eight-byte token.+ step :: RawRequest -> IO (Either String Request)+ step req = do+ line <- toString `fmap` B.hGetLine h+ if null line+ then return.Left $ "Got empty line in header: " ++ show line+ else case break (==' ') (init line) of+ ("", "") -> do+ -- we skip this empty line and read the next 8 bytes, the token+ bytes <- (map (chr.fromIntegral) . BL.unpack) `fmap` BL.hGet h 8+ return . validateRequest $ M.insert "Token" bytes req+ (key, val) ->+ -- can we recognize the header key? raise an error if not.+ -- also, raise an error if duplicate header keys are read.+ if key `elem` ["Host:", "Connection:", "Sec-WebSocket-Key1:",+ "Sec-WebSocket-Key2:", "Upgrade:", "Origin:"]+ then case M.lookup (init key) req of+ Just _ -> return.Left $ "Duplicate key: " ++ show key+ Nothing -> step $ M.insert (init key) (tail val) req+ else return.Left $ "Unrecognized header key in line: " ++ show line+ + ++{- Checks if a given raw request is valid or not. A valid request won't cause a division by zero when calculating a response token and contains all the neccessary data to create a response. Returns either an error if the request is not valid, or a valid, final request. -}+validateRequest :: RawRequest -> Either String Request+validateRequest req + | lacksHeaderKeys = Left $ "Bad request, keys missing: " ++ show req+ | any faultyKey [1, 2] = Left $ "Faulty Sec-WebSocketKey: " ++ show req+ | otherwise = Right $ fromRaw req+ where+ lacksHeaderKeys = + any (flip M.notMember req) ["Host", "Path", "Origin", "Sec-WebSocket-Key1", + "Sec-WebSocket-Key2", "Token"]+ faultyKey n = + let key = req M.! ("Sec-WebSocket-Key" ++ show n)+ in length (filter (==' ') key) == 0+ + fromRaw :: RawRequest -> Request+ fromRaw r = Request { reqHost = r M.! "Host",+ reqPath = r M.! "Path",+ reqOrigin = r M.! "Origin",+ reqKey1 = r M.! "Sec-WebSocket-Key1",+ reqKey2 = r M.! "Sec-WebSocket-Key2",+ reqToken = r M.! "Token"+ }++ +{- | Sends an accepting response based on the given 'Request', thus accepting and ending the handshake. -}+putResponse :: Handle -> Request -> IO ()+putResponse h req = B.hPutStr h (createResponse req)+++{- Returns an accepting response based on the given 'Request'. -}+createResponse :: Request -> B.ByteString+createResponse req =+ let header =+ "HTTP/1.1 101 Web Socket Protocol Handshake\r\n\+ \Upgrade: WebSocket\r\n\+ \Connection: Upgrade\r\n\+ \Sec-WebSocket-Origin: " ++ + reqOrigin req ++ "\r\n\+ \Sec-WebSocket-Location: ws://" ++ + reqHost req ++ reqPath req ++ "\r\n\+ \Sec-WebSocket-Protocol: sample\r\n\r\n"+ in B.append (fromString header) (createToken req)++ +{- Constructs the response token by using the two security keys and eight-byte token, as defined by the protocol -}+createToken :: Request -> B.ByteString+createToken req =+ let encodeAsInt = encode . divNumBySpaces + [num1, num2] = map encodeAsInt [reqKey1 req, reqKey2 req]+ token = BL.pack . map (fromIntegral . ord) $ reqToken req+ hash = md5 $ BL.concat [num1, num2, token]+ in B.pack . BL.unpack $ encode hash+++{- Divides the number hiding in the string by the number of spaces in the string, as defined in the protocol. Assumes division by zero will not occur, since the request was verified to be valid beforehand. -}+divNumBySpaces :: String -> Int32+divNumBySpaces str =+ let number = read $ filter isDigit str :: Int+ spaces = length $ filter (==' ') str+ in fromIntegral $ number `div` spaces+++{- | Send a strict ByteString. Call this function only after having performed the handshake. -}+putFrame :: Handle -> B.ByteString -> IO ()+putFrame h bs = do+ B.hPutStr h . B.cons 0 $ B.snoc bs 255+ hFlush h+ ++{- | Receive a strict ByteString. Call this function only after having performed the handshake. This function will block until an entire frame is read. -}+getFrame :: Handle -> IO B.ByteString+getFrame h = do+ B.hGet h 1 -- assume this is 0+ readUntil255 B.empty+ where+ readUntil255 buf = do+ b <- ((!!0) . B.unpack) `fmap` B.hGet h 1+ case b of+ 255 -> return buf+ otherwise -> readUntil255 $ B.snoc buf b
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ websockets.cabal view
@@ -0,0 +1,30 @@+Name: websockets+Version: 0.1.1.2++Cabal-version: >=1.6++Synopsis: Implements the WebSocket protocol.++Description: Implements certain basics of the WebSocket protocol+ as defined at <http://is.gd/eSdLB>, allowing the+ creation of simple WebSocket-capable servers. Works+ with Handles and strict ByteStrings.++License: BSD3+License-file: LICENCE+Copyright: (c) 2010 Siniša Biđin++Author: Siniša Biđin+Maintainer: Siniša Biđin <sinisa@bidin.cc>+Bug-reports: mailto:sinisa@bidin.cc++Stability: experimental+Category: Network+Tested-with: GHC ==6.12++Build-type: Simple++Library+ Exposed-Modules: Network.WebSockets+ Build-depends: pureMD5 ==1.1.*, network ==2.2.*, base ==4.*, + bytestring ==0.9.*, binary ==0.5.*, containers ==0.3.*