--------------------------------------------------------------------------------
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Hybi13
    ( headerVersions
    , finishRequest
    , finishResponse
    , encodeMessage
    , encodeMessages
    , decodeMessages
    , createRequest

      -- Internal (used for testing)
    , 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]
headerVersions :: [ByteString]
headerVersions = [ByteString
"13"]


--------------------------------------------------------------------------------
finishRequest :: RequestHead
              -> Headers
              -> Either HandshakeException Response
finishRequest :: RequestHead -> Headers -> Either HandshakeException Response
finishRequest RequestHead
reqHttp Headers
headers = do
    !ByteString
key <- RequestHead
-> CI ByteString -> Either HandshakeException ByteString
getRequestHeader RequestHead
reqHttp CI ByteString
"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 ((CI ByteString
"Sec-WebSocket-Accept", ByteString
encoded)(CI ByteString, ByteString) -> Headers -> Headers
forall a. a -> [a] -> [a]
:Headers
headers) ByteString
""


--------------------------------------------------------------------------------
finishResponse :: RequestHead
               -> ResponseHead
               -> Either HandshakeException Response
finishResponse :: RequestHead -> ResponseHead -> Either HandshakeException Response
finishResponse RequestHead
request ResponseHead
response = do
    -- Response message should be one of
    --
    -- - WebSocket Protocol Handshake
    -- - Switching Protocols
    --
    -- But we don't check it for now
    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
/= Int
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 String
"Wrong response status or message."

    ByteString
key          <- RequestHead
-> CI ByteString -> Either HandshakeException ByteString
getRequestHeader  RequestHead
request  CI ByteString
"Sec-WebSocket-Key"
    ByteString
responseHash <- ResponseHead
-> CI ByteString -> Either HandshakeException ByteString
getResponseHeader ResponseHead
response CI ByteString
"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 String
"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 ByteString
""


