{-# 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,Int -> WsException -> ShowS
[WsException] -> ShowS
WsException -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [WsException] -> ShowS
$cshowList :: [WsException] -> ShowS
show :: WsException -> [Char]
$cshow :: WsException -> [Char]
showsPrec :: Int -> WsException -> ShowS
$cshowsPrec :: Int -> WsException -> ShowS
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
  { WSFrameHdr -> Bool
ws'FIN    :: !Bool -- ^ MUST be set for control-frames (control-frames MUST NOT be fragmented).
  , WSFrameHdr -> Bool
ws'RSV1   :: !Bool
  , WSFrameHdr -> Bool
ws'RSV2   :: !Bool
  , WSFrameHdr -> Bool
ws'RSV3   :: !Bool
  , WSFrameHdr -> WSOpcode
ws'opcode :: !WSOpcode -- see 'WSOpcode'
  , WSFrameHdr -> Word64
ws'length :: !Word64 -- ^ MUST be smaller than 2^63 for data-frames;
                         --   MUST be smaller than 126 for control-frames.
  , WSFrameHdr -> Maybe Word32
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 Int -> WSFrameHdr -> ShowS
[WSFrameHdr] -> ShowS
WSFrameHdr -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [WSFrameHdr] -> ShowS
$cshowList :: [WSFrameHdr] -> ShowS
show :: WSFrameHdr -> [Char]
$cshow :: WSFrameHdr -> [Char]
showsPrec :: Int -> WSFrameHdr -> ShowS
$cshowsPrec :: Int -> WSFrameHdr -> ShowS
Show

-- | Size of serialized WebSocket frame header (i.e. without payload data) in octets.
--
-- @since 0.1.4.0
wsFrameHdrSize :: WSFrameHdr -> Int
wsFrameHdrSize :: WSFrameHdr -> Int
wsFrameHdrSize WSFrameHdr{ws'mask :: WSFrameHdr -> Maybe Word32
ws'mask = Maybe Word32
Nothing, Word64
ws'length :: Word64
ws'length :: WSFrameHdr -> Word64
ws'length}
  | Word64
ws'length forall a. Ord a => a -> a -> Bool
<  Word64
126    = Int
2
  | Word64
ws'length forall a. Ord a => a -> a -> Bool
<= Word64
0xffff = Int
4
  | Bool
otherwise           = Int
10
wsFrameHdrSize WSFrameHdr{ws'mask :: WSFrameHdr -> Maybe Word32
ws'mask = Just Word32
_, Word64
ws'length :: Word64
ws'length :: WSFrameHdr -> Word64
ws'length}
  | Word64
ws'length forall a. Ord a => a -> a -> Bool
<  Word64
126    = Int
6
  | Word64
ws'length forall a. Ord a => a -> a -> Bool
<= Word64
0xffff = Int
8
  | Bool
otherwise           = Int
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 :: Connection -> IO (Maybe WSFrameHdr)
readWSFrameHdr (HC.Connection { cIn :: Connection -> InputStream ByteString
cIn = InputStream ByteString
is }) = do
    Maybe ByteString
mchunk <- forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
is
    case Maybe ByteString
mchunk of
      Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      Just ByteString
chunk -> Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
go forall a b. (a -> b) -> a -> b
$ (if ByteString -> Bool
BS.null ByteString
chunk then forall a. a -> a
id else forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Decoder a -> ByteString -> Decoder a
Bin.pushChunk ByteString
chunk)
                       forall a b. (a -> b) -> a -> b
$ forall a. Get a -> Decoder a
Bin.runGetIncremental forall t. Binary t => Get t
Bin.get
  where
    go :: Bin.Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
    go :: Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
go (Bin.Fail ByteString
rest ByteOffset
_ [Char]
err) = do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
rest) forall a b. (a -> b) -> a -> b
$
          forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
rest InputStream ByteString
is
        forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> WsException
WsException ([Char]
"readWSFrameHdr: " forall a. [a] -> [a] -> [a]
++ [Char]
err)
    go partial :: Decoder WSFrameHdr
partial@(Bin.Partial Maybe ByteString -> Decoder WSFrameHdr
cont) = do
        Maybe ByteString
mchunk <- forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
is
        case Maybe ByteString
mchunk of
          Maybe ByteString
Nothing -> Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
go (Maybe ByteString -> Decoder WSFrameHdr
cont forall a. Maybe a
Nothing) -- eof, will likely trigger failure
          Just ByteString
chunk
            | ByteString -> Bool
BS.null ByteString
chunk -> Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
go Decoder WSFrameHdr
partial -- loop
            | Bool
otherwise     -> Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
go (Maybe ByteString -> Decoder WSFrameHdr
cont (forall a. a -> Maybe a
Just ByteString
chunk))
    go (Bin.Done ByteString
rest ByteOffset
_ WSFrameHdr
x) = do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
rest) forall a b. (a -> b) -> a -> b
$
          forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
rest InputStream ByteString
is
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just WSFrameHdr
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 :: forall a.
Connection
-> (WSFrameHdr -> InputStream ByteString -> IO a) -> IO (Maybe a)
receiveWSFrame (conn :: Connection
conn@HC.Connection { cIn :: Connection -> InputStream ByteString
cIn = InputStream ByteString
is }) WSFrameHdr -> InputStream ByteString -> IO a
cont = do
  Maybe WSFrameHdr
mhdr <- Connection -> IO (Maybe WSFrameHdr)
readWSFrameHdr Connection
conn
  case Maybe WSFrameHdr
mhdr of
    Maybe WSFrameHdr
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Just WSFrameHdr
hdr
      | WSFrameHdr -> Word64
ws'length WSFrameHdr
hdr forall a. Eq a => a -> a -> Bool
== Word64
0 -> do
          InputStream ByteString
is' <- forall a. IO (InputStream a)
Streams.nullInput
          forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` WSFrameHdr -> InputStream ByteString -> IO a
cont WSFrameHdr
hdr InputStream ByteString
is'
      | Bool
otherwise -> do
          InputStream ByteString
is' <- ByteOffset -> InputStream ByteString -> IO (InputStream ByteString)
Streams.takeExactly (forall a b. (Integral a, Num b) => a -> b
fromIntegral (WSFrameHdr -> Word64
ws'length WSFrameHdr
hdr)) InputStream ByteString
is
          InputStream ByteString
is'' <- Word32 -> InputStream ByteString -> IO (InputStream ByteString)
xor32InputStream (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word32
0 forall a. a -> a
id (WSFrameHdr -> Maybe Word32
ws'mask WSFrameHdr
hdr)) InputStream ByteString
is'
          a
res <- WSFrameHdr -> InputStream ByteString -> IO a
cont WSFrameHdr
hdr InputStream ByteString
is''
          forall a. InputStream a -> IO ()
Streams.skipToEof InputStream ByteString
is'
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! a
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 :: forall a.
Connection
-> WSFrameHdr -> (OutputStream ByteString -> IO a) -> IO a
sendWSFragData Connection
_ WSFrameHdr
hdr0  OutputStream ByteString -> IO a
_
  | Bool -> Bool
not (WSOpcode -> Bool
wsIsDataFrame (WSFrameHdr -> WSOpcode
ws'opcode WSFrameHdr
hdr0))
      = forall e a. Exception e => e -> IO a
throwIO ([Char] -> WsException
WsException [Char]
"sendWSFragData: sending control-frame requested")
  | WSFrameHdr -> WSOpcode
ws'opcode WSFrameHdr
hdr0 forall a. Eq a => a -> a -> Bool
== WSOpcode
WSOpcode'Continuation
      = forall e a. Exception e => e -> IO a
throwIO ([Char] -> WsException
WsException [Char]
"sendWSFragData: sending continuation frame requested")
sendWSFragData (HC.Connection { cOut :: Connection -> OutputStream Builder
cOut = OutputStream Builder
os }) WSFrameHdr
hdr0 OutputStream ByteString -> IO a
cont = do
    IORef WSOpcode
opcodeRef <- forall a. a -> IO (IORef a)
newIORef (WSFrameHdr -> WSOpcode
ws'opcode WSFrameHdr
hdr0)
    let go :: Maybe ByteString -> IO ()
go Maybe ByteString
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        go (Just ByteString
chunk)
          | ByteString -> Bool
BS.null ByteString
chunk = forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
Builder.flush) OutputStream Builder
os
          | Bool
otherwise = do
              let (Word32
_,ByteString
chunk') = Word32 -> ByteString -> (Word32, ByteString)
xor32StrictByteString' (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word32
0 forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ WSFrameHdr -> Maybe Word32
ws'mask WSFrameHdr
hdr0) ByteString
chunk
              WSOpcode
opcode <- forall a. IORef a -> IO a
readIORef IORef WSOpcode
opcodeRef
              forall a. IORef a -> a -> IO ()
writeIORef IORef WSOpcode
opcodeRef WSOpcode
WSOpcode'Continuation
              let fraghdr :: WSFrameHdr
fraghdr = WSFrameHdr
hdr0 { ws'FIN :: Bool
ws'FIN = Bool
False
                                 , ws'length :: Word64
ws'length = forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
chunk)
                                 , ws'opcode :: WSOpcode
ws'opcode = WSOpcode
opcode
                                 }
              forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! WSFrameHdr -> Builder
wsFrameHdrToBuilder WSFrameHdr
fraghdr forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
Builder.fromByteString ByteString
chunk') OutputStream Builder
os

    OutputStream ByteString
os' <- forall a. (Maybe a -> IO ()) -> IO (OutputStream a)
Streams.makeOutputStream Maybe ByteString -> IO ()
go
    !a
res <- OutputStream ByteString -> IO a
cont OutputStream ByteString
os'

    -- send FINal frame
    WSOpcode
opcode <- forall a. IORef a -> IO a
readIORef IORef WSOpcode
opcodeRef
    let final :: WSFrameHdr
final = (WSFrameHdr
hdr0 { ws'FIN :: Bool
ws'FIN    = Bool
True
                      , ws'length :: Word64
ws'length = Word64
0
                      , ws'opcode :: WSOpcode
ws'opcode = WSOpcode
opcode
                      , ws'mask :: Maybe Word32
ws'mask   = forall a. a -> Maybe a
Just Word32
0
                      })
    forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ WSFrameHdr -> Builder
wsFrameHdrToBuilder WSFrameHdr
final forall a. Monoid a => a -> a -> a
`mappend` Builder
Builder.flush) OutputStream Builder
os

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! a
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 :: Connection -> WSOpcode -> Maybe Word32 -> ByteString -> IO ()
writeWSFrame (HC.Connection { cOut :: Connection -> OutputStream Builder
cOut = OutputStream Builder
os }) WSOpcode
opcode Maybe Word32
mmask ByteString
payload = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (WSOpcode -> Bool
wsIsDataFrame WSOpcode
opcode) Bool -> Bool -> Bool
&& Word64
plen forall a. Ord a => a -> a -> Bool
>= Word64
126) forall a b. (a -> b) -> a -> b
$
      forall e a. Exception e => e -> IO a
throwIO ([Char] -> WsException
WsException [Char]
"writeWSFrame: over-sized control-frame")

    let hdr :: Builder
hdr = WSFrameHdr -> Builder
wsFrameHdrToBuilder (Bool
-> Bool
-> Bool
-> Bool
-> WSOpcode
-> Word64
-> Maybe Word32
-> WSFrameHdr
WSFrameHdr Bool
True Bool
False Bool
False Bool
False WSOpcode
opcode Word64
plen Maybe Word32
mmask)
        dat :: Builder
dat = case Maybe Word32
mmask of
                Maybe Word32
Nothing  -> ByteString -> Builder
Builder.fromLazyByteString ByteString
payload
                Just Word32
0   -> ByteString -> Builder
Builder.fromLazyByteString ByteString
payload
                Just Word32
msk -> ByteString -> Builder
Builder.fromLazyByteString (Word32 -> ByteString -> ByteString
xor32LazyByteString Word32
msk ByteString
payload)
    forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Builder
hdr forall a. Monoid a => a -> a -> a
`mappend` Builder
dat forall a. Monoid a => a -> a -> a
`mappend` Builder
Builder.flush) OutputStream Builder
os
  where
    plen :: Word64
plen = forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> ByteOffset
BL.length ByteString
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 :: Int -> Connection -> IO (Maybe (WSFrameHdr, ByteString))
readWSFrame Int
maxSize (conn :: Connection
conn@HC.Connection { cIn :: Connection -> InputStream ByteString
cIn = InputStream ByteString
is }) = do
    Maybe WSFrameHdr
mhdr <- Connection -> IO (Maybe WSFrameHdr)
readWSFrameHdr Connection
conn
    case Maybe WSFrameHdr
mhdr of
      Maybe WSFrameHdr
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      Just WSFrameHdr
hdr
        | WSFrameHdr -> Word64
ws'length WSFrameHdr
hdr forall a. Eq a => a -> a -> Bool
== Word64
0 ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (WSFrameHdr
hdr,ByteString
BS.empty)
        | WSFrameHdr -> Word64
ws'length WSFrameHdr
hdr forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxSize ->
            forall e a. Exception e => e -> IO a
throwIO ([Char] -> WsException
WsException [Char]
"readWSFrame: frame larger than maxSize")
        | Bool
otherwise -> do
            ByteString
dat <- Int -> InputStream ByteString -> IO ByteString
Streams.readExactly (forall a b. (Integral a, Num b) => a -> b
fromIntegral (WSFrameHdr -> Word64
ws'length WSFrameHdr
hdr)) InputStream ByteString
is
            let dat' :: ByteString
dat' = case WSFrameHdr -> Maybe Word32
ws'mask WSFrameHdr
hdr of
                         Maybe Word32
Nothing -> ByteString
dat
                         Just Word32
0  -> ByteString
dat
                         Just Word32
m  -> forall a b. (a, b) -> b
snd (Word32 -> ByteString -> (Word32, ByteString)
xor32StrictByteString' Word32
m ByteString
dat)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (WSFrameHdr
hdr,ByteString
dat')

-- | Serialize 'WSFrameHdr' to 'BB.Builder'
--
-- @since 0.1.4.0
wsFrameHdrToBuilder :: WSFrameHdr -> Builder
wsFrameHdrToBuilder :: WSFrameHdr -> Builder
wsFrameHdrToBuilder WSFrameHdr{Bool
Maybe Word32
Word64
WSOpcode
ws'mask :: Maybe Word32
ws'length :: Word64
ws'opcode :: WSOpcode
ws'RSV3 :: Bool
ws'RSV2 :: Bool
ws'RSV1 :: Bool
ws'FIN :: Bool
ws'mask :: WSFrameHdr -> Maybe Word32
ws'length :: WSFrameHdr -> Word64
ws'opcode :: WSFrameHdr -> WSOpcode
ws'RSV3 :: WSFrameHdr -> Bool
ws'RSV2 :: WSFrameHdr -> Bool
ws'RSV1 :: WSFrameHdr -> Bool
ws'FIN :: WSFrameHdr -> Bool
..} = forall a. Monoid a => [a] -> a
mconcat
    [ Word8 -> Builder
Builder.fromWord8 forall a b. (a -> b) -> a -> b
$!
        (if Bool
ws'FIN  then Word8
0x80 else Word8
0) forall a. Bits a => a -> a -> a
.|.
        (if Bool
ws'RSV1 then Word8
0x40 else Word8
0) forall a. Bits a => a -> a -> a
.|.
        (if Bool
ws'RSV2 then Word8
0x20 else Word8
0) forall a. Bits a => a -> a -> a
.|.
        (if Bool
ws'RSV3 then Word8
0x10 else Word8
0) forall a. Bits a => a -> a -> a
.|.
        (WSOpcode -> Word8
encodeWSOpcode WSOpcode
ws'opcode)

    , Word8 -> Builder
Builder.fromWord8 forall a b. (a -> b) -> a -> b
$!
        (if forall a. Maybe a -> Bool
isJust Maybe Word32
ws'mask then Word8
0x80 else Word8
0) forall a. Bits a => a -> a -> a
.|. Word8
len7

    -- extended payload length
    , case Word8
len7 of
        Word8
126 -> Word16 -> Builder
Builder.fromWord16be (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ws'length)
        Word8
127 -> Word64 -> Builder
Builder.fromWord64be Word64
ws'length
        Word8
_   -> forall a. Monoid a => a
Data.Monoid.mempty

    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Word32 -> Builder
Builder.fromWord32be Maybe Word32
ws'mask
    ]
  where
    len7 :: Word8
len7 | Word64
ws'length forall a. Ord a => a -> a -> Bool
< Word64
126     = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ws'length
         | Word64
ws'length forall a. Ord a => a -> a -> Bool
<= Word64
0xffff = Word8
126 -- 16bit
         | Bool
otherwise           = Word8
127 -- 64bit

instance Bin.Binary WSFrameHdr where
  -- put :: WSFrameHdr -> Bin.Put
  put :: WSFrameHdr -> Put
put WSFrameHdr{Bool
Maybe Word32
Word64
WSOpcode
ws'mask :: Maybe Word32
ws'length :: Word64
ws'opcode :: WSOpcode
ws'RSV3 :: Bool
ws'RSV2 :: Bool
ws'RSV1 :: Bool
ws'FIN :: Bool
ws'mask :: WSFrameHdr -> Maybe Word32
ws'length :: WSFrameHdr -> Word64
ws'opcode :: WSFrameHdr -> WSOpcode
ws'RSV3 :: WSFrameHdr -> Bool
ws'RSV2 :: WSFrameHdr -> Bool
ws'RSV1 :: WSFrameHdr -> Bool
ws'FIN :: WSFrameHdr -> Bool
..} = do
      Word8 -> Put
Bin.putWord8 forall a b. (a -> b) -> a -> b
$!
        (if Bool
ws'FIN  then Word8
0x80 else Word8
0) forall a. Bits a => a -> a -> a
.|.
        (if Bool
ws'RSV1 then Word8
0x40 else Word8
0) forall a. Bits a => a -> a -> a
.|.
        (if Bool
ws'RSV2 then Word8
0x20 else Word8
0) forall a. Bits a => a -> a -> a
.|.
        (if Bool
ws'RSV3 then Word8
0x10 else Word8
0) forall a. Bits a => a -> a -> a
.|.
        (WSOpcode -> Word8
encodeWSOpcode WSOpcode
ws'opcode)

      Word8 -> Put
Bin.putWord8 forall a b. (a -> b) -> a -> b
$!
        (if forall a. Maybe a -> Bool
isJust Maybe Word32
ws'mask then Word8
0x80 else Word8
0) forall a. Bits a => a -> a -> a
.|. Word8
len7

      -- extended payload length
      case Word8
len7 of
        Word8
126 -> Word16 -> Put
Bin.putWord16be (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ws'length)
        Word8
127 -> Word64 -> Put
Bin.putWord64be Word64
ws'length
        Word8
_   -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) Word32 -> Put
Bin.putWord32be Maybe Word32
ws'mask
    where
      len7 :: Word8
len7 | Word64
ws'length forall a. Ord a => a -> a -> Bool
< Word64
126     = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ws'length
           | Word64
ws'length forall a. Ord a => a -> a -> Bool
<= Word64
0xffff = Word8
126 -- 16bit
           | Bool
otherwise           = Word8
127 -- 64bit

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

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

      let ws'FIN :: Bool
ws'FIN    = forall a. Bits a => a -> Int -> Bool
testBit Word8
o0 Int
7
          ws'RSV1 :: Bool
ws'RSV1   = forall a. Bits a => a -> Int -> Bool
testBit Word8
o0 Int
6
          ws'RSV2 :: Bool
ws'RSV2   = forall a. Bits a => a -> Int -> Bool
testBit Word8
o0 Int
5
          ws'RSV3 :: Bool
ws'RSV3   = forall a. Bits a => a -> Int -> Bool
testBit Word8
o0 Int
4
          ws'opcode :: WSOpcode
ws'opcode = Word8 -> WSOpcode
decodeWSOpcode Word8
o0

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
ws'FIN Bool -> Bool -> Bool
&& Bool -> Bool
not (WSOpcode -> Bool
wsIsDataFrame WSOpcode
ws'opcode)) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"invalid fragmented control-frame"

      Word8
o1 <- Get Word8
Bin.getWord8

      let len7 :: Word8
len7 = Word8
o1 forall a. Bits a => a -> a -> a
.&. Word8
0x7f
          msk :: Bool
msk  = Word8
o1  forall a. Ord a => a -> a -> Bool
>= Word8
0x80

      Word64
ws'length <- case Word8
len7 of
          Word8
127 -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WSOpcode -> Bool
wsIsDataFrame WSOpcode
ws'opcode) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"invalid 64-bit extended length (control-frame)"
            Word64
v <- Get Word64
Bin.getWord64be
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word64
v forall a. Ord a => a -> a -> Bool
> Word64
0xffff) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"invalid 64-bit extended length (<= 0xffff)"
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word64
v forall a. Ord a => a -> a -> Bool
< Word64
0x8000000000000000) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"invalid 64-bit extended length (MSB set)"
            forall (m :: * -> *) a. Monad m => a -> m a
return Word64
v
          Word8
126 -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WSOpcode -> Bool
wsIsDataFrame WSOpcode
ws'opcode) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"invalid 16-bit extended length (control-frame)"
            Word16
v <- Get Word16
Bin.getWord16be
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word16
v forall a. Ord a => a -> a -> Bool
> Word16
125) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"invalid 16-bit extended length (<= 0x7d)"
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
v)
          Word8
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
len7)

      Maybe Word32
ws'mask <- if Bool
msk
       then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Get Word32
Bin.getWord32be
       else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

      forall (m :: * -> *) a. Monad m => a -> m a
return WSFrameHdr{Bool
Maybe Word32
Word64
WSOpcode
ws'mask :: Maybe Word32
ws'length :: Word64
ws'opcode :: WSOpcode
ws'RSV3 :: Bool
ws'RSV2 :: Bool
ws'RSV1 :: Bool
ws'FIN :: Bool
ws'mask :: Maybe Word32
ws'length :: Word64
ws'opcode :: WSOpcode
ws'RSV3 :: Bool
ws'RSV2 :: Bool
ws'RSV1 :: Bool
ws'FIN :: Bool
..}

-- | 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 (WSOpcode -> WSOpcode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WSOpcode -> WSOpcode -> Bool
$c/= :: WSOpcode -> WSOpcode -> Bool
== :: WSOpcode -> WSOpcode -> Bool
$c== :: WSOpcode -> WSOpcode -> Bool
Eq,Int -> WSOpcode -> ShowS
[WSOpcode] -> ShowS
WSOpcode -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [WSOpcode] -> ShowS
$cshowList :: [WSOpcode] -> ShowS
show :: WSOpcode -> [Char]
$cshow :: WSOpcode -> [Char]
showsPrec :: Int -> WSOpcode -> ShowS
$cshowsPrec :: Int -> WSOpcode -> ShowS
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 (WSOpcodeReserved -> WSOpcodeReserved -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WSOpcodeReserved -> WSOpcodeReserved -> Bool
$c/= :: WSOpcodeReserved -> WSOpcodeReserved -> Bool
== :: WSOpcodeReserved -> WSOpcodeReserved -> Bool
$c== :: WSOpcodeReserved -> WSOpcodeReserved -> Bool
Eq,Int -> WSOpcodeReserved -> ShowS
[WSOpcodeReserved] -> ShowS
WSOpcodeReserved -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [WSOpcodeReserved] -> ShowS
$cshowList :: [WSOpcodeReserved] -> ShowS
show :: WSOpcodeReserved -> [Char]
$cshow :: WSOpcodeReserved -> [Char]
showsPrec :: Int -> WSOpcodeReserved -> ShowS
$cshowsPrec :: Int -> WSOpcodeReserved -> ShowS
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 :: WSOpcode -> Bool
wsIsDataFrame WSOpcode
x = case WSOpcode
x of
  WSOpcode
WSOpcode'Continuation                 -> Bool
True
  WSOpcode
WSOpcode'Text                         -> Bool
True
  WSOpcode
WSOpcode'Binary                       -> Bool
True

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

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

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


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

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

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

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

  Word8
_   -> forall a. HasCallStack => a
undefined -- impossible

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

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

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

  WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved11 -> Word8
0xB
  WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved12 -> Word8
0xC
  WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved13 -> Word8
0xD
  WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved14 -> Word8
0xE
  WSOpcode'Reserved WSOpcodeReserved
WSOpcode'Reserved15 -> Word8
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 :: SecWebSocketKey -> ByteString
wsKeyToAcceptB64 SecWebSocketKey
key = ByteString -> ByteString
B64.encode (ByteString -> ByteString
SHA1.hash (SecWebSocketKey -> ByteString
secWebSocketKeyToB64 SecWebSocketKey
key ByteString -> ByteString -> ByteString
`BS.append` ByteString
rfc6455Guid))
  where
    rfc6455Guid :: ByteString
    rfc6455Guid :: ByteString
rfc6455Guid = ByteString
"258EAFA5-E914-47DA-95CA-C5AB0DC85B11"

-- | @Sec-WebSocket-Key@ header value according to RFC 6455
--
-- @since 0.1.4.0
newtype SecWebSocketKey = WSKey ByteString deriving (SecWebSocketKey -> SecWebSocketKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SecWebSocketKey -> SecWebSocketKey -> Bool
$c/= :: SecWebSocketKey -> SecWebSocketKey -> Bool
== :: SecWebSocketKey -> SecWebSocketKey -> Bool
$c== :: SecWebSocketKey -> SecWebSocketKey -> Bool
Eq,Eq SecWebSocketKey
SecWebSocketKey -> SecWebSocketKey -> Bool
SecWebSocketKey -> SecWebSocketKey -> Ordering
SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey
$cmin :: SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey
max :: SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey
$cmax :: SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey
>= :: SecWebSocketKey -> SecWebSocketKey -> Bool
$c>= :: SecWebSocketKey -> SecWebSocketKey -> Bool
> :: SecWebSocketKey -> SecWebSocketKey -> Bool
$c> :: SecWebSocketKey -> SecWebSocketKey -> Bool
<= :: SecWebSocketKey -> SecWebSocketKey -> Bool
$c<= :: SecWebSocketKey -> SecWebSocketKey -> Bool
< :: SecWebSocketKey -> SecWebSocketKey -> Bool
$c< :: SecWebSocketKey -> SecWebSocketKey -> Bool
compare :: SecWebSocketKey -> SecWebSocketKey -> Ordering
$ccompare :: SecWebSocketKey -> SecWebSocketKey -> Ordering
Ord,Int -> SecWebSocketKey -> ShowS
[SecWebSocketKey] -> ShowS
SecWebSocketKey -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SecWebSocketKey] -> ShowS
$cshowList :: [SecWebSocketKey] -> ShowS
show :: SecWebSocketKey -> [Char]
$cshow :: SecWebSocketKey -> [Char]
showsPrec :: Int -> SecWebSocketKey -> ShowS
$cshowsPrec :: Int -> SecWebSocketKey -> ShowS
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 :: ByteString -> Maybe SecWebSocketKey
secWebSocketKeyFromB64 ByteString
key
  | ByteString -> Int
BS.length ByteString
key' forall a. Eq a => a -> a -> Bool
/= Int
24      = forall a. Maybe a
Nothing -- invalid base64 or wrong length
  | Left [Char]
_ <- ByteString -> Either [Char] ByteString
B64.decode ByteString
key' = forall a. Maybe a
Nothing -- invalid base64
  | Bool
otherwise                 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! ByteString -> SecWebSocketKey
WSKey ByteString
key'
  where
    -- strip leading/trailing OWS from key
    key' :: ByteString
key' = forall a b. (a, b) -> a
fst ((Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.spanEnd Word8 -> Bool
isOWS ((Word8 -> Bool) -> ByteString -> ByteString
BS.dropWhile Word8 -> Bool
isOWS ByteString
key))

    -- optional whitespace
    isOWS :: Word8 -> Bool
    isOWS :: Word8 -> Bool
isOWS Word8
0x09 = Bool
True
    isOWS Word8
0x20 = Bool
True
    isOWS Word8
_    = Bool
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 :: SecWebSocketKey -> ByteString
secWebSocketKeyToB64 (WSKey ByteString
bs) = ByteString
bs

-- | Construct 'SecWebSocketKey' from two 'Word64' values.
--
-- @since 0.1.4.0
secWebSocketKeyFromWords :: Word64 -> Word64 -> SecWebSocketKey
secWebSocketKeyFromWords :: Word64 -> Word64 -> SecWebSocketKey
secWebSocketKeyFromWords Word64
h Word64
l = ByteString -> SecWebSocketKey
WSKey (ByteString -> ByteString
B64.encode ByteString
key)
  where
    key :: ByteString
key = [ByteString] -> ByteString
BS.concat forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BL.toChunks forall a b. (a -> b) -> a -> b
$ Put -> ByteString
Bin.runPut (Word64 -> Put
Bin.putWord64be Word64
h forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word64 -> Put
Bin.putWord64be Word64
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 :: Word32 -> InputStream ByteString -> IO (InputStream ByteString)
xor32InputStream Word32
0    InputStream ByteString
is = forall (m :: * -> *) a. Monad m => a -> m a
return InputStream ByteString
is
xor32InputStream Word32
msk0 InputStream ByteString
is = do
    IORef Word32
mskref <- forall a. a -> IO (IORef a)
newIORef Word32
msk0
    let go :: IO (Maybe ByteString)
go = do
          Maybe ByteString
mchunk <- forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
is
          case Maybe ByteString
mchunk of
            Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just ByteString
chunk -> do
              Word32
msk <- forall a. IORef a -> IO a
readIORef IORef Word32
mskref
              let (Word32
msk',ByteString
chunk') = Word32 -> ByteString -> (Word32, ByteString)
xor32StrictByteString' Word32
msk ByteString
chunk
              forall a. IORef a -> a -> IO ()
writeIORef IORef Word32
mskref Word32
msk'
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! ByteString
chunk'
    forall a. IO (Maybe a) -> IO (InputStream a)
Streams.makeInputStream IO (Maybe ByteString)
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 :: forall α b.
Connection
-> ByteString
-> RequestBuilder α
-> SecWebSocketKey
-> (Response -> InputStream ByteString -> IO b)
-> (Response -> Connection -> IO b)
-> IO b
wsUpgradeConnection Connection
conn ByteString
resource RequestBuilder α
rqmod SecWebSocketKey
wskey Response -> InputStream ByteString -> IO b
failedToUpgrade Response -> Connection -> IO b
success = do
    let rqToWS :: Request
rqToWS = forall α. RequestBuilder α -> Request
HC.buildRequest1 forall a b. (a -> b) -> a -> b
$ do
          Method -> ByteString -> RequestBuilder ()
HC.http Method
HC.GET ByteString
resource
          ByteString -> ByteString -> RequestBuilder ()
HC.setHeader ByteString
"upgrade" ByteString
"websocket"
          ByteString -> ByteString -> RequestBuilder ()
HC.setHeader ByteString
"connection" ByteString
"Upgrade"
          ByteString -> ByteString -> RequestBuilder ()
HC.setHeader ByteString
"sec-websocket-version" ByteString
"13"
          ByteString -> ByteString -> RequestBuilder ()
HC.setHeader ByteString
"sec-websocket-key" (SecWebSocketKey -> ByteString
secWebSocketKeyToB64 SecWebSocketKey
wskey)
          RequestBuilder α
rqmod

    forall α.
Connection -> Request -> (OutputStream Builder -> IO α) -> IO α
HC.sendRequest Connection
conn Request
rqToWS OutputStream Builder -> IO ()
HC.emptyBody

    forall a.
Connection
-> (Response -> InputStream ByteString -> IO a)
-> (Response
    -> InputStream ByteString -> OutputStream Builder -> IO a)
-> IO a
HC.receiveUpgradeResponse Connection
conn Response -> InputStream ByteString -> IO b
failedToUpgrade forall a b. (a -> b) -> a -> b
$ \Response
resp InputStream ByteString
_is OutputStream Builder
_os -> do

      case forall s. FoldCase s => s -> CI s
CI.mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Response -> ByteString -> Maybe ByteString
HC.getHeader Response
resp ByteString
"connection" of
        Maybe (CI ByteString)
Nothing        -> forall {a}. [Char] -> IO a
abort [Char]
"missing 'connection' header"
        Just CI ByteString
"upgrade" -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just CI ByteString
_         -> forall {a}. [Char] -> IO a
abort [Char]
"'connection' header has non-'upgrade' value"

      case forall s. FoldCase s => s -> CI s
CI.mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Response -> ByteString -> Maybe ByteString
HC.getHeader Response
resp ByteString
"upgrade" of
        Maybe (CI ByteString)
Nothing          -> forall {a}. [Char] -> IO a
abort [Char]
"missing 'upgrade' header"
        Just CI ByteString
"websocket" -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just CI ByteString
_           -> forall {a}. [Char] -> IO a
abort [Char]
"'upgrade' header has non-'websocket' value"

      case Response -> ByteString -> Maybe ByteString
HC.getHeader Response
resp ByteString
"sec-websocket-accept" of
        Maybe ByteString
Nothing -> forall {a}. [Char] -> IO a
abort [Char]
"missing 'sec-websocket-accept' header"
        Just ByteString
wsacc
          | ByteString
wsacc forall a. Eq a => a -> a -> Bool
/= SecWebSocketKey -> ByteString
wsKeyToAcceptB64 SecWebSocketKey
wskey -> forall {a}. [Char] -> IO a
abort [Char]
"sec-websocket-accept header mismatch"
          | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- pass

      Response -> Connection -> IO b
success Response
resp Connection
conn
  where
    abort :: [Char] -> IO a
abort [Char]
msg = forall e a. Exception e => e -> IO a
throwIO ([Char] -> WsException
WsException ([Char]
"wsUpgradeConnection: "forall a. [a] -> [a] -> [a]
++[Char]
msg))