--------------------------------------------------------------------------------
-- | This module exposes connection internals
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Connection
    ( PendingConnection (..)
    , acceptRequest
    , AcceptRequest(..)
    , defaultAcceptRequest
    , acceptRequestWith
    , rejectRequest
    , RejectRequest(..)
    , defaultRejectRequest
    , rejectRequestWith

    , Connection (..)

    , ConnectionOptions (..)
    , defaultConnectionOptions

    , receive
    , receiveDataMessage
    , receiveData
    , send
    , sendDataMessage
    , sendDataMessages
    , sendTextData
    , sendTextDatas
    , sendBinaryData
    , sendBinaryDatas
    , sendClose
    , sendCloseCode
    , sendPing
    , sendPong

    , withPingThread
    , forkPingThread
    , pingThread

    , CompressionOptions (..)
    , PermessageDeflate (..)
    , defaultPermessageDeflate

    , SizeLimit (..)
    ) where


--------------------------------------------------------------------------------
import           Control.Applicative                             ((<$>))
import           Control.Concurrent                              (forkIO,
                                                                  threadDelay)
import qualified Control.Concurrent.Async                        as Async
import           Control.Concurrent.MVar                         (MVar, newEmptyMVar, tryPutMVar)
import           Control.Exception                               (AsyncException,
                                                                  fromException,
                                                                  handle,
                                                                  throwIO)
import           Control.Monad                                   (foldM, unless,
                                                                  when)
import qualified Data.ByteString                                 as B
import qualified Data.ByteString.Builder                         as Builder
import qualified Data.ByteString.Char8                           as B8
import           Data.IORef                                      (IORef,
                                                                  newIORef,
                                                                  readIORef,
                                                                  writeIORef)
import           Data.List                                       (find)
import           Data.Maybe                                      (catMaybes)
import qualified Data.Text                                       as T
import           Data.Word                                       (Word16)
import           Prelude


--------------------------------------------------------------------------------
import           Network.WebSockets.Connection.Options
import           Network.WebSockets.Extensions                   as Extensions
import           Network.WebSockets.Extensions.PermessageDeflate
import           Network.WebSockets.Extensions.StrictUnicode
import           Network.WebSockets.Http
import           Network.WebSockets.Protocol
import           Network.WebSockets.Stream                       (Stream)
import qualified Network.WebSockets.Stream                       as Stream
import           Network.WebSockets.Types


--------------------------------------------------------------------------------
-- | A new client connected to the server. We haven't accepted the connection
-- yet, though.
data PendingConnection = PendingConnection
    { PendingConnection -> ConnectionOptions
pendingOptions  :: !ConnectionOptions
    -- ^ Options, passed as-is to the 'Connection'
    , PendingConnection -> RequestHead
pendingRequest  :: !RequestHead
    -- ^ Useful for e.g. inspecting the request path.
    , PendingConnection -> Connection -> IO ()
pendingOnAccept :: !(Connection -> IO ())
    -- ^ One-shot callback fired when a connection is accepted, i.e., *after*
    -- the accepting response is sent to the client.
    , PendingConnection -> Stream
pendingStream   :: !Stream
    -- ^ Input/output stream
    }


--------------------------------------------------------------------------------
-- | This datatype allows you to set options for 'acceptRequestWith'.  It is
-- strongly recommended to use 'defaultAcceptRequest' and then modify the
-- various fields, that way new fields introduced in the library do not break
-- your code.
data AcceptRequest = AcceptRequest
    { AcceptRequest -> Maybe ByteString
acceptSubprotocol :: !(Maybe B.ByteString)
    -- ^ The subprotocol to speak with the client.  If 'pendingSubprotcols' is
    -- non-empty, 'acceptSubprotocol' must be one of the subprotocols from the
    -- list.
    , AcceptRequest -> Headers
acceptHeaders     :: !Headers
    -- ^ Extra headers to send with the response.
    }


