{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}

{-# OPTIONS_GHC -Wall #-}
-- |
-- Copyright: © 2020  Herbert Valerio Riedel
-- SPDX-License-Identifier: GPL-2.0-or-later
--
-- Basic WebSocket <https://tools.ietf.org/html/rfc6455 RFC 6455> support.
--
-- @since 0.1.4.0
module Network.Http.Client.WebSocket
    ( -- * WebSocket Frames
      -- ** WebSocket Frame Header
      WSFrameHdr(..)
    , wsFrameHdrSize
    , wsFrameHdrToBuilder

    , WSOpcode(..)
    , WSOpcodeReserved(..)
    , wsIsDataFrame

      -- ** Mid-level I/O primitives

      -- *** Sending WebSocket frames
    , writeWSFrame
    , sendWSFragData

      -- *** Receiving WebSocket frames
--  , readWSFrameHdr
    , readWSFrame
    , receiveWSFrame

      -- * WebSocket handshake

      -- ** HTTP/1.1 WebSocket connection upgrade

    , wsUpgradeConnection

      -- ** Low-level primitives for WebSocket handshake
    , SecWebSocketKey
    , wsKeyToAcceptB64

    , secWebSocketKeyFromB64
    , secWebSocketKeyToB64
    , secWebSocketKeyFromWords

      -- * Exception
    , WsException(..)
    ) where

import           Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder as Builder
import           Control.Exception
import           Control.Monad            (unless, when)
import qualified Crypto.Hash.SHA1         as SHA1
import qualified Data.Binary              as Bin
import qualified Data.Binary.Get          as Bin
import qualified Data.Binary.Put          as Bin
import           Data.Bits
import           Data.ByteString          (ByteString)
import qualified Data.ByteString          as BS
import qualified Data.ByteString.Base64   as B64
import qualified Data.ByteString.Lazy     as BL
import qualified Data.CaseInsensitive     as CI
import           Data.IORef
import           Data.Maybe               (isJust)
import           Data.Monoid              (Monoid (..))
import           Data.Typeable            (Typeable)
import           Data.Word
import           Data.XOR                 (xor32LazyByteString, xor32StrictByteString')
import           Network.Http.Client      as HC
import qualified Network.Http.Connection  as HC
import           System.IO.Streams        (InputStream, OutputStream)
import qualified System.IO.Streams        as Streams

-- | Exception type thrown by WebSocket routines.
--
-- These exceptions mostly denote WebSocket protocol violations from either side, client and server.
--
-- @since 0.1.4.0
data WsException = WsException String
  deriving (Typeable,Show)

instance Exception WsException

-- | WebSocket Frame as per <https://tools.ietf.org/html/rfc6455#section-5.2 RFC 6455 section 5.2>
--
--
-- >  0                   1                   2                   3
-- >  0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
-- > +-+-+-+-+-------+-+-------------+-------------------------------+
-- > |F|R|R|R| opcode|M| Payload len |    Extended payload length    |
-- > |I|S|S|S|  (4)  |A|     (7)     |             (16/64)           |
-- > |N|V|V|V|       |S|             |   (if payload len==126/127)   |
-- > | |1|2|3|       |K|             |                               |
-- > +-+-+-+-+-------+-+-------------+ - - - - - - - - - - - - - - - +
-- > |     Extended payload length continued, if payload len == 127  |
-- > + - - - - - - - - - - - - - - - +-------------------------------+
-- > |                               |Masking-key, if MASK set to 1  |
-- > +-------------------------------+-------------------------------+
-- > | Masking-key (continued)       |          Payload Data         |
-- > +-------------------------------- - - - - - - - - - - - - - - - +
-- > :                     Payload Data continued ...                :
-- > + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +
-- > |                     Payload Data continued ...                |
-- > +---------------------------------------------------------------+
--
-- @since 0.1.4.0
data WSFrameHdr = WSFrameHdr
  { ws'FIN    :: !Bool -- ^ MUST be set for control-frames (control-frames MUST NOT be fragmented).
  , ws'RSV1   :: !Bool
  , ws'RSV2   :: !Bool
  , ws'RSV3   :: !Bool
  , ws'opcode :: !WSOpcode -- see 'WSOpcode'
  , ws'length :: !Word64 -- ^ MUST be smaller than 2^63 for data-frames;
                         --   MUST be smaller than 126 for control-frames.
  , ws'mask   :: !(Maybe Word32)
    -- ^ Whether the frame is masked and which masking key is used;
    -- 'Nothing' denotes unmasked frames.
    --
    -- A client MUST mask all frames that it sends to the server; A
    -- server MUST NOT mask any frames that it sends to the client.
  } deriving Show

-- | Size of serialized WebSocket frame header (i.e. without payload data) in octets.
--
-- @since 0.1.4.0
wsFrameHdrSize :: WSFrameHdr -> Int
wsFrameHdrSize WSFrameHdr{ws'mask = Nothing, ws'length}
  | ws'length <  126    = 2
  | ws'length <= 0xffff = 4
  | otherwise           = 10
wsFrameHdrSize WSFrameHdr{ws'mask = Just _, ws'length}
  | ws'length <  126    = 6
  | ws'length <= 0xffff = 8
  | otherwise           = 14

-- not exported yet
-- | Try reading a 'WSFrameHdr' from the 'InputStream'.
--
-- Returns 'Nothing' is EOF is encountered before any WebSocket header byte is read
readWSFrameHdr :: Connection -> IO (Maybe WSFrameHdr)
readWSFrameHdr (HC.Connection { cIn = is }) = do
    mchunk <- Streams.read is
    case mchunk of
      Nothing -> return Nothing
      Just chunk -> go $ (if BS.null chunk then id else flip Bin.pushChunk chunk)
                       $ Bin.runGetIncremental Bin.get
  where
    go :: Bin.Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
    go (Bin.Fail rest _ err) = do
        unless (BS.null rest) $
          Streams.unRead rest is
        throwIO $ WsException ("readWSFrameHdr: " ++ err)
    go partial@(Bin.Partial cont) = do
        mchunk <- Streams.read is
        case mchunk of
          Nothing -> go (cont Nothing) -- eof, will likely trigger failure
          Just chunk
            | BS.null chunk -> go partial -- loop
            | otherwise     -> go (cont (Just chunk))
    go (Bin.Done rest _ x) = do
        unless (BS.null rest) $
          Streams.unRead rest is
        return (Just x)

-- | Receive a single WebSocket frame as 'InputStream'.
--
-- This operation does not perform any defragmentation nor automatically deal with control-frames (those will be returned to the caller as-is).
--
-- See also 'readWSFrame' for a simple non-streaming version.
--
-- @since 0.1.4.0
receiveWSFrame :: Connection -> (WSFrameHdr -> InputStream ByteString -> IO a) -> IO (Maybe a)
receiveWSFrame (conn@HC.Connection { cIn = is }) cont = do
  mhdr <- readWSFrameHdr conn
  case mhdr of
    Nothing -> return Nothing
    Just hdr
      | ws'length hdr == 0 -> do
          is' <- Streams.nullInput
          Just `fmap` cont hdr is'
      | otherwise -> do
          is' <- Streams.takeExactly (fromIntegral (ws'length hdr)) is
          is'' <- xor32InputStream (maybe 0 id (ws'mask hdr)) is'
          res <- cont hdr is''
          Streams.skipToEof is'
          return $! Just $! res

-- | Send WebSocket message as fragmented data-frames.
--
-- This function can be used if the size of the data payload to be sent is not known in advance.
--
-- This operation does not flush automatically after every chunk; write an empty chunk to the 'OutputStream' to trigger flushing pending data onto the WebSocket connection.
--
-- The 'ws'length' and 'ws'FIN' fields are ignored and computed from the chunks to be sent.
--
-- Pre-conditions:
--
-- - This function does not support sending control-frames as those MUST NOT be fragmented.
-- - 'ws'opcode' MUST NOT be 'WSOpcode'Continuation'
--
-- @since 0.1.4.0
sendWSFragData :: Connection -> WSFrameHdr -> (OutputStream ByteString -> IO a) -> IO a
sendWSFragData _ hdr0  _
  | not (wsIsDataFrame (ws'opcode hdr0))
      = throwIO (WsException "sendWSFragData: sending control-frame requested")
  | ws'opcode hdr0 == WSOpcode'Continuation
      = throwIO (WsException "sendWSFragData: sending continuation frame requested")
sendWSFragData (HC.Connection { cOut = os }) hdr0 cont = do
    opcodeRef <- newIORef (ws'opcode hdr0)
    let go Nothing = return ()
        go (Just chunk)
          | BS.null chunk = Streams.write (Just Builder.flush) os
          | otherwise = do
              let (_,chunk') = xor32StrictByteString' (maybe 0 id $ ws'mask hdr0) chunk
              opcode <- readIORef opcodeRef
              writeIORef opcodeRef WSOpcode'Continuation
              let fraghdr = hdr0 { ws'FIN = False
                                 , ws'length = fromIntegral (BS.length chunk)
                                 , ws'opcode = opcode
                                 }
              Streams.write (Just $! wsFrameHdrToBuilder fraghdr `mappend` Builder.fromByteString chunk') os

    os' <- Streams.makeOutputStream go
    !res <- cont os'

    -- send FINal frame
    opcode <- readIORef opcodeRef
    let final = (hdr0 { ws'FIN    = True
                      , ws'length = 0
                      , ws'opcode = opcode
                      , ws'mask   = Just 0
                      })
    Streams.write (Just $ wsFrameHdrToBuilder final `mappend` Builder.flush) os

    return $! res

-- | Convenience function for writing simple non-fragmented frames to an established WebSocket connection.
--
-- Control-frames MUST have a payload smaller than 126 bytes.
--
-- @since 0.1.4.0
writeWSFrame :: Connection -> WSOpcode -> Maybe Word32 -> BL.ByteString -> IO ()
writeWSFrame (HC.Connection { cOut = os }) opcode mmask payload = do
    when (not (wsIsDataFrame opcode) && plen >= 126) $
      throwIO (WsException "writeWSFrame: over-sized control-frame")

    let hdr = wsFrameHdrToBuilder (WSFrameHdr True False False False opcode plen mmask)
        dat = case mmask of
                Nothing  -> Builder.fromLazyByteString payload
                Just 0   -> Builder.fromLazyByteString payload
                Just msk -> Builder.fromLazyByteString (xor32LazyByteString msk payload)
    Streams.write (Just $ hdr `mappend` dat `mappend` Builder.flush) os
  where
    plen = fromIntegral (BL.length payload)

-- | Convenience function for reading a single (possibly fragmented) frame from an established WebSocket connection.
--
-- The first argument is the maximum expected frame size to receive; if a larger frame is encountered an exception is raised.
--
-- This operation does not perform any defragmentation nor automatically deal with control-frames (those will be returned to the caller as-is).
--
-- Returns 'Nothing' if the 'InputStream' is terminated before reading the first octet.
--
-- @since 0.1.4.0
readWSFrame :: Int -> Connection -> IO (Maybe (WSFrameHdr,ByteString))
readWSFrame maxSize (conn@HC.Connection { cIn = is }) = do
    mhdr <- readWSFrameHdr conn
    case mhdr of
      Nothing -> return Nothing
      Just hdr
        | ws'length hdr == 0 ->
            return $ Just (hdr,BS.empty)
        | ws'length hdr >= fromIntegral maxSize ->
            throwIO (WsException "readWSFrame: frame larger than maxSize")
        | otherwise -> do
            dat <- Streams.readExactly (fromIntegral (ws'length hdr)) is
            let dat' = case ws'mask hdr of
                         Nothing -> dat
                         Just 0  -> dat
                         Just m  -> snd (xor32StrictByteString' m dat)
            return $ Just (hdr,dat')

-- | Serialize 'WSFrameHdr' to 'BB.Builder'
--
-- @since 0.1.4.0
wsFrameHdrToBuilder :: WSFrameHdr -> Builder
wsFrameHdrToBuilder WSFrameHdr{..} = mconcat
    [ Builder.fromWord8 $!
        (if ws'FIN  then 0x80 else 0) .|.
        (if ws'RSV1 then 0x40 else 0) .|.
        (if ws'RSV2 then 0x20 else 0) .|.
        (if ws'RSV3 then 0x10 else 0) .|.
        (encodeWSOpcode ws'opcode)

    , Builder.fromWord8 $!
        (if isJust ws'mask then 0x80 else 0) .|. len7

    -- extended payload length
    , case len7 of
        126 -> Builder.fromWord16be (fromIntegral ws'length)
        127 -> Builder.fromWord64be ws'length
        _   -> Data.Monoid.mempty

    , maybe mempty Builder.fromWord32be ws'mask
    ]
  where
    len7 | ws'length < 126     = fromIntegral ws'length
         | ws'length <= 0xffff = 126 -- 16bit
         | otherwise           = 127 -- 64bit

instance Bin.Binary WSFrameHdr where
  -- put :: WSFrameHdr -> Bin.Put
  put WSFrameHdr{..} = do
      Bin.putWord8 $!
        (if ws'FIN  then 0x80 else 0) .|.
        (if ws'RSV1 then 0x40 else 0) .|.
        (if ws'RSV2 then 0x20 else 0) .|.
        (if ws'RSV3 then 0x10 else 0) .|.
        (encodeWSOpcode ws'opcode)

      Bin.putWord8 $!
        (if isJust ws'mask then 0x80 else 0) .|. len7

      -- extended payload length
      case len7 of
        126 -> Bin.putWord16be (fromIntegral ws'length)
        127 -> Bin.putWord64be ws'length
        _   -> return ()

      maybe (return ()) Bin.putWord32be ws'mask
    where
      len7 | ws'length < 126     = fromIntegral ws'length
           | ws'length <= 0xffff = 126 -- 16bit
           | otherwise           = 127 -- 64bit

  ----------------------------------------------------------------------------

  -- get :: Bin.Get WSFrameHdr
  get = do
      o0 <- Bin.getWord8

      let ws'FIN    = testBit o0 7
          ws'RSV1   = testBit o0 6
          ws'RSV2   = testBit o0 5
          ws'RSV3   = testBit o0 4
          ws'opcode = decodeWSOpcode o0

      when (not ws'FIN && not (wsIsDataFrame ws'opcode)) $
        fail "invalid fragmented control-frame"

      o1 <- Bin.getWord8

      let len7 = o1 .&. 0x7f
          msk  = o1  >= 0x80

      ws'length <- case len7 of
          127 -> do
            unless (wsIsDataFrame ws'opcode) $ fail "invalid 64-bit extended length (control-frame)"
            v <- Bin.getWord64be
            unless (v > 0xffff) $ fail "invalid 64-bit extended length (<= 0xffff)"
            unless (v < 0x8000000000000000) $ fail "invalid 64-bit extended length (MSB set)"
            return v
          126 -> do
            unless (wsIsDataFrame ws'opcode) $ fail "invalid 16-bit extended length (control-frame)"
            v <- Bin.getWord16be
            unless (v > 125) $ fail "invalid 16-bit extended length (<= 0x7d)"
            return (fromIntegral v)
          _ -> return (fromIntegral len7)

      ws'mask <- if msk
       then Just `fmap` Bin.getWord32be
       else return Nothing

      return WSFrameHdr{..}

-- | WebSocket frame opcode.
--
-- See also 'wsIsDataFrame'.
--
-- @since 0.1.4.0
data WSOpcode
  = WSOpcode'Continuation -- ^ /data/ fragmented data-frame
  | WSOpcode'Text         -- ^ /data/ payload must utf-8 encoded
  | WSOpcode'Binary       -- ^ /data/ binary data payload
  | WSOpcode'Close        -- ^ /control/ connection close frame (optional payload with reason-code)
  | WSOpcode'Ping         -- ^ /control/ PING frame
  | WSOpcode'Pong         -- ^ /control/ PONG frame
  | WSOpcode'Reserved !WSOpcodeReserved -- ^ reserved frame kind not defined by RFC 6455
  deriving (Eq,Show)

-- | WebSocket frame opcodes reserved for future use by RFC 6455
--
-- @since 0.1.4.0
data WSOpcodeReserved
  = WSOpcode'Reserved3
  | WSOpcode'Reserved4
  | WSOpcode'Reserved5
  | WSOpcode'Reserved6
  | WSOpcode'Reserved7
  | WSOpcode'Reserved11
  | WSOpcode'Reserved12
  | WSOpcode'Reserved13
  | WSOpcode'Reserved14
  | WSOpcode'Reserved15
  deriving (Eq,Show)

-- | Whether 'WSOpcode' denotes a data-frame.
--
-- There are two kinds of WebSocket frames, data-frames and
-- control-frames. Consequently, this predicate is 'False' for
-- control-frames.
--
-- @since 0.1.4.0
wsIsDataFrame :: WSOpcode -> Bool
wsIsDataFrame x = case x of
  WSOpcode'Continuation                 -> True
  WSOpcode'Text                         -> True
  WSOpcode'Binary                       -> True

  WSOpcode'Reserved WSOpcode'Reserved3  -> True
  WSOpcode'Reserved WSOpcode'Reserved4  -> True
  WSOpcode'Reserved WSOpcode'Reserved5  -> True
  WSOpcode'Reserved WSOpcode'Reserved6  -> True
  WSOpcode'Reserved WSOpcode'Reserved7  -> True

  WSOpcode'Close                        -> False
  WSOpcode'Ping                         -> False
  WSOpcode'Pong                         -> False

  WSOpcode'Reserved WSOpcode'Reserved11 -> False
  WSOpcode'Reserved WSOpcode'Reserved12 -> False
  WSOpcode'Reserved WSOpcode'Reserved13 -> False
  WSOpcode'Reserved WSOpcode'Reserved14 -> False
  WSOpcode'Reserved WSOpcode'Reserved15 -> False


-- NB: ignores high nibble
decodeWSOpcode :: Word8 -> WSOpcode
decodeWSOpcode x = case x .&. 0xf of
  0x0 -> WSOpcode'Continuation
  0x1 -> WSOpcode'Text
  0x2 -> WSOpcode'Binary

  0x3 -> WSOpcode'Reserved WSOpcode'Reserved3
  0x4 -> WSOpcode'Reserved WSOpcode'Reserved4
  0x5 -> WSOpcode'Reserved WSOpcode'Reserved5
  0x6 -> WSOpcode'Reserved WSOpcode'Reserved6
  0x7 -> WSOpcode'Reserved WSOpcode'Reserved7

  0x8 -> WSOpcode'Close
  0x9 -> WSOpcode'Ping
  0xA -> WSOpcode'Pong

  0xB -> WSOpcode'Reserved WSOpcode'Reserved11
  0xC -> WSOpcode'Reserved WSOpcode'Reserved12
  0xD -> WSOpcode'Reserved WSOpcode'Reserved13
  0xE -> WSOpcode'Reserved WSOpcode'Reserved14
  0xF -> WSOpcode'Reserved WSOpcode'Reserved15

  _   -> undefined -- impossible

-- internal
encodeWSOpcode :: WSOpcode -> Word8
encodeWSOpcode x = case x of
  WSOpcode'Continuation                 -> 0x0
  WSOpcode'Text                         -> 0x1
  WSOpcode'Binary                       -> 0x2

  WSOpcode'Reserved WSOpcode'Reserved3  -> 0x3
  WSOpcode'Reserved WSOpcode'Reserved4  -> 0x4
  WSOpcode'Reserved WSOpcode'Reserved5  -> 0x5
  WSOpcode'Reserved WSOpcode'Reserved6  -> 0x6
  WSOpcode'Reserved WSOpcode'Reserved7  -> 0x7

  WSOpcode'Close                        -> 0x8
  WSOpcode'Ping                         -> 0x9
  WSOpcode'Pong                         -> 0xA

  WSOpcode'Reserved WSOpcode'Reserved11 -> 0xB
  WSOpcode'Reserved WSOpcode'Reserved12 -> 0xC
  WSOpcode'Reserved WSOpcode'Reserved13 -> 0xD
  WSOpcode'Reserved WSOpcode'Reserved14 -> 0xE
  WSOpcode'Reserved WSOpcode'Reserved15 -> 0xF

-- | Compute @Sec-WebSocket-Accept@ header value from @Sec-WebSocket-Key@ header value according to RFC 6455
--
-- >>> wsKeyToAcceptB64 <$> secWebSocketKeyFromB64 "dGhlIHNhbXBsZSBub25jZQ=="
-- Just "s3pPLMBiTxaQ9kYGzzhZRbK+xOo="
--
-- @since 0.1.4.0
wsKeyToAcceptB64 :: SecWebSocketKey -> ByteString
wsKeyToAcceptB64 key = B64.encode (SHA1.hash (secWebSocketKeyToB64 key `BS.append` rfc6455Guid))
  where
    rfc6455Guid :: ByteString
    rfc6455Guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"

-- | @Sec-WebSocket-Key@ header value according to RFC 6455
--
-- @since 0.1.4.0
newtype SecWebSocketKey = WSKey ByteString deriving (Eq,Ord,Show)

-- | Construct 'SecWebSocketKey' from its HTTP header base64 representation.
--
-- The input must be a valid @Sec-WebSocket-Key@ value, i.e. a @base64@ encoded 16-octet value (i.e. 24 base64 characters) with optional surrounding whitespace (@TAB@ or @SPC@) characters or this function will return 'Nothing'.
--
-- @since 0.1.4.0
secWebSocketKeyFromB64 :: ByteString -> Maybe SecWebSocketKey
secWebSocketKeyFromB64 key
  | BS.length key' /= 24      = Nothing -- invalid base64 or wrong length
  | Left _ <- B64.decode key' = Nothing -- invalid base64
  | otherwise                 = Just $! WSKey key'
  where
    -- strip leading/trailing OWS from key
    key' = fst (BS.spanEnd isOWS (BS.dropWhile isOWS key))

    -- optional whitespace
    isOWS :: Word8 -> Bool
    isOWS 0x09 = True
    isOWS 0x20 = True
    isOWS _    = False

-- | Emit 'SecWebSocketKey' as base64-encoded value suitable for use in the @Sec-WebSocket-Accept@ HTTP header.
--
-- @since 0.1.4.0
secWebSocketKeyToB64 :: SecWebSocketKey -> ByteString
secWebSocketKeyToB64 (WSKey bs) = bs

-- | Construct 'SecWebSocketKey' from two 'Word64' values.
--
-- @since 0.1.4.0
secWebSocketKeyFromWords :: Word64 -> Word64 -> SecWebSocketKey
secWebSocketKeyFromWords h l = WSKey (B64.encode key)
  where
    key = BS.concat $ BL.toChunks $ Bin.runPut (Bin.putWord64be h >> Bin.putWord64be l)

-- upgradeToWebSockets :: HC.Connection
--                     -> (Response -> InputStream ByteString                         -> IO a) -- ^ Non-code @101@ response handler
--                     -> (Response -> InputStream ByteString -> OutputStream Builder -> IO a) -- ^ Code @101@ response handler
--                     -> IO a
-- upgradeToWebSockets = do
--

xor32InputStream :: Word32 -> InputStream ByteString -> IO (InputStream ByteString)
xor32InputStream 0    is = return is
xor32InputStream msk0 is = do
    mskref <- newIORef msk0
    let go = do
          mchunk <- Streams.read is
          case mchunk of
            Nothing -> return Nothing
            Just chunk -> do
              msk <- readIORef mskref
              let (msk',chunk') = xor32StrictByteString' msk chunk
              writeIORef mskref msk'
              return $! Just $! chunk'
    Streams.makeInputStream go

-- xor32OutputStream :: Word32 -> OutputStream ByteString -> IO (OutputStream ByteString)
-- xor32OutputStream msk0 os = do
--     mskref <- newIORef msk0
--     let go Nothing = Streams.write Nothing os
--         go (Just chunk) = do
--               msk <- readIORef mskref
--               let (msk',chunk') = xor32StrictByteString' msk chunk
--               writeIORef mskref msk'
--               Streams.write (Just $! chunk') os
--     Streams.makeOutputStream go

----------------------------------------------------------------------------

-- | Perform an opening WebSocket handshake as per <https://tools.ietf.org/html/rfc6455#section-4 RFC 6455 section 4>
--
-- This operation sets the @host@, @upgrade@, @connection@, @sec-websocket-version@, @sec-websocket-key@ HTTP headers; if you need to customize the handshake request further use the 'BuildRequest'-modifier argument to inject more headers into the request.
--
-- @since 0.1.4.0
wsUpgradeConnection :: Connection -- ^ Connection in HTTP/1.1 protocol state (i.e. not yet upgraded)
                    -> ByteString -- ^ resource name (i.e. the argument to the @GET@ verb)
                    -> RequestBuilder α -- ^ Additional Handshake request builder operations (i.e. to add additional HTTP headers to Handshake HTTP request)
                    -> SecWebSocketKey -- ^ The @sec-websocket-key@ value to use
                    -> (Response -> InputStream ByteString -> IO b) -- ^ failure continuation if handshake fails with a non-101 response code
                    -> (Response -> Connection -> IO b) -- ^ success continuation; the 'Connection' has been succesfully upgraded to WebSocket mode and only WebSocket operations shall be performed over this 'Connection'.
                    -> IO b
wsUpgradeConnection conn resource rqmod wskey failedToUpgrade success = do
    let rqToWS = HC.buildRequest1 $ do
          HC.http HC.GET resource
          HC.setHeader "upgrade" "websocket"
          HC.setHeader "connection" "Upgrade"
          HC.setHeader "sec-websocket-version" "13"
          HC.setHeader "sec-websocket-key" (secWebSocketKeyToB64 wskey)
          rqmod

    HC.sendRequest conn rqToWS HC.emptyBody

    HC.receiveUpgradeResponse conn failedToUpgrade $ \resp _is _os -> do

      case CI.mk `fmap` HC.getHeader resp "connection" of
        Nothing        -> abort "missing 'connection' header"
        Just "upgrade" -> return ()
        Just _         -> abort "'connection' header has non-'upgrade' value"

      case CI.mk `fmap` HC.getHeader resp "upgrade" of
        Nothing          -> abort "missing 'upgrade' header"
        Just "websocket" -> return ()
        Just _           -> abort "'upgrade' header has non-'websocket' value"

      case HC.getHeader resp "sec-websocket-accept" of
        Nothing -> abort "missing 'sec-websocket-accept' header"
        Just wsacc
          | wsacc /= wsKeyToAcceptB64 wskey -> abort "sec-websocket-accept header mismatch"
          | otherwise -> return () -- pass

      success resp conn
  where
    abort msg = throwIO (WsException ("wsUpgradeConnection: "++msg))