websockets 0.4.0.0 → 0.4.0.1
raw patch · 8 files changed
+303/−233 lines, 8 filesdep ~attoparsecdep ~attoparsec-enumeratordep ~case-insensitive
Dependency ranges changed: attoparsec, attoparsec-enumerator, case-insensitive
Files
- src/Network/WebSockets.hs +2/−0
- src/Network/WebSockets/Protocol/Hybi00.hs +4/−99
- src/Network/WebSockets/Protocol/Hybi00/Internal.hs +111/−0
- src/Network/WebSockets/Protocol/Hybi10.hs +5/−130
- src/Network/WebSockets/Protocol/Hybi10/Internal.hs +132/−0
- src/Network/WebSockets/Protocol/Hybi17.hs +21/−0
- src/Network/WebSockets/Protocol/Hybi17/Internal.hs +20/−0
- websockets.cabal +8/−4
src/Network/WebSockets.hs view
@@ -96,6 +96,7 @@ , I.BinaryProtocol , I.Hybi00 , I.Hybi10+ , I.Hybi17 -- * A simple standalone server , I.runServer@@ -160,6 +161,7 @@ import qualified Network.WebSockets.Protocol as I import qualified Network.WebSockets.Protocol.Hybi00 as I import qualified Network.WebSockets.Protocol.Hybi10 as I+import qualified Network.WebSockets.Protocol.Hybi17 as I import qualified Network.WebSockets.Protocol.Unsafe as Unsafe import qualified Network.WebSockets.Socket as I import qualified Network.WebSockets.Types as I
src/Network/WebSockets/Protocol/Hybi00.hs view
@@ -4,105 +4,10 @@ , Hybi00 ) where -import Control.Applicative ((<|>))-import Control.Monad.Error (ErrorT (..), MonadError, throwError)-import Control.Monad.Trans (lift)-import Data.Char (isDigit)--import Data.Binary (encode)-import Data.Digest.Pure.MD5 (md5)-import Data.Int (Int32)-import qualified Blaze.ByteString.Builder as BB-import qualified Data.Attoparsec as A-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as BL-import qualified Data.CaseInsensitive as CI--import Network.WebSockets.Handshake.Http import Network.WebSockets.Protocol-import Network.WebSockets.Types-import Network.WebSockets.Protocol.Hybi10 (Hybi10_ (..))--data Hybi00_ = Hybi00_--instance Protocol Hybi00_ where- version Hybi00_ = "hybi00"- headerVersion Hybi00_ = "0" -- but the client will elide it- encodeFrame Hybi00_ = encodeFrameHybi00- decodeFrame Hybi00_ = decodeFrameHybi00- finishRequest Hybi00_ = runErrorT . handshakeHybi00- implementations = [Hybi00_]--instance TextProtocol Hybi00_--encodeFrameHybi00 :: Encoder p Frame-encodeFrameHybi00 _ (Frame True TextFrame pl) =- BB.fromLazyByteString $ "\0" `BL.append` pl `BL.append` "\255"-encodeFrameHybi00 _ (Frame _ CloseFrame _) =- BB.fromLazyByteString "\255\0"- -- TODO: prevent the user from doing this using type tags-encodeFrameHybi00 _ _ = error "Not supported"--decodeFrameHybi00 :: Decoder p Frame-decodeFrameHybi00 = decodeTextFrame <|> decodeCloseFrame- where- decodeTextFrame = do- _ <- A.word8 0x00- utf8string <- A.manyTill A.anyWord8 (A.try $ A.word8 0xff)- return $ Frame True TextFrame $ BL.pack utf8string-- decodeCloseFrame = do- _ <- A.word8 0xff- _ <- A.word8 0x00- return $ Frame True CloseFrame ""--divBySpaces :: String -> Maybe Int32-divBySpaces str- | spaces == 0 = Nothing- | otherwise = Just . fromIntegral $ number `div` spaces- where- number = read $ filter isDigit str :: Integer- spaces = fromIntegral . length $ filter (== ' ') str--handshakeHybi00 :: RequestHttpPart- -> ErrorT HandshakeError A.Parser Request-handshakeHybi00 reqHttp@(RequestHttpPart path h) = do- -- _ <- lift . A.word8 $ fromIntegral 0x0d- -- _ <- lift . A.word8 $ fromIntegral 0x0a-- case getHeader "Sec-WebSocket-Version" of- Left _ -> return ()- Right "0" -> return ()- Right _ -> throwError NotSupported-- keyPart3 <- lift $ A.take 8- keyPart1 <- numberFromToken =<< getHeader "Sec-WebSocket-Key1"- keyPart2 <- numberFromToken =<< getHeader "Sec-WebSocket-Key2"-- let key = B.concat . BL.toChunks . encode . md5 $ BL.concat- [keyPart1, keyPart2, BL.fromChunks [keyPart3]]-- host <- getHeader "Host"- -- todo: origin right? (also applies to hybi10)- origin <- getHeader "Origin"- let response = response101- [ ("Sec-WebSocket-Location", B.concat ["ws://", host, path])- , ("Sec-WebSocket-Origin", origin)- ]- key-- return $ Request path h response- where- getHeader k = case lookup k h of- Just t -> return t- Nothing -> throwError $ MalformedRequest reqHttp $- "Header missing: " ++ BC.unpack (CI.original k)-- numberFromToken token = case divBySpaces (BC.unpack token) of- Just n -> return $ encode n- Nothing -> throwError $ MalformedRequest reqHttp- "Security token does not contain enough spaces"+import Network.WebSockets.Protocol.Hybi00.Internal+import Network.WebSockets.Protocol.Hybi10.Internal+import Network.WebSockets.Protocol.Hybi17.Internal data Hybi00 = forall p. Protocol p => Hybi00 p @@ -112,6 +17,6 @@ encodeFrame (Hybi00 p) = encodeFrame p decodeFrame (Hybi00 p) = decodeFrame p finishRequest (Hybi00 p) = finishRequest p- implementations = [Hybi00 Hybi00_, Hybi00 Hybi10_]+ implementations = [Hybi00 Hybi17_, Hybi00 Hybi10_, Hybi00 Hybi00_] instance TextProtocol Hybi00
+ src/Network/WebSockets/Protocol/Hybi00/Internal.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module Network.WebSockets.Protocol.Hybi00.Internal+ ( Hybi00_ (..)+ ) where++import Control.Applicative ((<|>))+import Control.Monad.Error (ErrorT (..), MonadError, throwError)+import Control.Monad.Trans (lift)+import Data.Char (isDigit)++import Data.Binary (encode)+import Data.Digest.Pure.MD5 (md5)+import Data.Int (Int32)+import qualified Blaze.ByteString.Builder as BB+import qualified Data.Attoparsec as A+#if MIN_VERSION_attoparsec(0,10,0)+import qualified Data.Attoparsec.Types as AT+#endif+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.CaseInsensitive as CI++import Network.WebSockets.Handshake.Http+import Network.WebSockets.Protocol+import Network.WebSockets.Types++data Hybi00_ = Hybi00_++instance Protocol Hybi00_ where+ version Hybi00_ = "hybi00"+ headerVersion Hybi00_ = "0" -- but the client will elide it+ encodeFrame Hybi00_ = encodeFrameHybi00+ decodeFrame Hybi00_ = decodeFrameHybi00+ finishRequest Hybi00_ = runErrorT . handshakeHybi00+ implementations = [Hybi00_]++instance TextProtocol Hybi00_++encodeFrameHybi00 :: Encoder p Frame+encodeFrameHybi00 _ (Frame True TextFrame pl) =+ BB.fromLazyByteString $ "\0" `BL.append` pl `BL.append` "\255"+encodeFrameHybi00 _ (Frame _ CloseFrame _) =+ BB.fromLazyByteString "\255\0"+ -- TODO: prevent the user from doing this using type tags+encodeFrameHybi00 _ _ = error "Not supported"++decodeFrameHybi00 :: Decoder p Frame+decodeFrameHybi00 = decodeTextFrame <|> decodeCloseFrame+ where+ decodeTextFrame = do+ _ <- A.word8 0x00+ utf8string <- A.manyTill A.anyWord8 (A.try $ A.word8 0xff)+ return $ Frame True TextFrame $ BL.pack utf8string++ decodeCloseFrame = do+ _ <- A.word8 0xff+ _ <- A.word8 0x00+ return $ Frame True CloseFrame ""++divBySpaces :: String -> Maybe Int32+divBySpaces str+ | spaces == 0 = Nothing+ | otherwise = Just . fromIntegral $ number `div` spaces+ where+ number = read $ filter isDigit str :: Integer+ spaces = fromIntegral . length $ filter (== ' ') str++handshakeHybi00 :: RequestHttpPart+#if MIN_VERSION_attoparsec(0,10,0)+ -> ErrorT HandshakeError (AT.Parser B.ByteString) Request+#else+ -> ErrorT HandshakeError A.Parser Request+#endif+handshakeHybi00 reqHttp@(RequestHttpPart path h) = do+ -- _ <- lift . A.word8 $ fromIntegral 0x0d+ -- _ <- lift . A.word8 $ fromIntegral 0x0a++ case getHeader "Sec-WebSocket-Version" of+ Left _ -> return ()+ Right "0" -> return ()+ Right _ -> throwError NotSupported++ keyPart3 <- lift $ A.take 8+ keyPart1 <- numberFromToken =<< getHeader "Sec-WebSocket-Key1"+ keyPart2 <- numberFromToken =<< getHeader "Sec-WebSocket-Key2"++ let key = B.concat . BL.toChunks . encode . md5 $ BL.concat+ [keyPart1, keyPart2, BL.fromChunks [keyPart3]]++ host <- getHeader "Host"+ -- todo: origin right? (also applies to hybi10)+ origin <- getHeader "Origin"+ let response = response101+ [ ("Sec-WebSocket-Location", B.concat ["ws://", host, path])+ , ("Sec-WebSocket-Origin", origin)+ ]+ key++ return $ Request path h response+ where+ getHeader k = case lookup k h of+ Just t -> return t+ Nothing -> throwError $ MalformedRequest reqHttp $+ "Header missing: " ++ BC.unpack (CI.original k)++ numberFromToken token = case divBySpaces (BC.unpack token) of+ Just n -> return $ encode n+ Nothing -> throwError $ MalformedRequest reqHttp+ "Security token does not contain enough spaces"
src/Network/WebSockets/Protocol/Hybi10.hs view
@@ -1,136 +1,11 @@-{-# LANGUAGE ExistentialQuantification, OverloadedStrings #-}+{-# LANGUAGE ExistentialQuantification #-} module Network.WebSockets.Protocol.Hybi10- ( Hybi10_ (..)- , Hybi10+ ( Hybi10 ) where -import Control.Applicative (pure, (<$>))-import Data.Bits ((.&.), (.|.))-import Data.Monoid (mempty)--import Data.Attoparsec (anyWord8)-import Data.Binary.Get (runGet, getWord16be, getWord64be)-import Data.ByteString (ByteString)-import Data.ByteString.Char8 ()-import Data.Int (Int64)-import qualified Blaze.ByteString.Builder as B-import qualified Data.Attoparsec as A-import qualified Data.ByteString.Lazy as BL-import Data.Digest.Pure.SHA (bytestringDigest, sha1)-import qualified Data.ByteString.Base64 as B64-import qualified Data.ByteString.Char8 as BC-import qualified Data.CaseInsensitive as CI-import Control.Monad.Error (throwError)-import Data.Monoid (mappend, mconcat)--import Network.WebSockets.Handshake.Http-import Network.WebSockets.Mask import Network.WebSockets.Protocol-import Network.WebSockets.Types--data Hybi10_ = Hybi10_--instance Protocol Hybi10_ where- version Hybi10_ = "hybi10"- headerVersion Hybi10_ = "8"- encodeFrame Hybi10_ = encodeFrameHybi10- decodeFrame Hybi10_ = decodeFrameHybi10- finishRequest Hybi10_ = handshakeHybi10- implementations = [Hybi10_]--instance TextProtocol Hybi10_-instance BinaryProtocol Hybi10_---- | Parse a frame-decodeFrameHybi10 :: Decoder p Frame-decodeFrameHybi10 = do- byte0 <- anyWord8- let fin = byte0 .&. 0x80 == 0x80- opcode = byte0 .&. 0x0f-- let ft = case opcode of- 0x00 -> ContinuationFrame- 0x01 -> TextFrame- 0x02 -> BinaryFrame- 0x08 -> CloseFrame- 0x09 -> PingFrame- 0x0a -> PongFrame- _ -> error "Unknown opcode"-- byte1 <- 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 ft (masker $ BL.fromChunks chunks)- where- runGet' g = runGet g . BL.fromChunks . return-- take64 :: Int64 -> Decoder p [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)---- | Encode a frame-encodeFrameHybi10 :: Encoder p Frame-encodeFrameHybi10 mask f = B.fromWord8 byte0 `mappend`- B.fromWord8 byte1 `mappend` len `mappend` maskbytes `mappend`- B.fromLazyByteString (maskPayload mask (framePayload f))- where- byte0 = fin .|. opcode- fin = if frameFin f then 0x80 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'))---handshakeHybi10 :: RequestHttpPart -> Decoder p (Either HandshakeError Request)-handshakeHybi10 reqHttp@(RequestHttpPart path h) = return $ do- case getHeader "Sec-WebSocket-Version" of- Right "8" -> return ()- _ -> throwError NotSupported- key <- getHeader "Sec-WebSocket-Key"- let hash = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid- let encoded = B64.encode hash- return $ Request path h $ response101 [("Sec-WebSocket-Accept", encoded)] ""- 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 -> throwError $- MalformedRequest reqHttp $ - "Header missing: " ++ BC.unpack (CI.original k)+import Network.WebSockets.Protocol.Hybi10.Internal+import Network.WebSockets.Protocol.Hybi17.Internal data Hybi10 = forall p. Protocol p => Hybi10 p @@ -140,7 +15,7 @@ encodeFrame (Hybi10 p) = encodeFrame p decodeFrame (Hybi10 p) = decodeFrame p finishRequest (Hybi10 p) = finishRequest p- implementations = [Hybi10 Hybi10_]+ implementations = [Hybi10 Hybi17_, Hybi10 Hybi10_] instance TextProtocol Hybi10 instance BinaryProtocol Hybi10
+ src/Network/WebSockets/Protocol/Hybi10/Internal.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Protocol.Hybi10.Internal+ ( Hybi10_ (..)+ ) where++import Control.Applicative (pure, (<$>))+import Data.Bits ((.&.), (.|.))+import Data.Monoid (mempty)++import Data.Attoparsec (anyWord8)+import Data.Binary.Get (runGet, getWord16be, getWord64be)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 ()+import Data.Int (Int64)+import qualified Blaze.ByteString.Builder as B+import qualified Data.Attoparsec as A+import qualified Data.ByteString.Lazy as BL+import Data.Digest.Pure.SHA (bytestringDigest, sha1)+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Char8 as BC+import qualified Data.CaseInsensitive as CI+import Control.Monad.Error (throwError)+import Data.Monoid (mappend, mconcat)++import Network.WebSockets.Handshake.Http+import Network.WebSockets.Mask+import Network.WebSockets.Protocol+import Network.WebSockets.Types++data Hybi10_ = Hybi10_++instance Protocol Hybi10_ where+ version Hybi10_ = "hybi10"+ headerVersion Hybi10_ = "8"+ encodeFrame Hybi10_ = encodeFrameHybi10+ decodeFrame Hybi10_ = decodeFrameHybi10+ finishRequest Hybi10_ = handshakeHybi10+ implementations = [Hybi10_]++instance TextProtocol Hybi10_+instance BinaryProtocol Hybi10_++-- | Parse a frame+decodeFrameHybi10 :: Decoder p Frame+decodeFrameHybi10 = do+ byte0 <- anyWord8+ let fin = byte0 .&. 0x80 == 0x80+ opcode = byte0 .&. 0x0f++ let ft = case opcode of+ 0x00 -> ContinuationFrame+ 0x01 -> TextFrame+ 0x02 -> BinaryFrame+ 0x08 -> CloseFrame+ 0x09 -> PingFrame+ 0x0a -> PongFrame+ _ -> error "Unknown opcode"++ byte1 <- 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 ft (masker $ BL.fromChunks chunks)+ where+ runGet' g = runGet g . BL.fromChunks . return++ take64 :: Int64 -> Decoder p [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)++-- | Encode a frame+encodeFrameHybi10 :: Encoder p Frame+encodeFrameHybi10 mask f = B.fromWord8 byte0 `mappend`+ B.fromWord8 byte1 `mappend` len `mappend` maskbytes `mappend`+ B.fromLazyByteString (maskPayload mask (framePayload f))+ where+ byte0 = fin .|. opcode+ fin = if frameFin f then 0x80 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'))+++handshakeHybi10 :: RequestHttpPart -> Decoder p (Either HandshakeError Request)+handshakeHybi10 reqHttp@(RequestHttpPart path h) = return $ do+ case getHeader "Sec-WebSocket-Version" of+ Right "8" -> return ()+ _ -> throwError NotSupported+ key <- getHeader "Sec-WebSocket-Key"+ let hash = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid+ let encoded = B64.encode hash+ return $ Request path h $ response101 [("Sec-WebSocket-Accept", encoded)] ""+ 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 -> throwError $+ MalformedRequest reqHttp $ + "Header missing: " ++ BC.unpack (CI.original k)
+ src/Network/WebSockets/Protocol/Hybi17.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE ExistentialQuantification #-}+module Network.WebSockets.Protocol.Hybi17+ ( Hybi17+ ) where++import Network.WebSockets.Protocol+import Network.WebSockets.Protocol.Hybi10.Internal+import Network.WebSockets.Protocol.Hybi17.Internal++data Hybi17 = forall p. Protocol p => Hybi17 p++instance Protocol Hybi17 where+ version (Hybi17 p) = version p+ headerVersion (Hybi17 p) = headerVersion p+ encodeFrame (Hybi17 p) = encodeFrame p+ decodeFrame (Hybi17 p) = decodeFrame p+ finishRequest (Hybi17 p) = finishRequest p+ implementations = [Hybi17 Hybi17_, Hybi17 Hybi10_]++instance TextProtocol Hybi17+instance BinaryProtocol Hybi17
+ src/Network/WebSockets/Protocol/Hybi17/Internal.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Protocol.Hybi17.Internal+ ( Hybi17_ (..)+ ) where++import Network.WebSockets.Protocol+import Network.WebSockets.Protocol.Hybi10.Internal++data Hybi17_ = Hybi17_++instance Protocol Hybi17_ where+ version Hybi17_ = "hybi17"+ headerVersion Hybi17_ = "13"+ encodeFrame Hybi17_ = encodeFrame Hybi10_+ decodeFrame Hybi17_ = decodeFrame Hybi10_+ finishRequest Hybi17_ = finishRequest Hybi10_+ implementations = [Hybi17_]++instance TextProtocol Hybi17_+instance BinaryProtocol Hybi17_
websockets.cabal view
@@ -1,5 +1,5 @@ Name: websockets-Version: 0.4.0.0+Version: 0.4.0.1 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell.@@ -55,21 +55,25 @@ Network.WebSockets.Monad Network.WebSockets.Protocol Network.WebSockets.Protocol.Hybi00+ Network.WebSockets.Protocol.Hybi00.Internal Network.WebSockets.Protocol.Hybi10+ Network.WebSockets.Protocol.Hybi10.Internal+ Network.WebSockets.Protocol.Hybi17+ Network.WebSockets.Protocol.Hybi17.Internal Network.WebSockets.Protocol.Unsafe Network.WebSockets.Socket Network.WebSockets.Types Build-depends:- attoparsec >= 0.9 && < 0.10,- attoparsec-enumerator >= 0.2 && < 0.3,+ attoparsec >= 0.9 && < 0.11,+ attoparsec-enumerator >= 0.2 && < 0.4, base >= 4 && < 5, base64-bytestring >= 0.1 && < 0.2, binary >= 0.5 && < 0.6, blaze-builder >= 0.3 && < 0.4, blaze-builder-enumerator >= 0.2 && < 0.3, bytestring >= 0.9 && < 0.10,- case-insensitive >= 0.3 && < 0.4,+ case-insensitive >= 0.3 && < 0.5, containers >= 0.3 && < 0.5, enumerator >= 0.4.13 && < 0.5, mtl >= 2.0 && < 2.2,