--------------------------------------------------------------------------------
defaultAcceptRequest :: AcceptRequest
defaultAcceptRequest :: AcceptRequest
defaultAcceptRequest = Maybe ByteString -> Headers -> AcceptRequest
AcceptRequest forall a. Maybe a
Nothing []


--------------------------------------------------------------------------------
-- | Utility
sendResponse :: PendingConnection -> Response -> IO ()
sendResponse :: PendingConnection -> Response -> IO ()
sendResponse PendingConnection
pc Response
rsp = Stream -> ByteString -> IO ()
Stream.write (PendingConnection -> Stream
pendingStream PendingConnection
pc)
    (Builder -> ByteString
Builder.toLazyByteString (Response -> Builder
encodeResponse Response
rsp))


--------------------------------------------------------------------------------
-- | Accept a pending connection, turning it into a 'Connection'.
acceptRequest :: PendingConnection -> IO Connection
acceptRequest :: PendingConnection -> IO Connection
acceptRequest PendingConnection
pc = PendingConnection -> AcceptRequest -> IO Connection
acceptRequestWith PendingConnection
pc AcceptRequest
defaultAcceptRequest


--------------------------------------------------------------------------------
-- | This function is like 'acceptRequest' but allows you to set custom options
-- using the 'AcceptRequest' datatype.
acceptRequestWith :: PendingConnection -> AcceptRequest -> IO Connection
acceptRequestWith :: PendingConnection -> AcceptRequest -> IO Connection
acceptRequestWith PendingConnection
pc AcceptRequest
ar = case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a b c. (a -> b -> c) -> b -> a -> c
flip Protocol -> RequestHead -> Bool
compatible RequestHead
request) [Protocol]
protocols of
    Maybe Protocol
Nothing       -> do
        PendingConnection -> Response -> IO ()
sendResponse PendingConnection
pc forall a b. (a -> b) -> a -> b
$ Headers -> ByteString -> Response
response400 Headers
versionHeader ByteString
""
        forall e a. Exception e => e -> IO a
throwIO HandshakeException
NotSupported
    Just Protocol
protocol -> do

        -- Get requested list of exceptions from client.
        ExtensionDescriptions
rqExts <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
            RequestHead -> Either HandshakeException ExtensionDescriptions
getRequestSecWebSocketExtensions RequestHead
request

        -- Set up permessage-deflate extension if configured.
        Maybe Extension
pmdExt <- case ConnectionOptions -> CompressionOptions
connectionCompressionOptions (PendingConnection -> ConnectionOptions
pendingOptions PendingConnection
pc) of
            CompressionOptions
NoCompression                     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            PermessageDeflateCompression PermessageDeflate
pmd0 ->
                case SizeLimit -> Maybe PermessageDeflate -> NegotiateExtension
negotiateDeflate (ConnectionOptions -> SizeLimit
connectionMessageDataSizeLimit ConnectionOptions
options) (forall a. a -> Maybe a
Just PermessageDeflate
pmd0) ExtensionDescriptions
rqExts of
                    Left String
err   -> do
                        PendingConnection -> RejectRequest -> IO ()
rejectRequestWith PendingConnection
pc RejectRequest
defaultRejectRequest {rejectMessage :: ByteString
rejectMessage = String -> ByteString
B8.pack String
err}
                        forall e a. Exception e => e -> IO a
throwIO HandshakeException
NotSupported
                    Right Extension
pmd1 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Extension
pmd1)

        -- Set up strict utf8 extension if configured.
        let unicodeExt :: Maybe Extension
unicodeExt =
                if ConnectionOptions -> Bool
connectionStrictUnicode (PendingConnection -> ConnectionOptions
pendingOptions PendingConnection
pc)
                    then forall a. a -> Maybe a
Just Extension
strictUnicode else forall a. Maybe a
Nothing

        -- Final extension list.
        let exts :: [Extension]
exts = forall a. [Maybe a] -> [a]
catMaybes [Maybe Extension
pmdExt, Maybe Extension
unicodeExt]

        let subproto :: Headers
