--------------------------------------------------------------------------------
{-# 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 = ["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
    -- 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
/= 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)


--------------------------------------------------------------------------------
-- | Parse a frame
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)

    -- 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
$ "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