{-# 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]
(Int -> WsException -> ShowS)
-> (WsException -> [Char])
-> ([WsException] -> ShowS)
-> Show WsException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WsException -> ShowS
showsPrec :: Int -> WsException -> ShowS
$cshow :: WsException -> [Char]
show :: WsException -> [Char]
$cshowList :: [WsException] -> ShowS
showList :: [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]
(Int -> WSFrameHdr -> ShowS)
-> (WSFrameHdr -> [Char])
-> ([WSFrameHdr] -> ShowS)
-> Show WSFrameHdr
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WSFrameHdr -> ShowS
showsPrec :: Int -> WSFrameHdr -> ShowS
$cshow :: WSFrameHdr -> [Char]
show :: WSFrameHdr -> [Char]
$cshowList :: [WSFrameHdr] -> ShowS
showList :: [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 :: WSFrameHdr -> Word64
ws'length :: Word64
ws'length}
  | Word64
ws'length Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<  Word64
126    = Int
2
  | Word64
ws'length Word64 -> Word64 -> Bool
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 :: WSFrameHdr -> Word64
ws'length :: Word64
ws'length}
  | Word64
ws'length Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<  Word64
126    = Int
6
  | Word64
ws'length Word64 -> Word64 -> Bool
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 <- InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
is
    case Maybe ByteString
mchunk of
      Maybe ByteString
Nothing -> Maybe WSFrameHdr -> IO (Maybe WSFrameHdr)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe WSFrameHdr
forall a. Maybe a
Nothing
      Just ByteString
chunk -> Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
go (Decoder WSFrameHdr -> IO (Maybe WSFrameHdr))
-> Decoder WSFrameHdr -> IO (Maybe WSFrameHdr)
forall a b. (a -> b) -> a -> b
$ (if ByteString -> Bool
BS.null ByteString
chunk then Decoder WSFrameHdr -> Decoder WSFrameHdr
forall a. a -> a
id else (Decoder WSFrameHdr -> ByteString -> Decoder WSFrameHdr)
-> ByteString -> Decoder WSFrameHdr -> Decoder WSFrameHdr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Decoder WSFrameHdr -> ByteString -> Decoder WSFrameHdr
forall a. Decoder a -> ByteString -> Decoder a
Bin.pushChunk ByteString
chunk)
                       (Decoder WSFrameHdr -> Decoder WSFrameHdr)
-> Decoder WSFrameHdr -> Decoder WSFrameHdr
forall a b. (a -> b) -> a -> b
$ Get WSFrameHdr -> Decoder WSFrameHdr
forall a. Get a -> Decoder a
Bin.runGetIncremental Get WSFrameHdr
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
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
rest) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          ByteString -> InputStream ByteString -> IO ()
forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
rest InputStream ByteString
is
        WsException -> IO (Maybe WSFrameHdr)
forall e a. Exception e => e -> IO a
throwIO (WsException -> IO (Maybe WSFrameHdr))
-> WsException -> IO (Maybe WSFrameHdr)
forall a b. (a -> b) -> a -> b
$ [Char] -> WsException
WsException ([Char]
"readWSFrameHdr: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
err)
    go partial :: Decoder WSFrameHdr
partial@(Bin.Partial Maybe ByteString -> Decoder WSFrameHdr
cont) = do
        Maybe ByteString
mchunk <- InputStream ByteString -> IO (Maybe ByteString)
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 Maybe ByteString
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 (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
chunk))
    go (Bin.Done ByteString
rest ByteOffset
_ WSFrameHdr
x) = do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
rest) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          ByteString -> InputStream ByteString -> IO ()
forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
rest InputStream ByteString
is
        Maybe WSFrameHdr -> IO (Maybe WSFrameHdr)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WSFrameHdr -> Maybe WSFrameHdr
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 -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Just WSFrameHdr
hdr
      | WSFrameHdr -> Word64
ws'length WSFrameHdr
hdr Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 -> do
          InputStream ByteString
is' <- IO (InputStream ByteString)
forall a. IO (InputStream a)
Streams.nullInput
          a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> IO a -> IO b
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 (Word64 -> ByteOffset
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 (Word32 -> (Word32 -> Word32) -> Maybe Word32 -> Word32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word32
0 Word32 -> Word32
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''
          InputStream ByteString -> IO ()
forall a. InputStream a -> IO ()
Streams.skipToEof InputStream ByteString
is'
          Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$! a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
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))
      = WsException -> IO a