subproto = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\ByteString
p -> [(CI ByteString
"Sec-WebSocket-Protocol", ByteString
p)]) forall a b. (a -> b) -> a -> b
$ AcceptRequest -> Maybe ByteString
acceptSubprotocol AcceptRequest
ar
            headers :: Headers
headers = Headers
subproto forall a. [a] -> [a] -> [a]
++ AcceptRequest -> Headers
acceptHeaders AcceptRequest
ar forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Extension -> Headers
extHeaders [Extension]
exts
            response :: Either HandshakeException Response
response = Protocol
-> RequestHead -> Headers -> Either HandshakeException Response
finishRequest Protocol
protocol RequestHead
request Headers
headers

        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO (PendingConnection -> Response -> IO ()
sendResponse PendingConnection
pc) Either HandshakeException Response
response

        IO (Maybe Message)
parseRaw <- Protocol
-> SizeLimit -> SizeLimit -> Stream -> IO (IO (Maybe Message))
decodeMessages
            Protocol
protocol
            (ConnectionOptions -> SizeLimit
connectionFramePayloadSizeLimit ConnectionOptions
options)
            (ConnectionOptions -> SizeLimit
connectionMessageDataSizeLimit ConnectionOptions
options)
            (PendingConnection -> Stream
pendingStream PendingConnection
pc)
        [Message] -> IO ()
writeRaw <- Protocol -> ConnectionType -> Stream -> IO ([Message] -> IO ())
encodeMessages Protocol
protocol ConnectionType
ServerConnection (PendingConnection -> Stream
pendingStream PendingConnection
pc)

        [Message] -> IO ()
write <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\[Message] -> IO ()
x Extension
ext -> Extension -> ([Message] -> IO ()) -> IO ([Message] -> IO ())
extWrite Extension
ext [Message] -> IO ()
x) [Message] -> IO ()
writeRaw [Extension]
exts
        IO (Maybe Message)
parse <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\IO (Maybe Message)
x Extension
ext -> Extension -> IO (Maybe Message) -> IO (IO (Maybe Message))
extParse Extension
ext IO (Maybe Message)
x) IO (Maybe Message)
parseRaw [Extension]
exts

        IORef Bool
sentRef <- forall a. a -> IO (IORef a)
newIORef Bool
False
        MVar ()
heartbeat <- forall a. IO (MVar a)
newEmptyMVar
        let connection :: Connection
connection = Connection
                { connectionOptions :: ConnectionOptions
connectionOptions   = ConnectionOptions
options
                , connectionType :: ConnectionType
connectionType      = ConnectionType
ServerConnection
                , connectionProtocol :: Protocol
connectionProtocol  = Protocol
protocol
                , connectionParse :: IO (Maybe Message)
connectionParse     = IO (Maybe Message)
parse
                , connectionWrite :: [Message] -> IO ()
connectionWrite     = [Message] -> IO ()
write
                , connectionHeartbeat :: MVar ()
connectionHeartbeat = MVar ()
heartbeat
                , connectionSentClose :: IORef Bool
connectionSentClose = IORef Bool
sentRef
                }

        PendingConnection -> Connection -> IO ()
pendingOnAccept PendingConnection
pc Connection
connection
        forall (m :: * -> *) a. Monad m => a -> m a
return Connection
connection
  where
    options :: ConnectionOptions
options       = PendingConnection -> ConnectionOptions
pendingOptions PendingConnection
pc
    request :: RequestHead
request       = PendingConnection -> RequestHead
pendingRequest PendingConnection
pc
    versionHeader :: Headers
versionHeader = [(CI ByteString
"Sec-WebSocket-Version",
        ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
", " forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Protocol -> [ByteString]
headerVersions [Protocol]
protocols)]


--------------------------------------------------------------------------------
-- | Parameters that allow you to tweak how a request is rejected.  Please use
-- 'defaultRejectRequest' and modify fields using record syntax so your code
-- will not break when new fields are added.
data RejectRequest = RejectRequest
    { -- | The status code, 400 by default.
      RejectRequest -> Int
rejectCode    :: !Int
    , -- | The message, "Bad Request" by default
      RejectRequest -> ByteString
rejectMessage :: !B.ByteString
    , -- | Extra headers to be sent with the response.
      RejectRequest -> Headers
rejectHeaders :: Headers
    , -- | Reponse body of the rejection.
      RejectRequest -> ByteString
rejectBody    :: !B.ByteString
    }


