{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Hybi13
( headerVersions
, finishRequest
, finishResponse
, encodeMessage
, encodeMessages
, decodeMessages
, createRequest
, encodeFrame
, parseFrame
) where
import qualified Data.ByteString.Builder as B
import Control.Applicative (pure, (<$>))
import Control.Arrow (first)
import Control.Exception (throwIO)
import Control.Monad (forM, liftM, unless,
when)
import Data.Binary.Get (Get, getInt64be,
getLazyByteString,
getWord16be, getWord8)
import Data.Binary.Put (putWord16be, runPut)
import Data.Bits ((.&.), (.|.))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 ()
import qualified Data.ByteString.Lazy as BL
import Data.Digest.Pure.SHA (bytestringDigest, sha1)
import Data.IORef
import Data.Monoid (mappend, mconcat,
mempty)
import Data.Tuple (swap)
import System.Entropy as R
import System.Random (RandomGen, newStdGen)
import Network.WebSockets.Connection.Options
import Network.WebSockets.Http
import Network.WebSockets.Hybi13.Demultiplex
import Network.WebSockets.Hybi13.Mask
import Network.WebSockets.Stream (Stream)
import qualified Network.WebSockets.Stream as Stream
import Network.WebSockets.Types
headerVersions :: [ByteString]
= ["13"]
finishRequest :: RequestHead
-> Headers
-> Either HandshakeException Response
finishRequest :: RequestHead -> Headers -> Either HandshakeException Response
finishRequest reqHttp :: RequestHead
reqHttp headers :: Headers
headers = do
!ByteString
key <- RequestHead
-> CI ByteString -> Either HandshakeException ByteString
getRequestHeader RequestHead
reqHttp "Sec-WebSocket-Key"
let !hash :: ByteString
hash = ByteString -> ByteString
hashKey ByteString
key
!encoded :: ByteString
encoded = ByteString -> ByteString
B64.encode ByteString
hash
Response -> Either HandshakeException Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> Either HandshakeException Response)
-> Response -> Either HandshakeException Response
forall a b. (a -> b) -> a -> b
$ Headers -> ByteString -> Response
response101 (("Sec-WebSocket-Accept", ByteString
encoded)(CI ByteString, ByteString) -> Headers -> Headers
forall a. a -> [a] -> [a]
:Headers
headers) ""
finishResponse :: RequestHead
-> ResponseHead
-> Either HandshakeException Response
finishResponse :: RequestHead -> ResponseHead -> Either HandshakeException Response
finishResponse request :: RequestHead
request response :: ResponseHead
response = do
Bool
-> Either HandshakeException () -> Either HandshakeException ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ResponseHead -> Int
responseCode ResponseHead
response Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 101) (Either HandshakeException () -> Either HandshakeException ())
-> Either HandshakeException () -> Either HandshakeException ()
forall a b. (a -> b) -> a -> b
$ HandshakeException -> Either HandshakeException ()
forall a b. a -> Either a b
Left (HandshakeException -> Either HandshakeException ())
-> HandshakeException -> Either HandshakeException ()
forall a b. (a -> b) -> a -> b
$
ResponseHead -> String -> HandshakeException
MalformedResponse ResponseHead
response "Wrong response status or message."
ByteString
key <- RequestHead
-> CI ByteString -> Either HandshakeException ByteString
getRequestHeader RequestHead
request "Sec-WebSocket-Key"
ByteString
responseHash <- ResponseHead
-> CI ByteString -> Either HandshakeException ByteString
getResponseHeader ResponseHead
response "Sec-WebSocket-Accept"
let challengeHash :: ByteString
challengeHash = ByteString -> ByteString
B64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
hashKey ByteString
key
Bool
-> Either HandshakeException () -> Either HandshakeException ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
responseHash ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
challengeHash) (Either HandshakeException () -> Either HandshakeException ())
-> Either HandshakeException () -> Either HandshakeException ()
forall a b. (a -> b) -> a -> b
$ HandshakeException -> Either HandshakeException ()
forall a b. a -> Either a b
Left (HandshakeException -> Either HandshakeException ())
-> HandshakeException -> Either HandshakeException ()
forall a b. (a -> b) -> a -> b
$
ResponseHead -> String -> HandshakeException
MalformedResponse ResponseHead
response "Challenge and response hashes do not match."
Response -> Either HandshakeException Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> Either HandshakeException Response)
-> Response -> Either HandshakeException Response
forall a b. (a -> b) -> a -> b
$ ResponseHead -> ByteString -> Response
Response ResponseHead
response ""
encodeMessage :: RandomGen g => ConnectionType -> g -> Message -> (g, B.Builder)
encodeMessage :: ConnectionType -> g -> Message -> (g, Builder)
encodeMessage conType :: ConnectionType
conType gen :: g
gen msg :: Message
msg = (g
gen', Builder
builder)
where
mkFrame :: FrameType -> ByteString -> Frame
mkFrame = Bool -> Bool -> Bool -> Bool -> FrameType -> ByteString -> Frame
Frame Bool
True Bool
False Bool
False Bool
False
(mask :: Maybe Mask
mask, gen' :: g
gen') = case ConnectionType
conType of
ServerConnection -> (Maybe Mask
forall a. Maybe a
Nothing, g
gen)
ClientConnection -> (Mask -> Maybe Mask) -> (Mask, g) -> (Maybe Mask, g)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Mask -> Maybe Mask
forall a. a -> Maybe a
Just (g -> (Mask, g)
forall g. RandomGen g => g -> (Mask, g)
randomMask g
gen)
builder :: Builder
builder = Maybe Mask -> Frame -> Builder
encodeFrame Maybe Mask
mask (Frame -> Builder) -> Frame -> Builder
forall a b. (a -> b) -> a -> b
$ case Message
msg of
(ControlMessage (Close code :: Word16
code pl :: ByteString
pl)) -> FrameType -> ByteString -> Frame
mkFrame FrameType
CloseFrame (ByteString -> Frame) -> ByteString -> Frame
forall a b. (a -> b) -> a -> b
$
Put -> ByteString
runPut (Word16 -> Put
putWord16be Word16
code) ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
`mappend` ByteString
pl
(ControlMessage (Ping pl :: ByteString
pl)) -> FrameType -> ByteString -> Frame
mkFrame FrameType
PingFrame ByteString
pl
(ControlMessage (Pong pl :: ByteString
pl)) -> FrameType -> ByteString -> Frame
mkFrame FrameType
PongFrame ByteString
pl
(DataMessage rsv1 :: Bool
rsv1 rsv2 :: Bool
rsv2 rsv3 :: Bool
rsv3 (Text pl :: ByteString
pl _)) -> Bool -> Bool -> Bool -> Bool -> FrameType -> ByteString -> Frame
Frame Bool
True Bool
rsv1 Bool
rsv2 Bool
rsv3 FrameType
TextFrame ByteString
pl
(DataMessage rsv1 :: Bool
rsv1 rsv2 :: Bool
rsv2 rsv3 :: Bool
rsv3 (Binary pl :: ByteString
pl)) -> Bool -> Bool -> Bool -> Bool -> FrameType -> ByteString -> Frame
Frame Bool
True Bool
rsv1 Bool
rsv2 Bool
rsv3 FrameType
BinaryFrame ByteString
pl
encodeMessages
:: ConnectionType
-> Stream
-> IO ([Message] -> IO ())
encodeMessages :: ConnectionType -> Stream -> IO ([Message] -> IO ())
encodeMessages conType :: ConnectionType
conType stream :: Stream
stream = do
IORef StdGen
genRef <- StdGen -> IO (IORef StdGen)
forall a. a -> IO (IORef a)
newIORef (StdGen -> IO (IORef StdGen)) -> IO StdGen -> IO (IORef StdGen)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO StdGen
newStdGen
([Message] -> IO ()) -> IO ([Message] -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (([Message] -> IO ()) -> IO ([Message] -> IO ()))
-> ([Message] -> IO ()) -> IO ([Message] -> IO ())
forall a b. (a -> b) -> a -> b
$ \msgs :: [Message]
msgs -> do
[Builder]
builders <- [Message] -> (Message -> IO Builder) -> IO [Builder]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Message]
msgs ((Message -> IO Builder) -> IO [Builder])
-> (Message -> IO Builder) -> IO [Builder]
forall a b. (a -> b) -> a -> b
$ \msg :: Message
msg ->
IORef StdGen -> (StdGen -> (StdGen, Builder)) -> IO Builder
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef StdGen
genRef ((StdGen -> (StdGen, Builder)) -> IO Builder)
-> (StdGen -> (StdGen, Builder)) -> IO Builder
forall a b. (a -> b) -> a -> b
$ \s :: StdGen
s -> ConnectionType -> StdGen -> Message -> (StdGen, Builder)
forall g.
RandomGen g =>
ConnectionType -> g -> Message -> (g, Builder)
encodeMessage ConnectionType
conType StdGen
s Message
msg
Stream -> ByteString -> IO ()
Stream.write Stream
stream (Builder -> ByteString
B.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
builders)
encodeFrame :: Maybe Mask -> Frame -> B.Builder
encodeFrame :: Maybe Mask -> Frame -> Builder
encodeFrame mask :: Maybe Mask
mask f :: Frame
f = Word8 -> Builder
B.word8 Word8
byte0 Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
Word8 -> Builder
B.word8 Word8
byte1 Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
len Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
maskbytes Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
ByteString -> Builder
B.lazyByteString (Maybe Mask -> ByteString -> ByteString
maskPayload Maybe Mask
mask ByteString
payload)
where
byte0 :: Word8
byte0 = Word8
fin Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
rsv1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
rsv2 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
rsv3 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
opcode
fin :: Word8
fin = if Frame -> Bool
frameFin Frame
f then 0x80 else 0x00
rsv1 :: Word8
rsv1 = if Frame -> Bool
frameRsv1 Frame
f then 0x40 else 0x00
rsv2 :: Word8
rsv2 = if Frame -> Bool
frameRsv2 Frame
f then 0x20 else 0x00
rsv3 :: Word8
rsv3 = if Frame -> Bool
frameRsv3 Frame
f then 0x10 else 0x00
payload :: ByteString
payload = case Frame -> FrameType
frameType Frame
f of
ContinuationFrame -> Frame -> ByteString
framePayload Frame
f
TextFrame -> Frame -> ByteString
framePayload Frame
f
BinaryFrame -> Frame -> ByteString
framePayload Frame
f
CloseFrame -> Int64 -> ByteString -> ByteString
BL.take 125 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Frame -> ByteString
framePayload Frame
f
PingFrame -> Int64 -> ByteString -> ByteString
BL.take 125 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Frame -> ByteString
framePayload Frame
f
PongFrame -> Int64 -> ByteString -> ByteString
BL.take 125 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Frame -> ByteString
framePayload Frame
f
opcode :: Word8
opcode = case Frame -> FrameType
frameType Frame
f of
ContinuationFrame -> 0x00
TextFrame -> 0x01
BinaryFrame -> 0x02
CloseFrame -> 0x08
PingFrame -> 0x09
PongFrame -> 0x0a
(maskflag :: Word8
maskflag, maskbytes :: Builder
maskbytes) = case Maybe Mask
mask of
Nothing -> (0x00, Builder
forall a. Monoid a => a
mempty)
Just m :: Mask
m -> (0x80, Mask -> Builder
encodeMask Mask
m)
byte1 :: Word8
byte1 = Word8
maskflag Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
lenflag
len' :: Int64
len' = ByteString -> Int64
BL.length ByteString
payload
(lenflag :: Word8
lenflag, len :: Builder
len)
| Int64
len' Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< 126 = (Int64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len', Builder
forall a. Monoid a => a
mempty)
| Int64
len' Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< 0x10000 = (126, Word16 -> Builder
B.word16BE (Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len'))
| Bool
otherwise = (127, Word64 -> Builder
B.word64BE (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len'))
decodeMessages
:: SizeLimit
-> SizeLimit
-> Stream
-> IO (IO (Maybe Message))
decodeMessages :: SizeLimit -> SizeLimit -> Stream -> IO (IO (Maybe Message))
decodeMessages frameLimit :: SizeLimit
frameLimit messageLimit :: SizeLimit
messageLimit stream :: Stream
stream = do
IORef DemultiplexState
dmRef <- DemultiplexState -> IO (IORef DemultiplexState)
forall a. a -> IO (IORef a)
newIORef DemultiplexState
emptyDemultiplexState
IO (Maybe Message) -> IO (IO (Maybe Message))
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe Message) -> IO (IO (Maybe Message)))
-> IO (Maybe Message) -> IO (IO (Maybe Message))
forall a b. (a -> b) -> a -> b
$ IORef DemultiplexState -> IO (Maybe Message)
go IORef DemultiplexState
dmRef
where
go :: IORef DemultiplexState -> IO (Maybe Message)
go dmRef :: IORef DemultiplexState
dmRef = do
Maybe Frame
mbFrame <- Stream -> Get Frame -> IO (Maybe Frame)
forall a. Stream -> Get a -> IO (Maybe a)
Stream.parseBin Stream
stream (SizeLimit -> Get Frame
parseFrame SizeLimit
frameLimit)
case Maybe Frame
mbFrame of
Nothing -> Maybe Message -> IO (Maybe Message)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Message
forall a. Maybe a
Nothing
Just frame :: Frame
frame -> do
DemultiplexResult
demultiplexResult <- IORef DemultiplexState
-> (DemultiplexState -> (DemultiplexState, DemultiplexResult))
-> IO DemultiplexResult
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef DemultiplexState
dmRef ((DemultiplexState -> (DemultiplexState, DemultiplexResult))
-> IO DemultiplexResult)
-> (DemultiplexState -> (DemultiplexState, DemultiplexResult))
-> IO DemultiplexResult
forall a b. (a -> b) -> a -> b
$
\s :: DemultiplexState
s -> (DemultiplexResult, DemultiplexState)
-> (DemultiplexState, DemultiplexResult)
forall a b. (a, b) -> (b, a)
swap ((DemultiplexResult, DemultiplexState)
-> (DemultiplexState, DemultiplexResult))
-> (DemultiplexResult, DemultiplexState)
-> (DemultiplexState, DemultiplexResult)
forall a b. (a -> b) -> a -> b
$ SizeLimit
-> DemultiplexState
-> Frame
-> (DemultiplexResult, DemultiplexState)
demultiplex SizeLimit
messageLimit DemultiplexState
s Frame
frame
case DemultiplexResult
demultiplexResult of
DemultiplexError err :: ConnectionException
err -> ConnectionException -> IO (Maybe Message)
forall e a. Exception e => e -> IO a
throwIO ConnectionException
err
DemultiplexContinue -> IORef DemultiplexState -> IO (Maybe Message)
go IORef DemultiplexState
dmRef
DemultiplexSuccess msg :: Message
msg -> Maybe Message -> IO (Maybe Message)
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Maybe Message
forall a. a -> Maybe a
Just Message
msg)
parseFrame :: SizeLimit -> Get Frame
parseFrame :: SizeLimit -> Get Frame
parseFrame frameSizeLimit :: SizeLimit
frameSizeLimit = do
Word8
byte0 <- Get Word8
getWord8
let fin :: Bool
fin = Word8
byte0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x80 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x80
rsv1 :: Bool
rsv1 = Word8
byte0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x40 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x40
rsv2 :: Bool
rsv2 = Word8
byte0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x20 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x20
rsv3 :: Bool
rsv3 = Word8
byte0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x10 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x10
opcode :: Word8
opcode = Word8
byte0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x0f
Word8
byte1 <- Get Word8
getWord8
let mask :: Bool
mask = Word8
byte1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x80 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x80
lenflag :: Word8
lenflag = Word8
byte1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x7f
Int64
len <- case Word8
lenflag of
126 -> Word16 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int64) -> Get Word16 -> Get Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16be
127 -> Get Int64
getInt64be
_ -> Int64 -> Get Int64
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
lenflag)
Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int64 -> SizeLimit -> Bool
atMostSizeLimit Int64
len SizeLimit
frameSizeLimit) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get ()) -> String -> Get ()
forall a b. (a -> b) -> a -> b
$ "Frame of size " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show Int64
len String -> String -> String
forall a. [a] -> [a] -> [a]
++ " exceeded limit"
FrameType
ft <- case Word8
opcode of
0x00 -> FrameType -> Get FrameType
forall (m :: * -> *) a. Monad m => a -> m a
return FrameType
ContinuationFrame
0x01 -> FrameType -> Get FrameType
forall (m :: * -> *) a. Monad m => a -> m a
return FrameType
TextFrame
0x02 -> FrameType -> Get FrameType
forall (m :: * -> *) a. Monad m => a -> m a
return FrameType
BinaryFrame
0x08 -> Int64 -> Bool -> Get ()
forall (m :: * -> *) a.
(MonadFail m, Ord a, Num a) =>
a -> Bool -> m ()
enforceControlFrameRestrictions Int64
len Bool
fin Get () -> Get FrameType -> Get FrameType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FrameType -> Get FrameType
forall (m :: * -> *) a. Monad m => a -> m a
return FrameType
CloseFrame
0x09 -> Int64 -> Bool -> Get ()
forall (m :: * -> *) a.
(MonadFail m, Ord a, Num a) =>
a -> Bool -> m ()
enforceControlFrameRestrictions Int64
len Bool
fin Get () -> Get FrameType -> Get FrameType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FrameType -> Get FrameType
forall (m :: * -> *) a. Monad m => a -> m a
return FrameType
PingFrame
0x0a -> Int64 -> Bool -> Get ()
forall (m :: * -> *) a.
(MonadFail m, Ord a, Num a) =>
a -> Bool -> m ()
enforceControlFrameRestrictions Int64
len Bool
fin Get () -> Get FrameType -> Get FrameType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FrameType -> Get FrameType
forall (m :: * -> *) a. Monad m => a -> m a
return FrameType
PongFrame
_ -> String -> Get FrameType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get FrameType) -> String -> Get FrameType
forall a b. (a -> b) -> a -> b
$ "Unknown opcode: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
opcode
ByteString -> ByteString
masker <- Maybe Mask -> ByteString -> ByteString
maskPayload (Maybe Mask -> ByteString -> ByteString)
-> Get (Maybe Mask) -> Get (ByteString -> ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Bool
mask then Mask -> Maybe Mask
forall a. a -> Maybe a
Just (Mask -> Maybe Mask) -> Get Mask -> Get (Maybe Mask)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Mask
parseMask else Maybe Mask -> Get (Maybe Mask)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Mask
forall a. Maybe a
Nothing
ByteString
chunks <- Int64 -> Get ByteString
getLazyByteString Int64
len
Frame -> Get Frame
forall (m :: * -> *) a. Monad m => a -> m a
return (Frame -> Get Frame) -> Frame -> Get Frame
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Bool -> Bool -> FrameType -> ByteString -> Frame
Frame Bool
fin Bool
rsv1 Bool
rsv2 Bool
rsv3 FrameType
ft (ByteString -> ByteString
masker ByteString
chunks)
where
enforceControlFrameRestrictions :: a -> Bool -> m ()
enforceControlFrameRestrictions len :: a
len fin :: Bool
fin
| Bool -> Bool
not Bool
fin = String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Control Frames must not be fragmented!"
| a
len a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> 125 = String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Control Frames must not carry payload > 125 bytes!"
| Bool
otherwise = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
hashKey :: ByteString -> ByteString
hashKey :: ByteString -> ByteString
hashKey key :: ByteString
key = ByteString -> ByteString
unlazy (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Digest SHA1State -> ByteString
forall t. Digest t -> ByteString
bytestringDigest (Digest SHA1State -> ByteString) -> Digest SHA1State -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Digest SHA1State
sha1 (ByteString -> Digest SHA1State) -> ByteString -> Digest SHA1State
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
lazy (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
key ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
`mappend` ByteString
guid
where
guid :: ByteString
guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
lazy :: ByteString -> ByteString
lazy = [ByteString] -> ByteString
BL.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return
unlazy :: ByteString -> ByteString
unlazy = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BL.toChunks
createRequest :: ByteString
-> ByteString
-> Bool
-> Headers
-> IO RequestHead
createRequest :: ByteString -> ByteString -> Bool -> Headers -> IO RequestHead
createRequest hostname :: ByteString
hostname path :: ByteString
path secure :: Bool
secure customHeaders :: Headers
customHeaders = do
ByteString
key <- ByteString -> ByteString
B64.encode (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Int -> IO ByteString
getEntropy 16
RequestHead -> IO RequestHead
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestHead -> IO RequestHead) -> RequestHead -> IO RequestHead
forall a b. (a -> b) -> a -> b
$ ByteString -> Headers -> Bool -> RequestHead
RequestHead ByteString
path (ByteString -> Headers
forall a. IsString a => ByteString -> [(a, ByteString)]
headers ByteString
key Headers -> Headers -> Headers
forall a. [a] -> [a] -> [a]
++ Headers
customHeaders) Bool
secure
where
headers :: ByteString -> [(a, ByteString)]
headers key :: ByteString
key =
[ ("Host" , ByteString
hostname )
, ("Connection" , "Upgrade" )
, ("Upgrade" , "websocket" )
, ("Sec-WebSocket-Key" , ByteString
key )
, ("Sec-WebSocket-Version" , ByteString
versionNumber)
]
versionNumber :: ByteString
versionNumber = [ByteString] -> ByteString
forall a. [a] -> a
head [ByteString]
headerVersions