forall e a. Exception e => e -> IO a
throwIO ([Char] -> WsException
WsException [Char]
"sendWSFragData: sending control-frame requested")
  | WSFrameHdr -> WSOpcode
ws'opcode WSFrameHdr
hdr0 WSOpcode -> WSOpcode -> Bool
forall a. Eq a => a -> a -> Bool
== WSOpcode
WSOpcode'Continuation
      = WsException -> IO a
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 <- WSOpcode -> IO (IORef WSOpcode)
forall a. a -> IO (IORef a)
newIORef (WSFrameHdr -> WSOpcode
ws'opcode WSFrameHdr
hdr0)
    let go :: Maybe ByteString -> IO ()
go Maybe ByteString
Nothing = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        go (Just ByteString
chunk)
          | ByteString -> Bool
BS.null ByteString
chunk = Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
Builder.flush) OutputStream Builder
os
          | Bool
otherwise = do
              let (Word32
_,ByteString
chunk') = Word32 -> ByteString -> (Word32, ByteString)
xor32StrictByteString' (Word32 -> (Word32 -> Word32) -> Maybe Word32 -> Word32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word32
0 Word32 -> Word32
forall a. a -> a
id (Maybe Word32 -> Word32) -> Maybe Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ WSFrameHdr -> Maybe Word32
ws'mask WSFrameHdr
hdr0) ByteString
chunk
              WSOpcode
opcode <- IORef WSOpcode -> IO WSOpcode
forall a. IORef a -> IO a
readIORef IORef WSOpcode
opcodeRef
              IORef WSOpcode -> WSOpcode -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef WSOpcode
opcodeRef WSOpcode
WSOpcode'Continuation
              let fraghdr :: WSFrameHdr
fraghdr = WSFrameHdr
hdr0 { ws'FIN = False
                                 , ws'length = fromIntegral (BS.length chunk)
                                 , ws'opcode = opcode
                                 }
              Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$! WSFrameHdr -> Builder
wsFrameHdrToBuilder WSFrameHdr
fraghdr Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
Builder.fromByteString ByteString
chunk') OutputStream Builder
os

    OutputStream ByteString
os' <- (Maybe ByteString -> IO ()) -> IO (OutputStream ByteString)
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 <- IORef WSOpcode -> IO WSOpcode
forall a. IORef a -> IO a
readIORef IORef WSOpcode
opcodeRef
    let final :: WSFrameHdr
final = (WSFrameHdr
hdr0 { ws'FIN    = True
                      , ws'length = 0
                      , ws'opcode = opcode
                      , ws'mask   = Just 0
                      })
    Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ WSFrameHdr -> Builder
wsFrameHdrToBuilder WSFrameHdr
final Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
Builder.flush) OutputStream Builder
os

    a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (WSOpcode -> Bool
wsIsDataFrame WSOpcode
opcode) Bool -> Bool -> Bool
&& Word64
plen Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
126) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      WsException -> IO ()
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)
    Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ Builder
hdr Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
dat Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
Builder.flush) OutputStream Builder
os
  where
    plen :: Word64