--------------------------------------------------------------------------------
defaultRejectRequest :: RejectRequest
defaultRejectRequest :: RejectRequest
defaultRejectRequest = RejectRequest
    { rejectCode :: Int
rejectCode    = Int
400
    , rejectMessage :: ByteString
rejectMessage = ByteString
"Bad Request"
    , rejectHeaders :: Headers
rejectHeaders = []
    , rejectBody :: ByteString
rejectBody    = ByteString
""
    }


--------------------------------------------------------------------------------
rejectRequestWith
    :: PendingConnection  -- ^ Connection to reject
    -> RejectRequest      -- ^ Params on how to reject the request
    -> IO ()
rejectRequestWith :: PendingConnection -> RejectRequest -> IO ()
rejectRequestWith PendingConnection
pc RejectRequest
reject = PendingConnection -> Response -> IO ()
sendResponse PendingConnection
pc forall a b. (a -> b) -> a -> b
$ ResponseHead -> ByteString -> Response
Response
    ResponseHead
        { responseCode :: Int
responseCode    = RejectRequest -> Int
rejectCode RejectRequest
reject
        , responseMessage :: ByteString
responseMessage = RejectRequest -> ByteString
rejectMessage RejectRequest
reject
        , responseHeaders :: Headers
responseHeaders = RejectRequest -> Headers
rejectHeaders RejectRequest
reject
        }
    (RejectRequest -> ByteString
rejectBody RejectRequest
reject)


--------------------------------------------------------------------------------
-- | Requires calling 'pendingStream' and 'Stream.close'.
rejectRequest
    :: PendingConnection  -- ^ Connection to reject
    -> B.ByteString       -- ^ Rejection response body
    -> IO ()
rejectRequest :: PendingConnection -> ByteString -> IO ()
rejectRequest PendingConnection
pc ByteString
body = PendingConnection -> RejectRequest -> IO ()
rejectRequestWith PendingConnection
pc
    RejectRequest
defaultRejectRequest {rejectBody :: ByteString
rejectBody = ByteString
body}


--------------------------------------------------------------------------------
data Connection = Connection
    { Connection -> ConnectionOptions
connectionOptions   :: !ConnectionOptions
    , Connection -> ConnectionType
connectionType      :: !ConnectionType
    , Connection -> Protocol
connectionProtocol  :: !Protocol
    , Connection -> MVar ()
connectionHeartbeat :: !(MVar ())
    -- ^ This MVar is filled whenever a pong is received.  This is used by
    -- 'withPingPong' to timeout the connection if a pong is not received.
    , Connection -> IO (Maybe Message)
connectionParse     :: !(IO (Maybe Message))
    , Connection -> [Message] -> IO ()
connectionWrite     :: !([Message] -> IO ())
    , Connection -> IORef Bool
connectionSentClose :: !(IORef Bool)
    -- ^ According to the RFC, both the client and the server MUST send
    -- a close control message to each other.  Either party can initiate
    -- the first close message but then the other party must respond.  Finally,
    -- the server is in charge of closing the TCP connection.  This IORef tracks
    -- if we have sent a close message and are waiting for the peer to respond.
    }


--------------------------------------------------------------------------------
receive :: Connection -> IO Message
receive :: Connection -> IO Message
receive Connection
conn = do
    Maybe Message
mbMsg <- Connection -> IO (Maybe Message)
connectionParse Connection
conn
    case Maybe Message
mbMsg of
        Maybe Message
Nothing  -> forall e a. Exception e => e -> IO a
throwIO ConnectionException
ConnectionClosed
        Just Message
msg -> forall (m :: * -> *) a. Monad m => a -> m a
return Message
msg


