{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wall #-}
module Network.Http.Client.WebSocket
(
WSFrameHdr(..)
, wsFrameHdrSize
, wsFrameHdrToBuilder
, WSOpcode(..)
, WSOpcodeReserved(..)
, wsIsDataFrame
, writeWSFrame
, sendWSFragData
, readWSFrame
, receiveWSFrame
, wsUpgradeConnection
, SecWebSocketKey
, wsKeyToAcceptB64
, secWebSocketKeyFromB64
, secWebSocketKeyToB64
, secWebSocketKeyFromWords
, WsException(..)
) where
import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder as Builder
import Control.Exception
import Control.Monad (unless, when)
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Data.Binary as Bin
import qualified Data.Binary.Get as Bin
import qualified Data.Binary.Put as Bin
import Data.Bits
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI
import Data.IORef
import Data.Maybe (isJust)
import Data.Monoid (Monoid (..))
import Data.Word
import Data.XOR (xor32LazyByteString, xor32StrictByteString')
import Network.Http.Client as HC
import qualified Network.Http.Connection as HC
import System.IO.Streams (InputStream, OutputStream)
import qualified System.IO.Streams as Streams
data WsException = WsException String
deriving (Int -> WsException -> ShowS
[WsException] -> ShowS
WsException -> [Char]
(Int -> WsException -> ShowS)
-> (WsException -> [Char])
-> ([WsException] -> ShowS)
-> Show WsException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WsException -> ShowS
showsPrec :: Int -> WsException -> ShowS
$cshow :: WsException -> [Char]
show :: WsException -> [Char]
$cshowList :: [WsException] -> ShowS
showList :: [WsException] -> ShowS
Show)
instance Exception WsException
data WSFrameHdr = WSFrameHdr
{ WSFrameHdr -> Bool
ws'FIN :: !Bool
, WSFrameHdr -> Bool
ws'RSV1 :: !Bool
, WSFrameHdr -> Bool
ws'RSV2 :: !Bool
, WSFrameHdr -> Bool
ws'RSV3 :: !Bool
, WSFrameHdr -> WSOpcode
ws'opcode :: !WSOpcode
, WSFrameHdr -> Word64
ws'length :: !Word64
, WSFrameHdr -> Maybe Word32
ws'mask :: !(Maybe Word32)
} deriving Int -> WSFrameHdr -> ShowS
[WSFrameHdr] -> ShowS
WSFrameHdr -> [Char]
(Int -> WSFrameHdr -> ShowS)
-> (WSFrameHdr -> [Char])
-> ([WSFrameHdr] -> ShowS)
-> Show WSFrameHdr
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WSFrameHdr -> ShowS
showsPrec :: Int -> WSFrameHdr -> ShowS
$cshow :: WSFrameHdr -> [Char]
show :: WSFrameHdr -> [Char]
$cshowList :: [WSFrameHdr] -> ShowS
showList :: [WSFrameHdr] -> ShowS
Show
wsFrameHdrSize :: WSFrameHdr -> Int
wsFrameHdrSize :: WSFrameHdr -> Int
wsFrameHdrSize WSFrameHdr{ws'mask :: WSFrameHdr -> Maybe Word32
ws'mask = Maybe Word32
Nothing, Word64
ws'length :: WSFrameHdr -> Word64
ws'length :: Word64
ws'length}
| Word64
ws'length Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
126 = Int
2
| Word64
ws'length Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
0xffff = Int
4
| Bool
otherwise = Int
10
wsFrameHdrSize WSFrameHdr{ws'mask :: WSFrameHdr -> Maybe Word32
ws'mask = Just Word32
_, Word64
ws'length :: WSFrameHdr -> Word64
ws'length :: Word64
ws'length}
| Word64
ws'length Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
126 = Int
6
| Word64
ws'length Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
0xffff = Int
8
| Bool
otherwise = Int
14
readWSFrameHdr :: Connection -> IO (Maybe WSFrameHdr)
readWSFrameHdr :: Connection -> IO (Maybe WSFrameHdr)
readWSFrameHdr (HC.Connection { cIn :: Connection -> InputStream ByteString
cIn = InputStream ByteString
is }) = do
mchunk <- InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
is
case mchunk of
Maybe ByteString
Nothing -> Maybe WSFrameHdr -> IO (Maybe WSFrameHdr)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe WSFrameHdr
forall a. Maybe a
Nothing
Just ByteString
chunk -> Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
go (Decoder WSFrameHdr -> IO (Maybe WSFrameHdr))
-> Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
forall a b. (a -> b) -> a -> b
$ (if ByteString -> Bool
BS.null ByteString
chunk then Decoder WSFrameHdr -> Decoder WSFrameHdr
forall a. a -> a
id else (Decoder WSFrameHdr -> ByteString -> Decoder WSFrameHdr)
-> ByteString -> Decoder WSFrameHdr -> Decoder WSFrameHdr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Decoder WSFrameHdr -> ByteString -> Decoder WSFrameHdr
forall a. Decoder a -> ByteString -> Decoder a
Bin.pushChunk ByteString
chunk)
(Decoder WSFrameHdr -> Decoder WSFrameHdr)
-> Decoder WSFrameHdr -> Decoder WSFrameHdr
forall a b. (a -> b) -> a -> b
$ Get WSFrameHdr -> Decoder WSFrameHdr
forall a. Get a -> Decoder a
Bin.runGetIncremental Get WSFrameHdr
forall t. Binary t => Get t
Bin.get
where
go :: Bin.Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
go :: Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
go (Bin.Fail ByteString
rest ByteOffset
_ [Char]
err) = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
rest) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
ByteString -> InputStream ByteString -> IO ()
forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
rest InputStream ByteString
is
WsException -> IO (Maybe WSFrameHdr)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (WsException -> IO (Maybe WSFrameHdr))
-> WsException -> IO (Maybe WSFrameHdr)
forall a b. (a -> b) -> a -> b
$ [Char] -> WsException
WsException ([Char]
"readWSFrameHdr: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
err)
go partial :: Decoder WSFrameHdr
partial@(Bin.Partial Maybe ByteString -> Decoder WSFrameHdr
cont) = do
mchunk <- InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
is
case mchunk of
Maybe ByteString
Nothing -> Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
go (Maybe ByteString -> Decoder WSFrameHdr
cont Maybe ByteString
forall a. Maybe a
Nothing)
Just ByteString
chunk
| ByteString -> Bool
BS.null ByteString
chunk -> Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
go Decoder WSFrameHdr
partial
| Bool
otherwise -> Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
go (Maybe ByteString -> Decoder WSFrameHdr
cont (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
chunk))
go (Bin.Done ByteString
rest ByteOffset
_ WSFrameHdr
x) = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
rest) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
ByteString -> InputStream ByteString -> IO ()
forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
rest InputStream ByteString
is
Maybe WSFrameHdr -> IO (Maybe WSFrameHdr)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WSFrameHdr -> Maybe WSFrameHdr
forall a. a -> Maybe a
Just WSFrameHdr
x)
receiveWSFrame :: Connection -> (WSFrameHdr -> InputStream ByteString -> IO a) -> IO (Maybe a)
receiveWSFrame :: forall a.
Connection
-> (WSFrameHdr -> InputStream ByteString -> IO a) -> IO (Maybe a)
receiveWSFrame (conn :: Connection
conn@HC.Connection { cIn :: Connection -> InputStream ByteString
cIn = InputStream ByteString
is }) WSFrameHdr -> InputStream ByteString -> IO a
cont = do
mhdr <- Connection -> IO (Maybe WSFrameHdr)
readWSFrameHdr Connection
conn
case mhdr of
Maybe WSFrameHdr
Nothing -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
Just WSFrameHdr
hdr
| WSFrameHdr -> Word64
ws'length WSFrameHdr
hdr Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 -> do
is' <- IO (InputStream ByteString)
forall a. IO (InputStream a)
Streams.nullInput
Just `fmap` cont hdr is'
| Bool
otherwise -> do
is' <- ByteOffset -> InputStream ByteString -> IO (InputStream ByteString)
Streams.takeExactly (Word64 -> ByteOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WSFrameHdr -> Word64
ws'length WSFrameHdr
hdr)) InputStream ByteString
is
is'' <- xor32InputStream (maybe 0 id (ws'mask hdr)) is'
res <- cont hdr is''
Streams.skipToEof is'
return $! Just $! res
sendWSFragData :: Connection -> WSFrameHdr -> (OutputStream ByteString -> IO a) -> IO a
sendWSFragData :: forall a.
Connection
-> WSFrameHdr -> (OutputStream ByteString -> IO a) -> IO a
sendWSFragData Connection
_ WSFrameHdr
hdr0 OutputStream ByteString -> IO a
_
| Bool -> Bool
not (WSOpcode -> Bool
wsIsDataFrame (WSFrameHdr -> WSOpcode
ws'opcode WSFrameHdr
hdr0))
= WsException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ([Char] -> WsException
WsException [Char]
"sendWSFragData: sending control-frame requested")
| WSFrameHdr -> WSOpcode
ws'opcode WSFrameHdr
hdr0 WSOpcode -> WSOpcode -> Bool
forall a. Eq a => a -> a -> Bool
== WSOpcode
WSOpcode'Continuation
= WsException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ([Char] -> WsException
WsException [Char]
"sendWSFragData: sending continuation frame requested")
sendWSFragData (HC.Connection { cOut :: Connection -> OutputStream Builder
cOut = OutputStream Builder
os }) WSFrameHdr
hdr0 OutputStream ByteString -> IO a
cont = do
opcodeRef <- WSOpcode -> IO (IORef WSOpcode)
forall a. a -> IO (IORef a)
newIORef (WSFrameHdr -> WSOpcode
ws'opcode WSFrameHdr
hdr0)
let go Maybe ByteString
Nothing = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go (Just ByteString
chunk)
| ByteString -> Bool
BS.null ByteString
chunk = Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
Builder.flush) OutputStream Builder
os
| Bool
otherwise = do
let (Word32
_,ByteString
chunk') = Word32 -> ByteString -> (Word32, ByteString)
xor32StrictByteString' (Word32 -> (Word32 -> Word32) -> Maybe Word32 -> Word32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word32
0 Word32 -> Word32
forall a. a -> a
id (Maybe Word32 -> Word32) -> Maybe Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ WSFrameHdr -> Maybe Word32
ws'mask WSFrameHdr
hdr0) ByteString
chunk
opcode <- IORef WSOpcode -> IO WSOpcode
forall a. IORef a -> IO a
readIORef IORef WSOpcode
opcodeRef
writeIORef opcodeRef WSOpcode'Continuation
let fraghdr = WSFrameHdr
hdr0 { ws'FIN = False
, ws'length = fromIntegral (BS.length chunk)
, ws'opcode = opcode
}
Streams.write (Just $! wsFrameHdrToBuilder fraghdr `mappend` Builder.fromByteString chunk') os
os' <- Streams.makeOutputStream go
!res <- cont os'
opcode <- readIORef opcodeRef
let final = (WSFrameHdr
hdr0 { ws'FIN = True
, ws'length = 0
, ws'opcode = opcode
, ws'mask = Just 0
})
Streams.write (Just $ wsFrameHdrToBuilder final `mappend` Builder.flush) os
return $! res
writeWSFrame :: Connection -> WSOpcode -> Maybe Word32 -> BL.ByteString -> IO ()
writeWSFrame :: Connection -> WSOpcode -> Maybe Word32 -> ByteString -> IO ()
writeWSFrame (HC.Connection { cOut :: Connection -> OutputStream Builder
cOut = OutputStream Builder
os }) WSOpcode
opcode Maybe Word32
mmask ByteString
payload = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (WSOpcode -> Bool
wsIsDataFrame WSOpcode
opcode) Bool -> Bool -> Bool
&& Word64
plen Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
126) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
WsException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ([Char] -> WsException
WsException [Char]
"writeWSFrame: over-sized control-frame")
let hdr :: Builder
hdr = WSFrameHdr -> Builder
wsFrameHdrToBuilder (Bool
-> Bool
-> Bool
-> Bool
-> WSOpcode
-> Word64
-> Maybe Word32
-> WSFrameHdr
WSFrameHdr Bool
True Bool
False Bool
False Bool
False WSOpcode
opcode Word64
plen Maybe Word32
mmask)
dat :: Builder
dat = case Maybe Word32
mmask of
Maybe Word32
Nothing -> ByteString -> Builder
Builder.fromLazyByteString ByteString
payload
Just Word32
0 -> ByteString -> Builder
Builder.fromLazyByteString ByteString
payload
Just Word32
msk -> ByteString -> Builder
Builder.fromLazyByteString (Word32 -> ByteString -> ByteString
xor32LazyByteString Word32
msk ByteString
payload)
Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ Builder
hdr Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
dat Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
Builder.flush) OutputStream Builder
os
where
plen :: Word64
plen = ByteOffset -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> ByteOffset
BL.length ByteString
payload)
readWSFrame :: Int -> Connection -> IO (Maybe (WSFrameHdr,ByteString))
readWSFrame :: Int -> Connection -> IO (Maybe (WSFrameHdr, ByteString))
readWSFrame Int
maxSize (conn :: Connection
conn@HC.Connection { cIn :: Connection -> InputStream ByteString
cIn = InputStream ByteString
is }) = do
mhdr <- Connection -> IO (Maybe WSFrameHdr)
readWSFrameHdr Connection
conn
case mhdr of
Maybe WSFrameHdr
Nothing -> Maybe (WSFrameHdr, ByteString)
-> IO (Maybe (WSFrameHdr, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (WSFrameHdr, ByteString)
forall a. Maybe a
Nothing
Just WSFrameHdr
hdr
| WSFrameHdr -> Word64
ws'length WSFrameHdr
hdr Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 ->
Maybe (WSFrameHdr, ByteString)
-> IO (Maybe (WSFrameHdr, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (WSFrameHdr, ByteString)
-> IO (Maybe (WSFrameHdr, ByteString)))
-> Maybe (WSFrameHdr, ByteString)
-> IO (Maybe (WSFrameHdr, ByteString))
forall a b. (a -> b) -> a -> b
$ (WSFrameHdr, ByteString) -> Maybe (WSFrameHdr, ByteString)
forall a. a -> Maybe a
Just (WSFrameHdr
hdr,ByteString
BS.empty)
| WSFrameHdr -> Word64
ws'length WSFrameHdr
hdr Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxSize ->
WsException -> IO (Maybe (WSFrameHdr, ByteString))
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ([Char] -> WsException
WsException [Char]
"readWSFrame: frame larger than maxSize")
| Bool
otherwise -> do
dat <- Int -> InputStream ByteString -> IO ByteString
Streams.readExactly (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WSFrameHdr -> Word64
ws'length WSFrameHdr
hdr)) InputStream ByteString
is
let dat' = case WSFrameHdr -> Maybe Word32
ws'mask WSFrameHdr
hdr of
Maybe Word32
Nothing -> ByteString
dat
Just Word32
0 -> ByteString
dat
Just Word32
m -> (Word32, ByteString) -> ByteString
forall a b. (a, b) -> b
snd (Word32 -> ByteString -> (Word32, ByteString)
xor32StrictByteString' Word32
m ByteString
dat)
return $ Just (hdr,dat')
wsFrameHdrToBuilder :: WSFrameHdr -> Builder
wsFrameHdrToBuilder :: WSFrameHdr -> Builder
wsFrameHdrToBuilder WSFrameHdr{Bool
Maybe Word32
Word64
WSOpcode
ws'FIN :: WSFrameHdr -> Bool
ws'RSV1 :: WSFrameHdr -> Bool
ws'RSV2 :: WSFrameHdr -> Bool
ws'RSV3 :: WSFrameHdr -> Bool
ws'opcode :: WSFrameHdr -> WSOpcode
ws'length :: WSFrameHdr -> Word64
ws'mask :: WSFrameHdr -> Maybe Word32
ws'FIN :: Bool
ws'RSV1 :: Bool
ws'RSV2 :: Bool
ws'RSV3 :: Bool
ws'opcode :: WSOpcode
ws'length :: Word64
ws'mask :: Maybe Word32
..} = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ Word8 -> Builder
Builder.fromWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$!
(if Bool
ws'FIN then Word8
0x80 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
(if Bool
ws'RSV1 then Word8
0x40 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
(if Bool
ws'RSV2 then Word8
0x20 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
(if Bool
ws'RSV3 then Word8
0x10 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
(WSOpcode -> Word8
encodeWSOpcode WSOpcode
ws'opcode)
, Word8 -> Builder
Builder.fromWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$!
(if Maybe Word32 -> Bool
forall a. Maybe a -> Bool
isJust Maybe Word32
ws'mask then Word8
0x80 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
len7
, case Word8
len7 of
Word8
126 -> Word16 -> Builder
Builder.fromWord16be (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ws'length)
Word8
127 -> Word64 -> Builder
Builder.fromWord64be Word64
ws'length
Word8
_ -> Builder
forall a. Monoid a => a
Data.Monoid.mempty
, Builder -> (Word32 -> Builder) -> Maybe Word32 -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty Word32 -> Builder
Builder.fromWord32be Maybe Word32
ws'mask
]
where
len7 :: Word8
len7 | Word64
ws'length Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
126 = Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ws'length
| Word64
ws'length Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
0xffff = Word8
126
| Bool
otherwise = Word8
127
instance Bin.Binary WSFrameHdr where
put :: WSFrameHdr -> Put
put WSFrameHdr{Bool
Maybe Word32
Word64
WSOpcode
ws'FIN :: WSFrameHdr -> Bool
ws'RSV1 :: WSFrameHdr -> Bool
ws'RSV2 :: WSFrameHdr -> Bool
ws'RSV3 :: WSFrameHdr -> Bool
ws'opcode :: WSFrameHdr -> WSOpcode
ws'length :: WSFrameHdr -> Word64
ws'mask :: WSFrameHdr -> Maybe Word32
ws'FIN :: Bool
ws'RSV1 :: Bool
ws'RSV2 :: Bool
ws'RSV3 :: Bool
ws'opcode :: WSOpcode
ws'length :: Word64
ws'mask :: Maybe Word32
..} = do
Word8 -> Put
Bin.putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$!
(if Bool
ws'FIN then Word8
0x80 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
(if Bool
ws'RSV1 then Word8
0x40 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
(if Bool
ws'RSV2 then Word8
0x20 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
(if Bool
ws'RSV3 then Word8
0x10 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
(WSOpcode -> Word8
encodeWSOpcode WSOpcode
ws'opcode)
Word8 -> Put
Bin.putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$!
(if Maybe Word32 -> Bool
forall a. Maybe a -> Bool
isJust Maybe Word32
ws'mask then Word8
0x80 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
len7
case Word8
len7 of
Word8
126 -> Word16 -> Put
Bin.putWord16be (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ws'length)
Word8
127 -> Word64 -> Put
Bin.putWord64be Word64
ws'length
Word8
_ -> () -> Put
forall a. a -> PutM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Put -> (Word32 -> Put) -> Maybe Word32 -> Put
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Put
forall a. a -> PutM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Word32 -> Put
Bin.putWord32be Maybe Word32
ws'mask
where
len7 :: Word8
len7 | Word64
ws'length Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
126 = Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ws'length
| Word64
ws'length Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
0xffff = Word8
126
| Bool
otherwise = Word8
127
get :: Get WSFrameHdr
get = do
o0 <- Get Word8
Bin.getWord8
let ws'FIN = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
o0 Int
7
ws'RSV1 = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
o0 Int
6
ws'RSV2 = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
o0 Int
5
ws'RSV3 = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
o0 Int
4
ws'opcode = Word8 -> WSOpcode
decodeWSOpcode Word8
o0
when (not ws'FIN && not (wsIsDataFrame ws'opcode)) $
fail "invalid fragmented control-frame"
o1 <- Bin.getWord8
let len7 = Word8
o1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7f
msk = Word8
o1 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0x80
ws'length <- case len7 of
Word8
127 -> do
Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WSOpcode -> Bool
wsIsDataFrame WSOpcode
ws'opcode) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Get ()
forall a. [Char] -> Get a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"invalid 64-bit extended length (control-frame)"
v <- Get Word64
Bin.getWord64be
unless (v > 0xffff) $ fail "invalid 64-bit extended length (<= 0xffff)"
unless (v < 0x8000000000000000) $ fail "invalid 64-bit extended length (MSB set)"
return v
Word8
126 -> do
Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WSOpcode -> Bool
wsIsDataFrame WSOpcode
ws'opcode) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Get ()
forall a. [Char] -> Get a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"invalid 16-bit extended length (control-frame)"
v <- Get Word16
Bin.getWord16be
unless (v > 125) $ fail "invalid 16-bit extended length (<= 0x7d)"
return (fromIntegral v)
Word8
_ -> Word64 -> Get Word64
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
len7)
ws'mask <- if msk
then Just `fmap` Bin.getWord32be
else return Nothing
return WSFrameHdr{..}
data WSOpcode
= WSOpcode'Continuation
| WSOpcode'Text
| WSOpcode'Binary
| WSOpcode'Close
| WSOpcode'Ping
| WSOpcode'Pong
| WSOpcode'Reserved !WSOpcodeReserved
deriving (WSOpcode -> WSOpcode -> Bool
(WSOpcode -> WSOpcode -> Bool)
-> (WSOpcode -> WSOpcode -> Bool) -> Eq WSOpcode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WSOpcode -> WSOpcode -> Bool
== :: WSOpcode -> WSOpcode -> Bool
$c/= :: WSOpcode -> WSOpcode -> Bool
/= :: WSOpcode -> WSOpcode -> Bool
Eq,Int -> WSOpcode -> ShowS
[WSOpcode] -> ShowS
WSOpcode -> [Char]
(Int -> WSOpcode -> ShowS)
-> (WSOpcode -> [Char]) -> ([WSOpcode] -> ShowS) -> Show WSOpcode
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WSOpcode -> ShowS
showsPrec :: Int -> WSOpcode -> ShowS
$cshow :: WSOpcode -> [Char]
show :: WSOpcode -> [Char]
$cshowList :: [WSOpcode] -> ShowS
showList :: [WSOpcode] -> ShowS
Show)
data WSOpcodeReserved
= WSOpcode'Reserved3
| WSOpcode'Reserved4
| WSOpcode'Reserved5
| WSOpcode'Reserved6
| WSOpcode'Reserved7
| WSOpcode'Reserved11
| WSOpcode'Reserved12
| WSOpcode'Reserved13
| WSOpcode'Reserved14
| WSOpcode'Reserved15
deriving (WSOpcodeReserved -> WSOpcodeReserved -> Bool
(WSOpcodeReserved -> WSOpcodeReserved -> Bool)
-> (WSOpcodeReserved -> WSOpcodeReserved -> Bool)
-> Eq WSOpcodeReserved
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WSOpcodeReserved -> WSOpcodeReserved -> Bool
== :: WSOpcodeReserved -> WSOpcodeReserved -> Bool
$c/= :: WSOpcodeReserved -> WSOpcodeReserved -> Bool
/= :: WSOpcodeReserved -> WSOpcodeReserved -> Bool
Eq,Int -> WSOpcodeReserved -> ShowS
[WSOpcodeReserved] -> ShowS
WSOpcodeReserved -> [Char]
(Int -> WSOpcodeReserved -> ShowS)
-> (WSOpcodeReserved -> [Char])
-> ([WSOpcodeReserved] -> ShowS)
-> Show WSOpcodeReserved
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WSOpcodeReserved -> ShowS
showsPrec :: Int -> WSOpcodeReserved -> ShowS
$cshow :: WSOpcodeReserved -> [Char]
show :: WSOpcodeReserved -> [Char]
$cshowList :: [WSOpcodeReserved] -> ShowS
showList :: [WSOpcodeReserved] -> ShowS
Show)
wsIsDataFrame :: WSOpcode -> Bool
wsIsDataFrame :: WSOpcode -> Bool
wsIsDataFrame WSOpcode
x = case WSOpcode
x of
WSOpcode
WSOpcode'Continuation -> Bool
True
WSOpcode
WSOpcode'Text -> Bool
True
WSOpcode
WSOpcode'Binary -> Bool
True
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved3 -> Bool
True
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved4 -> Bool
True
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved5 -> Bool
True
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved6 -> Bool
True
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved7 -> Bool
True
WSOpcode
WSOpcode'Close -> Bool
False
WSOpcode
WSOpcode'Ping -> Bool
False
WSOpcode
WSOpcode'Pong -> Bool
False
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved11 -> Bool
False
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved12 -> Bool
False
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved13 -> Bool
False
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved14 -> Bool
False
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved15 -> Bool
False
decodeWSOpcode :: Word8 -> WSOpcode
decodeWSOpcode :: Word8 -> WSOpcode
decodeWSOpcode Word8
x = case Word8
x Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xf of
Word8
0x0 -> WSOpcode
WSOpcode'Continuation
Word8
0x1 -> WSOpcode
WSOpcode'Text
Word8
0x2 -> WSOpcode
WSOpcode'Binary
Word8
0x3 -> WSOpcodeReserved -> WSOpcode
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved3
Word8
0x4 -> WSOpcodeReserved -> WSOpcode
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved4
Word8
0x5 -> WSOpcodeReserved -> WSOpcode
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved5
Word8
0x6 -> WSOpcodeReserved -> WSOpcode
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved6
Word8
0x7 -> WSOpcodeReserved -> WSOpcode
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved7
Word8
0x8 -> WSOpcode
WSOpcode'Close
Word8
0x9 -> WSOpcode
WSOpcode'Ping
Word8
0xA -> WSOpcode
WSOpcode'Pong
Word8
0xB -> WSOpcodeReserved -> WSOpcode
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved11
Word8
0xC -> WSOpcodeReserved -> WSOpcode
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved12
Word8
0xD -> WSOpcodeReserved -> WSOpcode
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved13
Word8
0xE -> WSOpcodeReserved -> WSOpcode
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved14
Word8
0xF -> WSOpcodeReserved -> WSOpcode
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved15
Word8
_ -> WSOpcode
forall a. HasCallStack => a
undefined
encodeWSOpcode :: WSOpcode -> Word8
encodeWSOpcode :: WSOpcode -> Word8
encodeWSOpcode WSOpcode
x = case WSOpcode
x of
WSOpcode
WSOpcode'Continuation -> Word8
0x0
WSOpcode
WSOpcode'Text -> Word8
0x1
WSOpcode
WSOpcode'Binary -> Word8
0x2
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved3 -> Word8
0x3
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved4 -> Word8
0x4
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved5 -> Word8
0x5
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved6 -> Word8
0x6
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved7 -> Word8
0x7
WSOpcode
WSOpcode'Close -> Word8
0x8
WSOpcode
WSOpcode'Ping -> Word8
0x9
WSOpcode
WSOpcode'Pong -> Word8
0xA
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved11 -> Word8
0xB
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved12 -> Word8
0xC
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved13 -> Word8
0xD
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved14 -> Word8
0xE
WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved15 -> Word8
0xF
wsKeyToAcceptB64 :: SecWebSocketKey -> ByteString
wsKeyToAcceptB64 :: SecWebSocketKey -> ByteString
wsKeyToAcceptB64 SecWebSocketKey
key = ByteString -> ByteString
B64.encode (ByteString -> ByteString
SHA1.hash (SecWebSocketKey -> ByteString
secWebSocketKeyToB64 SecWebSocketKey
key ByteString -> ByteString -> ByteString
`BS.append` ByteString
rfc6455Guid))
where
rfc6455Guid :: ByteString
rfc6455Guid :: ByteString
rfc6455Guid = ByteString
"258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
newtype SecWebSocketKey = WSKey ByteString deriving (SecWebSocketKey -> SecWebSocketKey -> Bool
(SecWebSocketKey -> SecWebSocketKey -> Bool)
-> (SecWebSocketKey -> SecWebSocketKey -> Bool)
-> Eq SecWebSocketKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SecWebSocketKey -> SecWebSocketKey -> Bool
== :: SecWebSocketKey -> SecWebSocketKey -> Bool
$c/= :: SecWebSocketKey -> SecWebSocketKey -> Bool
/= :: SecWebSocketKey -> SecWebSocketKey -> Bool
Eq,Eq SecWebSocketKey
Eq SecWebSocketKey =>
(SecWebSocketKey -> SecWebSocketKey -> Ordering)
-> (SecWebSocketKey -> SecWebSocketKey -> Bool)
-> (SecWebSocketKey -> SecWebSocketKey -> Bool)
-> (SecWebSocketKey -> SecWebSocketKey -> Bool)
-> (SecWebSocketKey -> SecWebSocketKey -> Bool)
-> (SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey)
-> (SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey)
-> Ord SecWebSocketKey
SecWebSocketKey -> SecWebSocketKey -> Bool
SecWebSocketKey -> SecWebSocketKey -> Ordering
SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SecWebSocketKey -> SecWebSocketKey -> Ordering
compare :: SecWebSocketKey -> SecWebSocketKey -> Ordering
$c< :: SecWebSocketKey -> SecWebSocketKey -> Bool
< :: SecWebSocketKey -> SecWebSocketKey -> Bool
$c<= :: SecWebSocketKey -> SecWebSocketKey -> Bool
<= :: SecWebSocketKey -> SecWebSocketKey -> Bool
$c> :: SecWebSocketKey -> SecWebSocketKey -> Bool
> :: SecWebSocketKey -> SecWebSocketKey -> Bool
$c>= :: SecWebSocketKey -> SecWebSocketKey -> Bool
>= :: SecWebSocketKey -> SecWebSocketKey -> Bool
$cmax :: SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey
max :: SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey
$cmin :: SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey
min :: SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey
Ord,Int -> SecWebSocketKey -> ShowS
[SecWebSocketKey] -> ShowS
SecWebSocketKey -> [Char]
(Int -> SecWebSocketKey -> ShowS)
-> (SecWebSocketKey -> [Char])
-> ([SecWebSocketKey] -> ShowS)
-> Show SecWebSocketKey
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SecWebSocketKey -> ShowS
showsPrec :: Int -> SecWebSocketKey -> ShowS
$cshow :: SecWebSocketKey -> [Char]
show :: SecWebSocketKey -> [Char]
$cshowList :: [SecWebSocketKey] -> ShowS
showList :: [SecWebSocketKey] -> ShowS
Show)
secWebSocketKeyFromB64 :: ByteString -> Maybe SecWebSocketKey
secWebSocketKeyFromB64 :: ByteString -> Maybe SecWebSocketKey
secWebSocketKeyFromB64 ByteString
key
| ByteString -> Int
BS.length ByteString
key' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
24 = Maybe SecWebSocketKey
forall a. Maybe a
Nothing
| Left [Char]
_ <- ByteString -> Either [Char] ByteString
B64.decode ByteString
key' = Maybe SecWebSocketKey
forall a. Maybe a
Nothing
| Bool
otherwise = SecWebSocketKey -> Maybe SecWebSocketKey
forall a. a -> Maybe a
Just (SecWebSocketKey -> Maybe SecWebSocketKey)
-> SecWebSocketKey -> Maybe SecWebSocketKey
forall a b. (a -> b) -> a -> b
$! ByteString -> SecWebSocketKey
WSKey ByteString
key'
where
key' :: ByteString
key' = (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.spanEnd Word8 -> Bool
isOWS ((Word8 -> Bool) -> ByteString -> ByteString
BS.dropWhile Word8 -> Bool
isOWS ByteString
key))
isOWS :: Word8 -> Bool
isOWS :: Word8 -> Bool
isOWS Word8
0x09 = Bool
True
isOWS Word8
0x20 = Bool
True
isOWS Word8
_ = Bool
False
secWebSocketKeyToB64 :: SecWebSocketKey -> ByteString
secWebSocketKeyToB64 :: SecWebSocketKey -> ByteString
secWebSocketKeyToB64 (WSKey ByteString
bs) = ByteString
bs
secWebSocketKeyFromWords :: Word64 -> Word64 -> SecWebSocketKey
secWebSocketKeyFromWords :: Word64 -> Word64 -> SecWebSocketKey
secWebSocketKeyFromWords Word64
h Word64
l = ByteString -> SecWebSocketKey
WSKey (ByteString -> ByteString
B64.encode ByteString
key)
where
key :: ByteString
key = [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BL.toChunks (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
Bin.runPut (Word64 -> Put
Bin.putWord64be Word64
h Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word64 -> Put
Bin.putWord64be Word64
l)
xor32InputStream :: Word32 -> InputStream ByteString -> IO (InputStream ByteString)
xor32InputStream :: Word32 -> InputStream ByteString -> IO (InputStream ByteString)
xor32InputStream Word32
0 InputStream ByteString
is = InputStream ByteString -> IO (InputStream ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InputStream ByteString
is
xor32InputStream Word32
msk0 InputStream ByteString
is = do
mskref <- Word32 -> IO (IORef Word32)
forall a. a -> IO (IORef a)
newIORef Word32
msk0
let go = do
mchunk <- InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
is
case mchunk of
Maybe ByteString
Nothing -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
Just ByteString
chunk -> do
msk <- IORef Word32 -> IO Word32
forall a. IORef a -> IO a
readIORef IORef Word32
mskref
let (msk',chunk') = xor32StrictByteString' msk chunk
writeIORef mskref msk'
return $! Just $! chunk'
Streams.makeInputStream go
wsUpgradeConnection :: Connection
-> ByteString
-> RequestBuilder α
-> SecWebSocketKey
-> (Response -> InputStream ByteString -> IO b)
-> (Response -> Connection -> IO b)
-> IO b
wsUpgradeConnection :: forall α b.
Connection
-> ByteString
-> RequestBuilder α
-> SecWebSocketKey
-> (Response -> InputStream ByteString -> IO b)
-> (Response -> Connection -> IO b)
-> IO b
wsUpgradeConnection Connection
conn ByteString
resource RequestBuilder α
rqmod SecWebSocketKey
wskey Response -> InputStream ByteString -> IO b
failedToUpgrade Response -> Connection -> IO b
success = do
let rqToWS :: Request
rqToWS = RequestBuilder α -> Request
forall α. RequestBuilder α -> Request
HC.buildRequest1 (RequestBuilder α -> Request) -> RequestBuilder α -> Request
forall a b. (a -> b) -> a -> b
$ do
Method -> ByteString -> RequestBuilder ()
HC.http Method
HC.GET ByteString
resource
ByteString -> ByteString -> RequestBuilder ()
HC.setHeader ByteString
"upgrade" ByteString
"websocket"
ByteString -> ByteString -> RequestBuilder ()
HC.setHeader ByteString
"connection" ByteString
"Upgrade"
ByteString -> ByteString -> RequestBuilder ()
HC.setHeader ByteString
"sec-websocket-version" ByteString
"13"
ByteString -> ByteString -> RequestBuilder ()
HC.setHeader ByteString
"sec-websocket-key" (SecWebSocketKey -> ByteString
secWebSocketKeyToB64 SecWebSocketKey
wskey)
RequestBuilder α
rqmod
Connection -> Request -> (OutputStream Builder -> IO ()) -> IO ()
forall α.
Connection -> Request -> (OutputStream Builder -> IO α) -> IO α
HC.sendRequest Connection
conn Request
rqToWS OutputStream Builder -> IO ()
HC.emptyBody
Connection
-> (Response -> InputStream ByteString -> IO b)
-> (Response
-> InputStream ByteString -> OutputStream Builder -> IO b)
-> IO b
forall a.
Connection
-> (Response -> InputStream ByteString -> IO a)
-> (Response
-> InputStream ByteString -> OutputStream Builder -> IO a)
-> IO a
HC.receiveUpgradeResponse Connection
conn Response -> InputStream ByteString -> IO b
failedToUpgrade ((Response
-> InputStream ByteString -> OutputStream Builder -> IO b)
-> IO b)
-> (Response
-> InputStream ByteString -> OutputStream Builder -> IO b)
-> IO b
forall a b. (a -> b) -> a -> b
$ \Response
resp InputStream ByteString
_is OutputStream Builder
_os -> do
case ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString)
-> Maybe ByteString -> Maybe (CI ByteString)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Response -> ByteString -> Maybe ByteString
HC.getHeader Response
resp ByteString
"connection" of
Maybe (CI ByteString)
Nothing -> [Char] -> IO ()
forall {a}. [Char] -> IO a
abort [Char]
"missing 'connection' header"
Just CI ByteString
"upgrade" -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just CI ByteString
_ -> [Char] -> IO ()
forall {a}. [Char] -> IO a
abort [Char]
"'connection' header has non-'upgrade' value"
case ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString)
-> Maybe ByteString -> Maybe (CI ByteString)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Response -> ByteString -> Maybe ByteString
HC.getHeader Response
resp ByteString
"upgrade" of
Maybe (CI ByteString)
Nothing -> [Char] -> IO ()
forall {a}. [Char] -> IO a
abort [Char]
"missing 'upgrade' header"
Just CI ByteString
"websocket" -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just CI ByteString
_ -> [Char] -> IO ()
forall {a}. [Char] -> IO a
abort [Char]
"'upgrade' header has non-'websocket' value"
case Response -> ByteString -> Maybe ByteString
HC.getHeader Response
resp ByteString
"sec-websocket-accept" of
Maybe ByteString
Nothing -> [Char] -> IO ()
forall {a}. [Char] -> IO a
abort [Char]
"missing 'sec-websocket-accept' header"
Just ByteString
wsacc
| ByteString
wsacc ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= SecWebSocketKey -> ByteString
wsKeyToAcceptB64 SecWebSocketKey
wskey -> [Char] -> IO ()
forall {a}. [Char] -> IO a
abort [Char]
"sec-websocket-accept header mismatch"
| Bool
otherwise -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Response -> Connection -> IO b
success Response
resp Connection
conn
where
abort :: [Char] -> IO a
abort [Char]
msg = WsException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ([Char] -> WsException
WsException ([Char]
"wsUpgradeConnection: "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
msg))