plen = ByteOffset -> Word64
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 -> Maybe (WSFrameHdr, ByteString)
-> IO (Maybe (WSFrameHdr, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (WSFrameHdr, ByteString)
forall a. Maybe a
Nothing
      Just WSFrameHdr
hdr
        | WSFrameHdr -> Word64
ws'length WSFrameHdr
hdr Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 ->
            Maybe (WSFrameHdr, ByteString)
-> IO (Maybe (WSFrameHdr, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (WSFrameHdr, ByteString)
 -> IO (Maybe (WSFrameHdr, ByteString)))
-> Maybe (WSFrameHdr, ByteString)
-> IO (Maybe (WSFrameHdr, ByteString))
forall a b. (a -> b) -> a -> b
$ (WSFrameHdr, ByteString) -> Maybe (WSFrameHdr, ByteString)
forall a. a -> Maybe a
Just (WSFrameHdr
hdr,ByteString
BS.empty)
        | WSFrameHdr -> Word64
ws'length WSFrameHdr
hdr Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxSize ->
            WsException -> IO (Maybe (WSFrameHdr, ByteString))
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 (Word64 -> Int
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  -> (Word32, ByteString) -> ByteString
forall a b. (a, b) -> b
snd (Word32 -> ByteString -> (Word32, ByteString)
xor32StrictByteString' Word32
m ByteString
dat)
            Maybe (WSFrameHdr, ByteString)
-> IO (Maybe (WSFrameHdr, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (WSFrameHdr, ByteString)
 -> IO (Maybe (WSFrameHdr, ByteString)))
-> Maybe (WSFrameHdr, ByteString)
-> IO (Maybe (WSFrameHdr, ByteString))
forall a b. (a -> b) -> a -> b
$ (WSFrameHdr, ByteString) -> Maybe (WSFrameHdr, ByteString)
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'FIN :: WSFrameHdr -> Bool
ws'RSV1 :: WSFrameHdr -> Bool
ws'RSV2 :: WSFrameHdr -> Bool
ws'RSV3 :: WSFrameHdr -> Bool
ws'opcode :: WSFrameHdr -> WSOpcode
ws'length :: WSFrameHdr -> Word64
ws'mask :: WSFrameHdr -> Maybe Word32
ws'FIN :: Bool
ws'RSV1 :: Bool
ws'RSV2 :: Bool
ws'RSV3 :: Bool
ws'opcode :: WSOpcode
ws'length :: Word64
ws'mask :: Maybe Word32
..} = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ Word8 -> Builder
Builder.fromWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$!
        (if Bool
ws'FIN  then Word8
0x80 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
        (if Bool
ws'RSV1 then Word8
0x40 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
        (if Bool
ws'RSV2 then Word8
0x20 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
        (if Bool
ws'RSV3 then Word8
0x10 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
        (WSOpcode -> Word8
encodeWSOpcode WSOpcode
ws'opcode)

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

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

    , Builder -> (Word32 -> Builder) -> Maybe Word32 -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty Word32 -> Builder
Builder.fromWord32be Maybe Word32
ws'mask
    ]
  where
    len7 :: Word8
len7 | Word64
ws'length Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
126     = Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ws'length
         | Word64
ws'length Word64 -> Word64 -> Bool
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'FIN :: WSFrameHdr -> Bool
ws'RSV1 :: WSFrameHdr -> Bool
ws'RSV2 :: WSFrameHdr -> Bool
ws'RSV3 :: WSFrameHdr -> Bool
ws'opcode :: WSFrameHdr -> WSOpcode
ws'length :: WSFrameHdr -> Word64
ws'mask :: WSFrameHdr -> Maybe Word32
ws'FIN :: Bool
ws'RSV1 :: Bool
ws'RSV2 :: Bool
ws'RSV3 :: Bool
ws'opcode :: WSOpcode
ws'length :: Word64
ws'mask :: Maybe Word32
..} = do
      Word8 -> Put
Bin.putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$!
        (if Bool
ws'FIN  then Word8
0x80 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
        (if Bool
ws'RSV1 then Word8
0x40 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
        (if Bool
ws'RSV2 then Word8
0x20 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
        (if Bool
ws'RSV3 then Word8
0x10 else Word8
0) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
        (WSOpcode -> Word8
encodeWSOpcode WSOpcode
ws'opcode)

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

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

      Put -> (Word32 -> Put) -> Maybe Word32 -> Put
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Put
forall a. a -> PutM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Word32 -> Put
Bin.putWord32be Maybe Word32
ws'mask
    where
      len7 :: Word8
len7 | Word64
ws'length Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
126     = Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ws'length
           | Word64
ws'length Word64 -> Word64 -> Bool
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    = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
o0 Int
7
          ws'RSV1 :: Bool
ws'RSV1   = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
o0 Int
6
          ws'RSV2 :: Bool
ws'RSV2   = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
o0 Int
5
          ws'RSV3 :: Bool
ws'RSV3   = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
o0 Int
4
          ws'opcode :: WSOpcode
ws'opcode = Word8 -> WSOpcode
decodeWSOpcode Word8
o0

      Bool -> Get () -> Get ()
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)) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> Get ()
forall a. [Char] -> Get a
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 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7f
          msk :: Bool
msk  = Word8
o1  Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0x80

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

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

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

-- | 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
(WSOpcode -> WSOpcode -> Bool)
-> (WSOpcode -> WSOpcode -> Bool) -> Eq WSOpcode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WSOpcode -> WSOpcode -> Bool
== :: WSOpcode -> WSOpcode -> Bool
$c/= :: WSOpcode -> WSOpcode -> Bool
/= :: WSOpcode -> WSOpcode -> Bool
Eq,Int -> WSOpcode -> ShowS
[WSOpcode] -> ShowS
WSOpcode -> [Char]
(Int -> WSOpcode -> ShowS)
-> (WSOpcode -> [Char]) -> ([WSOpcode] -> ShowS) -> Show WSOpcode
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WSOpcode -> ShowS
showsPrec :: Int -> WSOpcode -> ShowS
$cshow :: WSOpcode -> [Char]
show :: WSOpcode -> [Char]
$cshowList :: [WSOpcode] -> ShowS
showList :: [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
(WSOpcodeReserved -> WSOpcodeReserved -> Bool)
-> (WSOpcodeReserved -> WSOpcodeReserved -> Bool)
-> Eq WSOpcodeReserved
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WSOpcodeReserved -> WSOpcodeReserved -> Bool
== :: WSOpcodeReserved -> WSOpcodeReserved -> Bool
$c/= :: WSOpcodeReserved -> WSOpcodeReserved -> Bool
/= :: WSOpcodeReserved -> WSOpcodeReserved -> Bool
Eq,Int -> WSOpcodeReserved -> ShowS
[WSOpcodeReserved] -> ShowS
WSOpcodeReserved -> [Char]
(Int -> WSOpcodeReserved -> ShowS)
-> (WSOpcodeReserved -> [Char])
-> ([WSOpcodeReserved] -> ShowS)
-> Show WSOpcodeReserved
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WSOpcodeReserved -> ShowS
showsPrec :: Int -> WSOpcodeReserved -> ShowS
$cshow :: WSOpcodeReserved -> [Char]
show :: WSOpcodeReserved -> [Char]
$cshowList :: [WSOpcodeReserved] -> ShowS
showList :: [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 Word8 -> Word8 -> Word8
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
_   -> WSOpcode
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
(SecWebSocketKey -> SecWebSocketKey -> Bool)
-> (SecWebSocketKey -> SecWebSocketKey -> Bool)
-> Eq SecWebSocketKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SecWebSocketKey -> SecWebSocketKey -> Bool
== :: SecWebSocketKey -> SecWebSocketKey -> Bool
$c/= :: SecWebSocketKey -> SecWebSocketKey -> Bool
/= :: SecWebSocketKey -> SecWebSocketKey -> Bool
Eq,Eq SecWebSocketKey
Eq SecWebSocketKey =>
(SecWebSocketKey -> SecWebSocketKey -> Ordering)
-> (SecWebSocketKey -> SecWebSocketKey -> Bool)
-> (SecWebSocketKey -> SecWebSocketKey -> Bool)
-> (SecWebSocketKey -> SecWebSocketKey -> Bool)
-> (SecWebSocketKey -> SecWebSocketKey -> Bool)
-> (SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey)
-> (SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey)
-> Ord 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
$ccompare :: SecWebSocketKey -> SecWebSocketKey -> Ordering
compare :: SecWebSocketKey -> SecWebSocketKey -> Ordering
$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
>= :: SecWebSocketKey -> SecWebSocketKey -> Bool
$cmax :: SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey
max :: SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey
$cmin :: SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey
min :: SecWebSocketKey -> SecWebSocketKey -> SecWebSocketKey
Ord,Int -> SecWebSocketKey -> ShowS
[SecWebSocketKey] -> ShowS
SecWebSocketKey -> [Char]
(Int -> SecWebSocketKey -> ShowS)
-> (SecWebSocketKey -> [Char])
-> ([SecWebSocketKey] -> ShowS)
-> Show SecWebSocketKey
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SecWebSocketKey -> ShowS
showsPrec :: Int -> SecWebSocketKey -> ShowS
$cshow :: SecWebSocketKey -> [Char]
show :: SecWebSocketKey -> [Char]
$cshowList :: [SecWebSocketKey] -> ShowS
showList :: [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' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
24      = Maybe SecWebSocketKey
forall a. Maybe a
Nothing -- invalid base64 or wrong length
  | Left [Char]
_ <- ByteString -> Either [Char] ByteString
B64.decode ByteString
key' = Maybe SecWebSocketKey
forall a. Maybe a
Nothing -- invalid base64
  | Bool
otherwise                 = SecWebSocketKey -> Maybe SecWebSocketKey
forall a. a -> Maybe a
Just (SecWebSocketKey -> Maybe SecWebSocketKey)
-> SecWebSocketKey -> Maybe SecWebSocketKey
forall a b. (a -> b) -> a -> b
$! ByteString -> SecWebSocketKey
WSKey ByteString
key'
  where
    -- strip leading/trailing OWS from key
    key' :: ByteString
key' = (ByteString, ByteString) -> ByteString
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 ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BL.toChunks (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
Bin.runPut (Word64 -> Put
Bin.putWord64be Word64
h Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
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 = InputStream ByteString -> IO (InputStream ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InputStream ByteString
is
xor32InputStream Word32
msk0 InputStream ByteString
is = do
    IORef Word32
mskref <- Word32 -> IO (IORef Word32)
forall a. a -> IO (IORef a)
newIORef Word32
msk0
    let go :: IO (Maybe ByteString)
go = do
          Maybe ByteString
mchunk <- InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
is
          case Maybe ByteString
mchunk of
            Maybe ByteString
Nothing -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
            Just ByteString
chunk -> do
              Word32
msk <- IORef Word32 -> IO Word32
forall a. IORef a -> IO a
readIORef IORef Word32
mskref
              let (Word32
msk',ByteString
chunk') = Word32 -> ByteString -> (Word32, ByteString)
xor32StrictByteString' Word32
msk ByteString
chunk
              IORef Word32 -> Word32 -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Word32
mskref Word32
msk'
              Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$! ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$! ByteString
chunk'
    IO (Maybe ByteString) -> IO (InputStream ByteString)
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 = RequestBuilder α -> Request
forall α. RequestBuilder α -> Request
HC.buildRequest1 (RequestBuilder α -> Request) -> RequestBuilder α -> Request
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

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

    Connection
-> (Response -> InputStream ByteString -> IO b)
-> (Response
    -> InputStream ByteString -> OutputStream Builder -> IO b)
-> IO b
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 ((Response
  -> InputStream ByteString -> OutputStream Builder -> IO b)
 -> IO b)
-> (Response
    -> InputStream ByteString -> OutputStream Builder -> IO b)
-> IO b
forall a b. (a -> b) -> a -> b
$ \Response
resp InputStream ByteString
_is OutputStream Builder
_os -> do

      case ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString)
-> Maybe ByteString -> Maybe (CI ByteString)
forall a b. (a -> b) -> Maybe a -> Maybe b
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        -> [Char] -> IO ()
forall {a}. [Char] -> IO a
abort [Char]
"missing 'connection' header"
        Just CI ByteString
"upgrade" -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just CI ByteString
_         -> [Char] -> IO ()
forall {a}. [Char] -> IO a
abort [Char]
"'connection' header has non-'upgrade' value"

      case ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString)
-> Maybe ByteString -> Maybe (CI ByteString)
forall a b. (a -> b) -> Maybe a -> Maybe b
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          -> [Char] -> IO ()
forall {a}. [Char] -> IO a
abort [Char]
"missing 'upgrade' header"
        Just CI ByteString
"websocket" -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just CI ByteString
_           -> [Char] -> IO ()
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 -> [Char] -> IO ()
forall {a}. [Char] -> IO a
abort [Char]
"missing 'sec-websocket-accept' header"
        Just ByteString
wsacc
          | ByteString
wsacc ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= SecWebSocketKey -> ByteString
wsKeyToAcceptB64 SecWebSocketKey
wskey -> [Char] -> IO ()
forall {a}. [Char] -> IO a
abort [Char]
"sec-websocket-accept header mismatch"
          | Bool
otherwise -> () -> IO ()
forall a. a -> IO a
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 = WsException -> IO a
forall e a. Exception e => e -> IO a
throwIO ([Char] -> WsException
WsException ([Char]
"wsUpgradeConnection: "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
msg))