--------------------------------------------------------------------------------
-- | Receive an application message. Automatically respond to control messages.
--
-- When the peer sends a close control message, an exception of type 'CloseRequest'
-- is thrown.  The peer can send a close control message either to initiate a
-- close or in response to a close message we have sent to the peer.  In either
-- case the 'CloseRequest' exception will be thrown.  The RFC specifies that
-- the server is responsible for closing the TCP connection, which should happen
-- after receiving the 'CloseRequest' exception from this function.
--
-- This will throw 'ConnectionClosed' if the TCP connection dies unexpectedly.
receiveDataMessage :: Connection -> IO DataMessage
receiveDataMessage :: Connection -> IO DataMessage
receiveDataMessage Connection
conn = do
    Message
msg <- Connection -> IO Message
receive Connection
conn
    case Message
msg of
        DataMessage Bool
_ Bool
_ Bool
_ DataMessage
am -> forall (m :: * -> *) a. Monad m => a -> m a
return DataMessage
am
        ControlMessage ControlMessage
cm    -> case ControlMessage
cm of
            Close Word16
i ByteString
closeMsg -> do
                Bool
hasSentClose <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ Connection -> IORef Bool
connectionSentClose Connection
conn
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hasSentClose forall a b. (a -> b) -> a -> b
$ Connection -> Message -> IO ()
send Connection
conn Message
msg
                forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Word16 -> ByteString -> ConnectionException
CloseRequest Word16
i ByteString
closeMsg
            Pong ByteString
_    -> do
                Bool
_ <- forall a. MVar a -> a -> IO Bool
tryPutMVar (Connection -> MVar ()
connectionHeartbeat Connection
conn) ()
                ConnectionOptions -> IO ()
connectionOnPong (Connection -> ConnectionOptions
connectionOptions Connection
conn)
                Connection -> IO DataMessage
receiveDataMessage Connection
conn
            Ping ByteString
pl   -> do
                Connection -> Message -> IO ()
send Connection
conn (ControlMessage -> Message
ControlMessage (ByteString -> ControlMessage
Pong ByteString
pl))
                Connection -> IO DataMessage
receiveDataMessage Connection
conn


--------------------------------------------------------------------------------
-- | Receive a message, converting it to whatever format is needed.
receiveData :: WebSocketsData a => Connection -> IO a
receiveData :: forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn = forall a. WebSocketsData a => DataMessage -> a
fromDataMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO DataMessage
receiveDataMessage Connection
conn


--------------------------------------------------------------------------------
send :: Connection -> Message -> IO ()
send :: Connection -> Message -> IO ()
send Connection
conn = Connection -> [Message] -> IO ()
sendAll Connection
conn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return

--------------------------------------------------------------------------------
sendAll :: Connection -> [Message] -> IO ()
sendAll :: Connection -> [Message] -> IO ()
sendAll Connection
_    []   = forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendAll Connection
conn [Message]
msgs = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Message -> Bool
isCloseMessage [Message]
msgs) forall a b. (a -> b) -> a -> b
$
      forall a. IORef a -> a -> IO ()
writeIORef (Connection -> IORef Bool
connectionSentClose Connection
conn) Bool
True
    Connection -> [Message] -> IO ()
connectionWrite Connection
conn [Message]
msgs
  where
    isCloseMessage :: Message -> Bool
isCloseMessage (ControlMessage (Close Word16
_ ByteString
_)) = Bool
True
    isCloseMessage Message
_                            = Bool
False

--------------------------------------------------------------------------------
-- | Send a 'DataMessage'.  This allows you send both human-readable text and
-- binary data.  This is a slightly more low-level interface than 'sendTextData'
-- or 'sendBinaryData'.
sendDataMessage :: Connection -> DataMessage -> IO ()
sendDataMessage :: Connection -> DataMessage -> IO ()
sendDataMessage Connection
conn = Connection -> [DataMessage] -> IO ()
sendDataMessages Connection
conn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return