--------------------------------------------------------------------------------
encodeMessage :: RandomGen g => ConnectionType -> g -> Message -> (g, B.Builder)
encodeMessage :: ConnectionType -> g -> Message -> (g, Builder)
encodeMessage ConnectionType
conType g
gen 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
    (Maybe Mask
mask, g
gen') = case ConnectionType
conType of
        ConnectionType
ServerConnection -> (Maybe Mask
forall a. Maybe a
Nothing, g
gen)
        ConnectionType
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 Word16
code 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 ByteString
pl))               -> FrameType -> ByteString -> Frame
mkFrame FrameType
PingFrame   ByteString
pl
        (ControlMessage (Pong ByteString
pl))               -> FrameType -> ByteString -> Frame
mkFrame FrameType
PongFrame   ByteString
pl
        (DataMessage Bool
rsv1 Bool
rsv2 Bool
rsv3 (Text ByteString
pl Maybe Text
_)) -> Bool -> Bool -> Bool -> Bool -> FrameType -> ByteString -> Frame
Frame Bool
True Bool
rsv1 Bool
rsv2 Bool
rsv3 FrameType
TextFrame   ByteString
pl
        (DataMessage Bool
rsv1 Bool
rsv2 Bool
rsv3 (Binary 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 ConnectionType
conType 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
forall (m :: * -> *). MonadIO m => m 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
$ \[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
$ \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
$ \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 Maybe Mask
mask 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 Word8
0x80 else Word8
0x00
    rsv1 :: Word8
rsv1   = if Frame -> Bool
frameRsv1 Frame
f then Word8
0x40 else Word8
0x00
    rsv2 :: Word8
rsv2   = if Frame -> Bool
frameRsv2 Frame
f then Word8
0x20 else Word8
0x00
    rsv3 :: Word8
rsv3   = if Frame -> Bool
frameRsv3 Frame
f then Word8
0x10 else Word8
0x00
    payload :: ByteString
payload = case Frame -> FrameType
frameType Frame
f of
        FrameType
ContinuationFrame -> Frame -> ByteString
framePayload Frame
f
        FrameType
TextFrame         -> Frame -> ByteString
framePayload Frame
f
        FrameType
BinaryFrame       -> Frame -> ByteString
framePayload Frame
f
        FrameType
CloseFrame        -> Int64 -> ByteString -> ByteString
BL.take Int64
125 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Frame -> ByteString
framePayload Frame
f
        FrameType
PingFrame         -> Int64 -> ByteString -> ByteString
BL.take Int64
125 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Frame -> ByteString
framePayload Frame
f
        FrameType
PongFrame         -> Int64 -> ByteString -> ByteString
BL.take Int64
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
        FrameType
ContinuationFrame -> Word8
0x00
        FrameType
TextFrame         -> Word8
0x01
        FrameType
BinaryFrame       -> Word8
0x02
        FrameType
CloseFrame        -> Word8
0x08
        FrameType
PingFrame         -> Word8
0x09
        FrameType
PongFrame         -> Word8
0x0a
    (Word8
maskflag, Builder
maskbytes) = case Maybe Mask
mask of
        Maybe Mask
Nothing -> (Word8
0x00, Builder
forall a. Monoid a => a
mempty)
        Just Mask
m  -> (Word8
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
    (Word8
lenflag, Builder
len)
        | Int64
len' Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
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
< Int64
0x10000 = (Word8
126, Word16 -> Builder
B.word16BE (Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len'))
        | Bool
otherwise      = (Word8
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 SizeLimit
frameLimit SizeLimit
messageLimit 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 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
            Maybe Frame
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 -> 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
$
                    \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 ConnectionException
err    -> ConnectionException -> IO (Maybe Message)
forall e a. Exception e => e -> IO a
throwIO ConnectionException
err
                    DemultiplexResult
DemultiplexContinue     -> IORef DemultiplexState -> IO (Maybe Message)
go IORef DemultiplexState
dmRef
                    DemultiplexSuccess  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)


--------------------------------------------------------------------------------
-- | Parse a frame
parseFrame :: SizeLimit -> Get Frame
parseFrame :: SizeLimit -> Get Frame
parseFrame SizeLimit
frameSizeLimit = do
    Word8
byte0 <- Get Word8
getWord8
    let fin :: Bool
fin    = Word8
byte0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x80 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x80
        rsv1 :: Bool
rsv1   = Word8
byte0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x40 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x40
        rsv2 :: Bool
rsv2   = Word8
byte0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x20 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x20
        rsv3 :: Bool
rsv3   = Word8
byte0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x10 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x10
        opcode :: Word8
opcode = Word8
byte0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x0f

    Word8
byte1 <- Get Word8
getWord8
    let mask :: Bool
mask = Word8
byte1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x80 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x80
        lenflag :: Word8
lenflag = Word8
byte1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7f

    Int64
len <- case Word8
lenflag of
        Word8
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
        Word8
127 -> Get Int64
getInt64be
        Word8
_   -> 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)

    -- Check size against limit.
    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
$ String
"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]
++ String
" exceeded limit"

    FrameType
ft <- case Word8
opcode of
        Word8
0x00 -> FrameType -> Get FrameType
forall (m :: * -> *) a. Monad m => a -> m a
return FrameType
ContinuationFrame
        Word8
0x01 -> FrameType -> Get FrameType
forall (m :: * -> *) a. Monad m => a -> m a
return FrameType
TextFrame
        Word8
0x02 -> FrameType -> Get FrameType
forall (m :: * -> *) a. Monad m => a -> m a
return FrameType
BinaryFrame
        Word8
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
        Word8
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
        Word8
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
        Word8
_    -> 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
$ String
"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 a
len Bool
fin
          | Bool -> Bool
not Bool
fin   = String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Control Frames must not be fragmented!"
          | a
len a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
125 = String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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 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 = ByteString
"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 ByteString
hostname ByteString
path Bool
secure 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 Int
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 ByteString
key =
        [ (a
"Host"                   , ByteString
hostname     )
        , (a
"Connection"             , ByteString
"Upgrade"    )
        , (a
"Upgrade"                , ByteString
"websocket"  )
        , (a
"Sec-WebSocket-Key"      , ByteString
key          )
        , (a
"Sec-WebSocket-Version"  , ByteString
versionNumber)
        ]

    versionNumber :: ByteString
versionNumber = [ByteString] -> ByteString
forall a. [a] -> a
head [ByteString]
headerVersions