    --------------------------------------------------------------------------------
    {-# 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 :: [StrictByteString]
    headerVersions = [StrictByteString
    "13"]

    --------------------------------------------------------------------------------
    finishRequest :: RequestHead
                  -> Headers
                  -> Either HandshakeException Response
    finishRequest :: RequestHead -> Headers -> Either HandshakeException Response
    finishRequest RequestHead
    reqHttp Headers
    headers = do
        !key <- RequestHead
    -> CI StrictByteString
    -> Either HandshakeException StrictByteString
    getRequestHeader RequestHead
    reqHttp CI StrictByteString
    "Sec-WebSocket-Key"
        let !hash    = StrictByteString -> StrictByteString
    hashKey StrictByteString
    key
            !encoded = StrictByteString -> StrictByteString
    B64.encode StrictByteString
    hash
        return $ response101 (("Sec-WebSocket-Accept", encoded):headers) ""

    --------------------------------------------------------------------------------
    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
    400) (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
    $
            RequestHead -> ResponseHead -> HandshakeException
    RequestRejected RequestHead
    request ResponseHead
    response
        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 -> [Char] -> HandshakeException
    MalformedResponse ResponseHead
    response [Char]
    "Wrong response status or message."

        key          <- RequestHead
    -> CI StrictByteString
    -> Either HandshakeException StrictByteString
    getRequestHeader  RequestHead
    request  CI StrictByteString
    "Sec-WebSocket-Key"
        responseHash <- getResponseHeader response "Sec-WebSocket-Accept"
        let challengeHash = StrictByteString -> StrictByteString
    B64.encode (StrictByteString -> StrictByteString)
    -> StrictByteString -> StrictByteString
    forall a b. (a -> b) -> a -> b
    $ StrictByteString -> StrictByteString
    hashKey StrictByteString
    key
        when (responseHash /= challengeHash) $ Left $
            MalformedResponse response "Challenge and response hashes do not match."

        return $ Response response ""

    --------------------------------------------------------------------------------
    encodeMessage :: RandomGen g => ConnectionType -> g -> Message -> (g, B.Builder)
    encodeMessage :: forall g.
    RandomGen g =>
    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 b c d. (b -> c) -> (b, d) -> (c, d)
    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
        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
        return $ \[Message]
    msgs -> do
            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.write stream (B.toLazyByteString $ mconcat 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
        dmRef <- DemultiplexState -> IO (IORef DemultiplexState)
    forall a. a -> IO (IORef a)
    newIORef DemultiplexState
    emptyDemultiplexState
        return $ go dmRef
      where
        go :: IORef DemultiplexState -> IO (Maybe Message)
    go IORef DemultiplexState
    dmRef = do
            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 mbFrame of
                Maybe Frame
    Nothing    -> Maybe Message -> IO (Maybe Message)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe Message
    forall a. Maybe a
    Nothing
                Just Frame
    frame -> do
                    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 of
                        DemultiplexError ConnectionException
    err    -> ConnectionException -> IO (Maybe Message)
    forall e a. (HasCallStack, 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 a. a -> IO a
    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
        byte0 <- Get Word8
    getWord8
        let 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   = 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   = 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   = 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
    byte0 Word8 -> Word8 -> Word8
    forall a. Bits a => a -> a -> a
    .&. Word8
    0x0f

        byte1 <- getWord8
        let 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
    byte1 Word8 -> Word8 -> Word8
    forall a. Bits a => a -> a -> a
    .&. Word8
    0x7f

        len <- case 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 a. a -> Get a
    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.
        unless (atMostSizeLimit len frameSizeLimit) $
            fail $ "Frame of size " ++ show len ++ " exceeded limit"

        ft <- case opcode of
            Word8
    0x00 -> FrameType -> Get FrameType
    forall a. a -> Get a
    forall (m :: * -> *) a. Monad m => a -> m a
    return FrameType
    ContinuationFrame
            Word8
    0x01 -> FrameType -> Get FrameType
    forall a. a -> Get a
    forall (m :: * -> *) a. Monad m => a -> m a
    return FrameType
    TextFrame
            Word8
    0x02 -> FrameType -> Get FrameType
    forall a. a -> Get a
    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 a b. Get a -> Get b -> Get b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> FrameType -> Get FrameType
    forall a. a -> Get a
    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 a b. Get a -> Get b -> Get b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> FrameType -> Get FrameType
    forall a. a -> Get a
    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 a b. Get a -> Get b -> Get b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> FrameType -> Get FrameType
    forall a. a -> Get a
    forall (m :: * -> *) a. Monad m => a -> m a
    return FrameType
    PongFrame
            Word8
    _    -> [Char] -> Get FrameType
    forall a. [Char] -> Get a
    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
    fail ([Char] -> Get FrameType) -> [Char] -> Get FrameType
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Unknown opcode: " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Word8 -> [Char]
    forall a. Show a => a -> [Char]
    show Word8
    opcode

        masker <- maskPayload <$> if mask then Just <$> parseMask else pure Nothing

        chunks <- getLazyByteString len

        return $ Frame fin rsv1 rsv2 rsv3 ft (masker chunks)

        where
            enforceControlFrameRestrictions :: a -> Bool -> m ()
    enforceControlFrameRestrictions a
    len Bool
    fin
              | Bool -> Bool
    not Bool
    fin   = [Char] -> m ()
    forall a. [Char] -> m a
    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
    fail [Char]
    "Control Frames must not be fragmented!"
              | a
    len a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    > a
    125 = [Char] -> m ()
    forall a. [Char] -> m a
    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
    fail [Char]
    "Control Frames must not carry payload > 125 bytes!"
              | Bool
    otherwise = () -> m ()
    forall a. a -> m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()

    --------------------------------------------------------------------------------
    hashKey :: ByteString -> ByteString
    hashKey :: StrictByteString -> StrictByteString
    hashKey StrictByteString
    key = ByteString -> StrictByteString
    unlazy (ByteString -> StrictByteString) -> ByteString -> StrictByteString
    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
    $ StrictByteString -> ByteString
    lazy (StrictByteString -> ByteString) -> StrictByteString -> ByteString
    forall a b. (a -> b) -> a -> b
    $ StrictByteString
    key StrictByteString -> StrictByteString -> StrictByteString
    forall a. Monoid a => a -> a -> a
    `mappend` StrictByteString
    guid
      where
        guid :: StrictByteString
    guid = StrictByteString
    "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
        lazy :: StrictByteString -> ByteString
    lazy = [StrictByteString] -> ByteString
    BL.fromChunks ([StrictByteString] -> ByteString)
    -> (StrictByteString -> [StrictByteString])
    -> StrictByteString
    -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . StrictByteString -> [StrictByteString]
    forall a. a -> [a]
    forall (m :: * -> *) a. Monad m => a -> m a
    return
        unlazy :: ByteString -> StrictByteString
    unlazy = [StrictByteString] -> StrictByteString
    forall a. Monoid a => [a] -> a
    mconcat ([StrictByteString] -> StrictByteString)
    -> (ByteString -> [StrictByteString])
    -> ByteString
    -> StrictByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> [StrictByteString]
    BL.toChunks

    --------------------------------------------------------------------------------
    createRequest :: ByteString
                  -> ByteString
                  -> Bool
                  -> Headers
                  -> IO RequestHead
    createRequest :: StrictByteString
    -> StrictByteString -> Bool -> Headers -> IO RequestHead
    createRequest StrictByteString
    hostname StrictByteString
    path Bool
    secure Headers
    customHeaders = do
        key <- StrictByteString -> StrictByteString
    B64.encode (StrictByteString -> StrictByteString)
    -> IO StrictByteString -> IO StrictByteString
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    `liftM`  Int -> IO StrictByteString
    getEntropy Int
    16
        return $ RequestHead path (headers key ++ customHeaders) secure
      where
        headers :: StrictByteString -> [(a, StrictByteString)]
    headers StrictByteString
    key =
            [ (a
    "Host"                   , StrictByteString
    hostname     )
            , (a
    "Connection"             , StrictByteString
    "Upgrade"    )
            , (a
    "Upgrade"                , StrictByteString
    "websocket"  )
            , (a
    "Sec-WebSocket-Key"      , StrictByteString
    key          )
            , (a
    "Sec-WebSocket-Version"  , StrictByteString
    versionNumber)
            ]

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