--------------------------------------------------------------------------------
-- | Send a collection of 'DataMessage's.  This is more efficient than calling
-- 'sendDataMessage' many times.
sendDataMessages :: Connection -> [DataMessage] -> IO ()
sendDataMessages :: Connection -> [DataMessage] -> IO ()
sendDataMessages Connection
conn = Connection -> [Message] -> IO ()
sendAll Connection
conn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Bool -> Bool -> DataMessage -> Message
DataMessage Bool
False Bool
False Bool
False)

--------------------------------------------------------------------------------
-- | Send a textual message.  The message will be encoded as UTF-8.  This should
-- be the default choice for human-readable text-based protocols such as JSON.
sendTextData :: WebSocketsData a => Connection -> a -> IO ()
sendTextData :: forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn = forall a. WebSocketsData a => Connection -> [a] -> IO ()
sendTextDatas Connection
conn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return

--------------------------------------------------------------------------------
-- | Send a number of textual messages.  This is more efficient than calling
-- 'sendTextData' many times.
sendTextDatas :: WebSocketsData a => Connection -> [a] -> IO ()
sendTextDatas :: forall a. WebSocketsData a => Connection -> [a] -> IO ()
sendTextDatas Connection
conn =
    Connection -> [DataMessage] -> IO ()
sendDataMessages Connection
conn forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> ByteString -> Maybe Text -> DataMessage
Text (forall a. WebSocketsData a => a -> ByteString
toLazyByteString a
x) forall a. Maybe a
Nothing)

--------------------------------------------------------------------------------
-- | Send a binary message.  This is useful for sending binary blobs, e.g.
-- images, data encoded with MessagePack, images...
sendBinaryData :: WebSocketsData a => Connection -> a -> IO ()
sendBinaryData :: forall a. WebSocketsData a => Connection -> a -> IO ()
sendBinaryData Connection
conn = forall a. WebSocketsData a => Connection -> [a] -> IO ()
sendBinaryDatas Connection
conn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return

--------------------------------------------------------------------------------
-- | Send a number of binary messages.  This is more efficient than calling
-- 'sendBinaryData' many times.
sendBinaryDatas :: WebSocketsData a => Connection -> [a] -> IO ()
sendBinaryDatas :: forall a. WebSocketsData a => Connection -> [a] -> IO ()
sendBinaryDatas Connection
conn = Connection -> [DataMessage] -> IO ()
sendDataMessages Connection
conn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> DataMessage
Binary forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WebSocketsData a => a -> ByteString
toLazyByteString)

--------------------------------------------------------------------------------
-- | Send a friendly close message.  Note that after sending this message,
-- you should still continue calling 'receiveDataMessage' to process any
-- in-flight messages.  The peer will eventually respond with a close control
-- message of its own which will cause 'receiveDataMessage' to throw the
-- 'CloseRequest' exception.  This exception is when you can finally consider
-- the connection closed.
sendClose :: WebSocketsData a => Connection -> a -> IO ()
sendClose :: forall a. WebSocketsData a => Connection -> a -> IO ()
sendClose Connection
conn = forall a. WebSocketsData a => Connection -> Word16 -> a -> IO ()
sendCloseCode Connection
conn Word16
1000


--------------------------------------------------------------------------------
-- | Send a friendly close message and close code.  Similar to 'sendClose',
-- you should continue calling 'receiveDataMessage' until you receive a
-- 'CloseRequest' exception.
--
-- See <http://tools.ietf.org/html/rfc6455#section-7.4> for a list of close
-- codes.
sendCloseCode :: WebSocketsData a => Connection -> Word16 -> a -> IO ()
sendCloseCode :: forall a. WebSocketsData a => Connection -> Word16 -> a -> IO ()
sendCloseCode Connection
conn Word16
code =
    Connection -> Message -> IO ()
send Connection
conn forall b c a. (b -> c) -> (a -> b) -> a -> c
. ControlMessage -> Message
ControlMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> ByteString -> ControlMessage
Close Word16
code forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WebSocketsData a => a -> ByteString
toLazyByteString


