websockets 0.6.0.4 → 0.7.0.0
raw patch · 13 files changed
+324/−77 lines, 13 filesdep +entropydep ~QuickCheckdep ~base64-bytestringdep ~bytestringPVP ok
version bump matches the API change (PVP)
Dependencies added: entropy
Dependency ranges changed: QuickCheck, base64-bytestring, bytestring
API changes (from Hackage documentation)
- Network.WebSockets: Response :: !Int -> !ByteString -> Headers -> ByteString -> Response
- Network.WebSockets: data Response
- Network.WebSockets: responseBody :: Response -> ByteString
- Network.WebSockets: responseCode :: Response -> !Int
- Network.WebSockets: responseHeaders :: Response -> Headers
- Network.WebSockets: responseMessage :: Response -> !ByteString
+ Network.WebSockets: MalformedResponse :: ResponseHttpPart -> String -> HandshakeError
+ Network.WebSockets: RequestBody :: RequestHttpPart -> ByteString -> RequestBody
+ Network.WebSockets: ResponseBody :: ResponseHttpPart -> ByteString -> ResponseBody
+ Network.WebSockets: ResponseHttpPart :: !Int -> !ByteString -> Headers -> ResponseHttpPart
+ Network.WebSockets: connect :: Protocol p => String -> Int -> String -> WebSockets p a -> IO a
+ Network.WebSockets: connectWith :: Protocol p => String -> Int -> String -> Maybe String -> Maybe [String] -> WebSockets p a -> IO a
+ Network.WebSockets: data RequestBody
+ Network.WebSockets: data ResponseBody
+ Network.WebSockets: data ResponseHttpPart
+ Network.WebSockets: responseHttpCode :: ResponseHttpPart -> !Int
+ Network.WebSockets: responseHttpHeaders :: ResponseHttpPart -> Headers
+ Network.WebSockets: responseHttpMessage :: ResponseHttpPart -> !ByteString
- Network.WebSockets: Request :: !ByteString -> Headers -> Response -> Request
+ Network.WebSockets: Request :: !ByteString -> Headers -> ResponseBody -> Request
- Network.WebSockets: requestResponse :: Request -> Response
+ Network.WebSockets: requestResponse :: Request -> ResponseBody
Files
- src/Network/WebSockets.hs +14/−5
- src/Network/WebSockets/Client.hs +84/−0
- src/Network/WebSockets/Handshake.hs +1/−1
- src/Network/WebSockets/Handshake/Http.hs +107/−25
- src/Network/WebSockets/Monad.hs +3/−1
- src/Network/WebSockets/Protocol.hs +16/−0
- src/Network/WebSockets/Protocol/Hybi00.hs +2/−0
- src/Network/WebSockets/Protocol/Hybi00/Internal.hs +12/−14
- src/Network/WebSockets/Protocol/Hybi10.hs +2/−0
- src/Network/WebSockets/Protocol/Hybi10/Internal.hs +69/−16
- src/Network/WebSockets/Socket.hs +2/−4
- src/Network/WebSockets/Types.hs +1/−3
- websockets.cabal +11/−8
src/Network/WebSockets.hs view
@@ -101,11 +101,15 @@ , I.runServer , I.runWithSocket - -- * Types+ -- * HTTP Types , I.Headers- , I.RequestHttpPart (..) , I.Request (..)- , I.Response (..)+ , I.RequestHttpPart (..)+ , I.RequestBody (..)+ , I.ResponseHttpPart (..)+ , I.ResponseBody (..)++ -- * WebSockets types , I.Message (..) , I.ControlMessage (..) , I.DataMessage (..)@@ -144,10 +148,15 @@ , I.catchWsError , I.HandshakeError(..) , I.ConnectionError(..)++ -- * WebSockets Client+ , I.connect+ , I.connectWith ) where import Control.Monad.Trans (liftIO) +import qualified Network.WebSockets.Client as I import qualified Network.WebSockets.Handshake as I import qualified Network.WebSockets.Handshake.Http as I import qualified Network.WebSockets.Monad as I@@ -191,8 +200,8 @@ I.Binary x -> return (I.fromLazyByteString x) -- | Send a 'I.Response' to the socket immediately.-sendResponse :: I.Protocol p => I.Response -> I.WebSockets p ()-sendResponse = I.sendBuilder . I.encodeResponse+sendResponse :: I.Protocol p => I.ResponseBody -> I.WebSockets p ()+sendResponse = I.sendBuilder . I.encodeResponseBody -- | Send a text message sendTextData :: (I.TextProtocol p, I.WebSocketsData a) => a -> I.WebSockets p ()
+ src/Network/WebSockets/Client.hs view
@@ -0,0 +1,84 @@+--------------------------------------------------------------------------------+-- | This part of the library provides you with utilities to create WebSockets+-- clients (in addition to servers).+module Network.WebSockets.Client+ ( connect+ , connectWith+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative ((<$>))+import Control.Monad.Trans (liftIO)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BC+import Data.Enumerator (Iteratee, ($$))+import qualified Data.Enumerator as E+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.Socket as S+import qualified Network.Socket.Enumerator as SE+++--------------------------------------------------------------------------------+import Network.WebSockets.Handshake.Http+import Network.WebSockets.Monad+import Network.WebSockets.Protocol+import Network.WebSockets.Socket (iterSocket)+++--------------------------------------------------------------------------------+connect :: Protocol p+ => String -- ^ Host+ -> Int -- ^ Port+ -> String -- ^ Path+ -> WebSockets p a -- ^ Client application+ -> IO a+connect host port path ws =+ connectWith host port path Nothing Nothing ws+++--------------------------------------------------------------------------------+connectWith :: Protocol p+ => String -- ^ Host+ -> Int -- ^ Port+ -> String -- ^ Path+ -> Maybe String -- ^ Origin, if Nothing then server interprets+ -- connection as not coming from a browser.+ -> Maybe [String] -- ^ Protocol List+ -> WebSockets p a -- ^ Client application+ -> IO a+connectWith host port path origin wsProtocols app = do+ -- Create the request+ request <- createRequest protocol bHost bPath bOrigin bWsProtocols False++ -- Connect to server+ sock <- S.socket S.AF_INET S.Stream S.defaultProtocol+ addrInfos <- S.getAddrInfo Nothing (Just host) (Just $ show port)+ S.connect sock (S.addrAddress $ head addrInfos)+ res <- E.run_ $ SE.enumSocket 4096 sock $$ (iter request) $ iterSocket sock++ -- Clean up+ S.sClose sock+ return res+ where+ protocol = head implementations+ iter request = runWebSocketsClient protocol request app+ bHost = T.encodeUtf8 $ T.pack host+ bPath = T.encodeUtf8 $ T.pack path+ bOrigin = T.encodeUtf8 . T.pack <$> origin+ bWsProtocols = map BC.pack <$> wsProtocols+++--------------------------------------------------------------------------------+runWebSocketsClient :: Protocol p+ => p+ -> RequestHttpPart+ -> WebSockets p a+ -> Iteratee ByteString IO ()+ -> Iteratee ByteString IO a+runWebSocketsClient protocol request ws outIter = do+ liftIO $ makeBuilderSender outIter $ encodeRequestHttpPart request+ response <- receiveIteratee decodeResponse+ _ <- finishResponse protocol request response+ runWebSocketsWith' defaultWebSocketsOptions protocol ws outIter
src/Network/WebSockets/Handshake.hs view
@@ -27,7 +27,7 @@ -- | Respond to errors encountered during handshake. First argument may be -- bottom.-responseError :: forall p. Protocol p => p -> HandshakeError -> Response+responseError :: forall p. Protocol p => p -> HandshakeError -> ResponseBody responseError _ err = response400 $ case err of -- TODO: fix NotSupported -> versionHeader -- Version negotiation
src/Network/WebSockets/Handshake/Http.hs view
@@ -2,15 +2,27 @@ {-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} module Network.WebSockets.Handshake.Http ( Headers- , RequestHttpPart (..) , Request (..)- , Response (..)+ , RequestHttpPart (..)+ , RequestBody (..)+ , ResponseHttpPart (..)+ , ResponseBody (..) , HandshakeError (..) , getSecWebSocketVersion++ , encodeRequestHttpPart+ , encodeRequestBody , decodeRequest- , encodeResponse++ , encodeResponseHttpPart+ , encodeResponseBody+ , decodeResponse+ , response101 , response400++ , getRequestHeader+ , getResponseHeader ) where import Data.Dynamic (Typeable)@@ -19,17 +31,27 @@ import Control.Exception (Exception) import Control.Monad.Error (Error (..)) +import Data.ByteString (ByteString) import Data.ByteString.Char8 () import Data.ByteString.Internal (c2w)-import qualified Data.Attoparsec as A import qualified Blaze.ByteString.Builder as Builder import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder+import qualified Data.Attoparsec as A import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC import qualified Data.CaseInsensitive as CI+import qualified Data.Enumerator as E -- | Request headers type Headers = [(CI.CI B.ByteString, B.ByteString)] +-- | Full request type, including the response to it+data Request = Request+ { requestPath :: !B.ByteString+ , requestHeaders :: Headers+ , requestResponse :: ResponseBody+ } deriving (Show)+ -- | (Internally used) HTTP headers and requested path. data RequestHttpPart = RequestHttpPart { requestHttpPath :: !B.ByteString@@ -37,22 +59,21 @@ , requestHttpSecure :: Bool } deriving (Eq, Show) --- | Full request type-data Request = Request- { requestPath :: !B.ByteString- , requestHeaders :: Headers- , requestResponse :: Response- }+-- | A request with a body+data RequestBody = RequestBody RequestHttpPart B.ByteString deriving (Show) -- | Response to a 'Request'-data Response = Response- { responseCode :: !Int- , responseMessage :: !B.ByteString- , responseHeaders :: Headers- , responseBody :: B.ByteString+data ResponseHttpPart = ResponseHttpPart+ { responseHttpCode :: !Int+ , responseHttpMessage :: !B.ByteString+ , responseHttpHeaders :: Headers } deriving (Show) +-- | A response including a body+data ResponseBody = ResponseBody ResponseHttpPart B.ByteString+ deriving (Show)+ -- | Error in case of failed handshake. Will be thrown as an iteratee -- exception. ('Error' condition). --@@ -65,6 +86,9 @@ -- | The request was somehow invalid (missing headers or wrong security -- token) | MalformedRequest RequestHttpPart String+ -- | The servers response was somehow invalid (missing headers or wrong+ -- security token)+ | MalformedResponse ResponseHttpPart String -- | The request was well-formed, but the library user rejected it. -- (e.g. "unknown path") | RequestRejected Request String@@ -82,6 +106,24 @@ getSecWebSocketVersion :: RequestHttpPart -> Maybe B.ByteString getSecWebSocketVersion p = lookup "Sec-WebSocket-Version" (requestHttpHeaders p) +-- | RequestHttpPart encoder+encodeRequestHttpPart :: RequestHttpPart -> Builder.Builder+encodeRequestHttpPart (RequestHttpPart 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"]++-- | RequestBody encoder+encodeRequestBody :: RequestBody -> Builder.Builder+encodeRequestBody (RequestBody httpPart body) =+ encodeRequestHttpPart httpPart `mappend` Builder.copyByteString body+ -- | Parse an initial request decodeRequest :: Bool -> A.Parser RequestHttpPart decodeRequest isSecure = RequestHttpPart@@ -103,27 +145,67 @@ <* newline -- | Encode an HTTP upgrade response-encodeResponse :: Response -> Builder.Builder-encodeResponse (Response code msg headers body) =+encodeResponseHttpPart :: ResponseHttpPart -> Builder.Builder+encodeResponseHttpPart (ResponseHttpPart 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" `mappend`- Builder.copyByteString body -- (body is empty except for version -00)+ Builder.copyByteString "\r\n" where header (k, v) = mconcat $ map Builder.copyByteString [CI.original k, ": ", v, "\r\n"] +encodeResponseBody :: ResponseBody -> Builder.Builder+encodeResponseBody (ResponseBody httpPart body) =+ encodeResponseHttpPart httpPart `mappend` Builder.copyByteString body+ -- | An upgrade response-response101 :: Headers -> B.ByteString -> Response-response101 headers body = Response 101 "WebSocket Protocol Handshake"- (("Upgrade", "websocket") : ("Connection", "Upgrade") : headers)- body+response101 :: Headers -> B.ByteString -> ResponseBody+response101 headers = ResponseBody+ (ResponseHttpPart 101 "WebSocket Protocol Handshake"+ (("Upgrade", "websocket") : ("Connection", "Upgrade") : headers)) -- | Bad request ---response400 :: Headers -> Response-response400 headers = Response 400 "Bad Request" headers ""+response400 :: Headers -> ResponseBody+response400 headers =+ ResponseBody (ResponseHttpPart 400 "Bad Request" headers) ""++-- | HTTP response parser+decodeResponse :: A.Parser ResponseHttpPart+decodeResponse = ResponseHttpPart+ <$> fmap (read . BC.unpack) code+ <*> message+ <*> A.manyTill header 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+ header = (,)+ <$> (CI.mk <$> A.takeWhile1 (/= c2w ':'))+ <* A.string ": "+ <*> A.takeWhile1 (/= c2w '\r')+ <* newline++getRequestHeader :: Monad m+ => RequestHttpPart+ -> CI.CI ByteString+ -> E.Iteratee ByteString m ByteString+getRequestHeader rq key = case lookup key (requestHttpHeaders rq) of+ Just t -> return t+ Nothing -> E.throwError $ MalformedRequest rq $ + "Header missing: " ++ BC.unpack (CI.original key)++getResponseHeader :: Monad m+ => ResponseHttpPart+ -> CI.CI ByteString+ -> E.Iteratee ByteString m ByteString+getResponseHeader rsp key = case lookup key (responseHttpHeaders rsp) of+ Just t -> return t+ Nothing -> E.throwError $ MalformedResponse rsp $ + "Header missing: " ++ BC.unpack (CI.original key)
src/Network/WebSockets/Monad.hs view
@@ -22,6 +22,8 @@ , throwWsError , catchWsError , spawnPingThread+ , receiveIteratee+ , makeBuilderSender ) where import Control.Applicative (Applicative, (<$>))@@ -122,7 +124,7 @@ runWebSocketsWith opts httpReq goWs outIter = E.catchError ok $ \e -> do -- If handshake went bad, send response forM_ (fromException e) $ \he ->- let builder = encodeResponse $ responseError (undefined :: p) he+ let builder = encodeResponseBody $ responseError (undefined :: p) he in liftIO $ makeBuilderSender outIter builder -- Re-throw error E.throwError e
src/Network/WebSockets/Protocol.hs view
@@ -45,6 +45,17 @@ -- | Decodes messages from binary 'B.ByteString's. decodeMessages :: Monad m => p -> E.Enumeratee B.ByteString (Message p) m a + -- | Create a @Request@ that can be sent to the websockets server to open+ -- the connection.+ createRequest :: p+ -> B.ByteString -- ^ Hostname of the server.+ -> B.ByteString -- ^ Path+ -> Maybe B.ByteString -- ^ Origin where we are connecting from.+ -> Maybe [B.ByteString] -- ^ Protocols list.+ -> Bool -- ^ Is the connection secure, i.e. wss.+ -> IO RequestHttpPart -- ^ HTTP request that can be sent to the+ -- to the server to initiate the connection.+ -- | Parse and validate the rest of the request. For hybi10, this is just -- validation, but hybi00 also needs to fetch a "security token" --@@ -53,6 +64,11 @@ finishRequest :: Monad m => p -> RequestHttpPart -> E.Iteratee B.ByteString m Request++ -- | Parse and validate the handshake response received from the server.+ finishResponse :: Monad m+ => p -> RequestHttpPart -> ResponseHttpPart+ -> E.Iteratee B.ByteString m ResponseBody -- | Implementations of the specification implementations :: [p]
src/Network/WebSockets/Protocol/Hybi00.hs view
@@ -19,7 +19,9 @@ supported (Hybi00 p) h = supported p h encodeMessages (Hybi00 p) = (EL.map castMessage =$) . encodeMessages p decodeMessages (Hybi00 p) = (decodeMessages p =$) . EL.map castMessage+ createRequest (Hybi00 p) = createRequest p finishRequest (Hybi00 p) = finishRequest p+ finishResponse (Hybi00 p) = finishResponse p implementations = [Hybi00 Hybi10_, Hybi00 Hybi00_] instance TextProtocol Hybi00
src/Network/WebSockets/Protocol/Hybi00/Internal.hs view
@@ -18,8 +18,8 @@ import qualified Data.Enumerator as E import qualified Data.Enumerator.List as EL import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy.Char8 () import qualified Data.ByteString.Lazy as BL-import qualified Data.CaseInsensitive as CI import Network.WebSockets.Handshake.Http import Network.WebSockets.Protocol@@ -28,13 +28,15 @@ data Hybi00_ = Hybi00_ instance Protocol Hybi00_ where- version Hybi00_ = "hybi00"- headerVersions Hybi00_ = [] -- The client will elide it- supported Hybi00_ h = getSecWebSocketVersion h == Nothing- encodeMessages Hybi00_ = EL.map encodeMessage- decodeMessages Hybi00_ = E.sequence (A.iterParser parseMessage)- finishRequest Hybi00_ = handshakeHybi00- implementations = [Hybi00_]+ version Hybi00_ = "hybi00"+ headerVersions Hybi00_ = [] -- The client will elide it+ supported Hybi00_ h = getSecWebSocketVersion h == Nothing+ encodeMessages Hybi00_ = EL.map encodeMessage+ decodeMessages Hybi00_ = E.sequence (A.iterParser parseMessage)+ createRequest Hybi00_ = error "createRequest Hybi00_"+ finishRequest Hybi00_ = handshakeHybi00+ finishResponse Hybi00_ = error "finishResponse Hybi00_"+ implementations = [Hybi00_] instance TextProtocol Hybi00_ @@ -79,7 +81,7 @@ let key = B.concat . BL.toChunks . encode . md5 $ BL.concat [keyPart1, keyPart2, BL.fromChunks [keyPart3]] - host <- getHeader "Host"+ host <- getHeader "Host" -- todo: origin right? (also applies to hybi10) origin <- getHeader "Origin" let schema = if isSecure then "wss://" else "ws://"@@ -91,11 +93,7 @@ return $ Request path h response where- getHeader k = case lookup k h of- Just t -> return t- Nothing -> E.throwError $ MalformedRequest reqHttp $- "Header missing: " ++ BC.unpack (CI.original k)-+ getHeader = getRequestHeader reqHttp numberFromToken token = case divBySpaces (BC.unpack token) of Just n -> return $ encode n Nothing -> E.throwError $ MalformedRequest reqHttp
src/Network/WebSockets/Protocol/Hybi10.hs view
@@ -17,7 +17,9 @@ supported (Hybi10 p) h = supported p h encodeMessages (Hybi10 p) = (EL.map castMessage =$) . encodeMessages p decodeMessages (Hybi10 p) = (decodeMessages p =$) . EL.map castMessage+ createRequest (Hybi10 p) = createRequest p finishRequest (Hybi10 p) = finishRequest p+ finishResponse (Hybi10 p) = finishResponse p implementations = [Hybi10 Hybi10_] instance TextProtocol Hybi10
src/Network/WebSockets/Protocol/Hybi10/Internal.hs view
@@ -5,24 +5,23 @@ ) where import Control.Applicative (pure, (<$>))+import Control.Monad (liftM) import Data.Bits ((.&.), (.|.)) import Data.Maybe (maybeToList) import Data.Monoid (mempty, mappend, mconcat) import Data.Attoparsec (anyWord8) import Data.Binary.Get (runGet, getWord16be, getWord64be)-import Data.ByteString (ByteString)+import Data.ByteString (ByteString, intercalate) import Data.ByteString.Char8 () import Data.Digest.Pure.SHA (bytestringDigest, sha1)-import Data.Int (Int64) import Data.Enumerator ((=$))+import Data.Int (Int64) import qualified Blaze.ByteString.Builder as B import qualified Data.Attoparsec as A import qualified Data.Attoparsec.Enumerator as A import qualified Data.ByteString.Base64 as B64-import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL-import qualified Data.CaseInsensitive as CI import qualified Data.Enumerator as E import qualified Data.Enumerator.List as EL @@ -32,15 +31,19 @@ import Network.WebSockets.Protocol.Hybi10.Mask import Network.WebSockets.Types +import System.Entropy as R+ data Hybi10_ = Hybi10_ instance Protocol Hybi10_ where- version Hybi10_ = "hybi10"- headerVersions Hybi10_ = ["13", "8", "7"]- encodeMessages Hybi10_ = EL.map encodeMessageHybi10- decodeMessages Hybi10_ = decodeMessagesHybi10- finishRequest Hybi10_ = handshakeHybi10- implementations = [Hybi10_]+ version Hybi10_ = "hybi10"+ headerVersions Hybi10_ = ["13", "8", "7"]+ encodeMessages Hybi10_ = EL.map encodeMessageHybi10+ decodeMessages Hybi10_ = decodeMessagesHybi10+ createRequest Hybi10_ = createRequestHybi10+ finishRequest Hybi10_ = handshakeHybi10+ finishResponse Hybi10_ = finishResponseHybi10+ implementations = [Hybi10_] instance TextProtocol Hybi10_ instance BinaryProtocol Hybi10_@@ -142,15 +145,65 @@ => RequestHttpPart -> E.Iteratee ByteString m Request handshakeHybi10 reqHttp@(RequestHttpPart path h _) = do- key <- getHeader "Sec-WebSocket-Key"- let hash = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid+ key <- getRequestHeader reqHttp "Sec-WebSocket-Key"+ let hash = hashKeyHybi10 key let encoded = B64.encode hash return $ Request path h $ response101 [("Sec-WebSocket-Accept", encoded)] ""++createRequestHybi10 :: ByteString+ -> ByteString+ -> Maybe ByteString+ -> Maybe [ByteString]+ -> Bool+ -> IO RequestHttpPart+createRequestHybi10 hostname path origin protocols secure = do+ key <- B64.encode `liftM` getEntropy 16+ return $ RequestHttpPart path (headers key) secure where+ headers key = [("Host" , hostname )+ ,("Connection" , "Upgrade" )+ ,("Upgrade" , "websocket" )+ ,("Sec-WebSocket-Key" , key )+ ,("Sec-WebSocket-Version" , versionNumber)+ ] ++ protocolHeader protocols+ ++ originHeader origin++ originHeader (Just o) = [("Origin" , o )]+ originHeader Nothing = []++ protocolHeader (Just ps) = [("Sec-WebSocket-Protocol", intercalate ", " ps)]+ protocolHeader Nothing = []++ versionNumber = head . headerVersions $ Hybi10_++finishResponseHybi10 :: Monad m+ => RequestHttpPart+ -> ResponseHttpPart+ -> E.Iteratee ByteString m ResponseBody+finishResponseHybi10 request response = do+ -- Response message should be one of+ --+ -- - WebSocket Protocol Handshake+ -- - Switching Protocols+ --+ -- But we don't check it for now+ if responseHttpCode response /= 101+ then throw "Wrong response status or message."+ else do+ key <- getRequestHeader request "Sec-WebSocket-Key"+ responseHash <- getResponseHeader response "Sec-WebSocket-Accept"++ let challengeHash = B64.encode $ hashKeyHybi10 key+ if responseHash /= challengeHash+ then throw "Challenge and response hashes do not match."+ else return $ ResponseBody response ""+ where+ throw msg = E.throwError $ MalformedResponse response msg+++hashKeyHybi10 :: ByteString -> ByteString+hashKeyHybi10 key = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid+ where guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" lazy = BL.fromChunks . return unlazy = mconcat . BL.toChunks- getHeader k = case lookup k h of- Just t -> return t- Nothing -> E.throwError $ MalformedRequest reqHttp $ - "Header missing: " ++ BC.unpack (CI.original k)
src/Network/WebSockets/Socket.hs view
@@ -7,10 +7,8 @@ , iterSocket ) where -import Prelude hiding (catch)- import Control.Concurrent (forkIO)-import Control.Exception (SomeException, catch)+import Control.Exception (SomeException, handle) import Control.Monad (forever) import Control.Monad.Trans (liftIO) @@ -41,7 +39,7 @@ host' <- S.inet_addr host S.bindSocket sock (S.SockAddrInet (fromIntegral port) host') S.listen sock 5- flip catch (closeSock sock) $ forever $ do+ handle (closeSock sock) $ forever $ do (conn, _) <- S.accept sock -- Voodoo fix: set this to True as soon as we notice the connection was -- closed. Will prevent iterSocket' from even trying to send anything.
src/Network/WebSockets/Types.hs view
@@ -1,7 +1,5 @@--{-# LANGUAGE DeriveDataTypeable #-}- -- | Primary types+{-# LANGUAGE DeriveDataTypeable #-} module Network.WebSockets.Types ( Message (..) , ControlMessage (..)
websockets.cabal view
@@ -1,5 +1,5 @@ Name: websockets-Version: 0.6.0.4+Version: 0.7.0.0 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell.@@ -49,6 +49,7 @@ Network.WebSockets.Util.PubSub Other-modules:+ Network.WebSockets.Client Network.WebSockets.Handshake Network.WebSockets.Handshake.Http Network.WebSockets.Monad@@ -67,11 +68,11 @@ attoparsec >= 0.9 && < 0.11, attoparsec-enumerator >= 0.2 && < 0.4, base >= 4 && < 5,- base64-bytestring >= 0.1 && < 0.2,+ base64-bytestring >= 0.1 && < 1.1, binary >= 0.5 && < 0.6, blaze-builder >= 0.3 && < 0.4, blaze-builder-enumerator >= 0.2 && < 0.3,- bytestring >= 0.9 && < 0.10,+ bytestring >= 0.9 && < 0.11, case-insensitive >= 0.3 && < 0.5, containers >= 0.3 && < 0.6, enumerator >= 0.4.13 && < 0.5,@@ -81,7 +82,8 @@ random >= 1.0 && < 1.1, SHA >= 1.5 && < 1.6, text >= 0.10 && < 0.12,- pureMD5 >= 0.2.2 && < 2.2+ pureMD5 >= 0.2.2 && < 2.2,+ entropy >= 0.2.1 && < 0.3 Test-suite websockets-tests Type: exitcode-stdio-1.0@@ -91,7 +93,7 @@ Build-depends: HUnit >= 1.2 && < 1.3,- QuickCheck >= 2.4 && < 2.5,+ QuickCheck >= 2.4 && < 2.6, test-framework >= 0.4 && < 0.7, test-framework-hunit >= 0.2 && < 0.3, test-framework-quickcheck2 >= 0.2 && < 0.3,@@ -99,11 +101,11 @@ attoparsec >= 0.9 && < 0.11, attoparsec-enumerator >= 0.2 && < 0.4, base >= 4 && < 5,- base64-bytestring >= 0.1 && < 0.2,+ base64-bytestring >= 0.1 && < 1.1, binary >= 0.5 && < 0.6, blaze-builder >= 0.3 && < 0.4, blaze-builder-enumerator >= 0.2 && < 0.3,- bytestring >= 0.9 && < 0.10,+ bytestring >= 0.9 && < 0.11, case-insensitive >= 0.3 && < 0.5, containers >= 0.3 && < 0.6, enumerator >= 0.4.13 && < 0.5,@@ -113,7 +115,8 @@ random >= 1.0 && < 1.1, SHA >= 1.5 && < 1.6, text >= 0.10 && < 0.12,- pureMD5 >= 0.2.2 && < 2.2+ pureMD5 >= 0.2.2 && < 2.2,+ entropy >= 0.2.1 && < 0.3 Source-repository head Type: git