--------------------------------------------------------------------------------
-- | Send a ping
sendPing :: WebSocketsData a => Connection -> a -> IO ()
sendPing :: forall a. WebSocketsData a => Connection -> a -> IO ()
sendPing Connection
conn = Connection -> Message -> IO ()
send Connection
conn forall b c a. (b -> c) -> (a -> b) -> a -> c
. ControlMessage -> Message
ControlMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ControlMessage
Ping forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WebSocketsData a => a -> ByteString
toLazyByteString

--------------------------------------------------------------------------------
-- | Send a pong
sendPong :: WebSocketsData a => Connection -> a -> IO ()
sendPong :: forall a. WebSocketsData a => Connection -> a -> IO ()
sendPong Connection
conn = Connection -> Message -> IO ()
send Connection
conn forall b c a. (b -> c) -> (a -> b) -> a -> c
. ControlMessage -> Message
ControlMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ControlMessage
Pong forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WebSocketsData a => a -> ByteString
toLazyByteString

--------------------------------------------------------------------------------
-- | Forks a ping thread, sending a ping message every @n@ seconds over the
-- connection.  The thread is killed when the inner IO action is finished.
--
-- This is useful to keep idle connections open through proxies and whatnot.
-- Many (but not all) proxies have a 60 second default timeout, so based on that
-- sending a ping every 30 seconds is a good idea.
--
-- Note that usually you want to use 'Network.WebSockets.Connection.PingPong.withPingPong'
-- to timeout the connection if a pong is not received.
withPingThread
    :: Connection
    -> Int    -- ^ Second interval in which pings should be sent.
    -> IO ()  -- ^ Repeat this after sending a ping.
    -> IO a   -- ^ Application to wrap with a ping thread.
    -> IO a   -- ^ Executes application and kills ping thread when done.
withPingThread :: forall a. Connection -> Int -> IO () -> IO a -> IO a
withPingThread Connection
conn Int
n IO ()
action IO a
app =
    forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync (Connection -> Int -> IO () -> IO ()
pingThread Connection
conn Int
n IO ()
action) (\Async ()
_ -> IO a
app)

--------------------------------------------------------------------------------
-- | DEPRECATED: Use 'withPingThread' instead.
--
-- Forks a ping thread, sending a ping message every @n@ seconds over the
-- connection.  The thread dies silently if the connection crashes or is closed.
--
-- This is useful to keep idle connections open through proxies and whatnot.
-- Many (but not all) proxies have a 60 second default timeout, so based on that
-- sending a ping every 30 seconds is a good idea.
forkPingThread :: Connection -> Int -> IO ()
forkPingThread :: Connection -> Int -> IO ()
forkPingThread Connection
conn Int
n = do
    ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Connection -> Int -> IO () -> IO ()
pingThread Connection
conn Int
n (forall (m :: * -> *) a. Monad m => a -> m a
return ())
    forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# DEPRECATED forkPingThread "Use 'withPingThread' instead" #-}


--------------------------------------------------------------------------------
-- | Use this if you want to run the ping thread yourself.
--
-- See also 'withPingThread'.
pingThread :: Connection -> Int -> IO () -> IO ()
pingThread :: Connection -> Int -> IO () -> IO ()
pingThread Connection
conn Int
n IO ()
action
    | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0    = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise = SomeException -> IO ()
ignore forall e a. Exception e => (e -> IO a) -> IO a -> IO a
`handle` Int -> IO ()
go Int
1
  where
    go :: Int -> IO ()
    go :: Int -> IO ()
go Int
i = do
        Int -> IO ()
threadDelay (Int
n forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000)
        forall a. WebSocketsData a => Connection -> a -> IO ()
sendPing Connection
conn (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
i)
        IO ()
action
        Int -> IO ()
go (Int
i forall a. Num a => a -> a -> a
+ Int
1)

    ignore :: SomeException -> IO ()
ignore SomeException
e = case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
        Just AsyncException
async -> forall e a. Exception e => e -> IO a
throwIO (AsyncException
async :: AsyncException)
        Maybe AsyncException
Nothing    -> forall (m :: * -> *) a. Monad m => a -> m a
return ()