--------------------------------------------------------------------------------
-- | This module exposes connection internals and should only be used if you
-- really know what you are doing.
{-# 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

    , 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.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 Maybe ByteString
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 (Protocol -> Bool) -> [Protocol] -> Maybe Protocol
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Protocol -> RequestHead -> Bool)
-> RequestHead -> Protocol -> Bool
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 (Response -> IO ()) -> Response -> IO ()
forall a b. (a -> b) -> a -> b
$ Headers -> ByteString -> Response
response400 Headers
versionHeader ByteString
""
        HandshakeException -> IO Connection
forall e a. Exception e => e -> IO a
throwIO HandshakeException
NotSupported
    Just Protocol
protocol -> do

        -- Get requested list of exceptions from client.
        ExtensionDescriptions
rqExts <- (HandshakeException -> IO ExtensionDescriptions)
-> (ExtensionDescriptions -> IO ExtensionDescriptions)
-> Either HandshakeException ExtensionDescriptions
-> IO ExtensionDescriptions
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either HandshakeException -> IO ExtensionDescriptions
forall e a. Exception e => e -> IO a
throwIO ExtensionDescriptions -> IO ExtensionDescriptions
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HandshakeException ExtensionDescriptions
 -> IO ExtensionDescriptions)
-> Either HandshakeException ExtensionDescriptions
-> IO ExtensionDescriptions
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                     -> Maybe Extension -> IO (Maybe Extension)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Extension
forall a. Maybe a
Nothing
            PermessageDeflateCompression PermessageDeflate
pmd0 ->
                case SizeLimit -> Maybe PermessageDeflate -> NegotiateExtension
negotiateDeflate (ConnectionOptions -> SizeLimit
connectionMessageDataSizeLimit ConnectionOptions
options) (PermessageDeflate -> Maybe PermessageDeflate
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}
                        HandshakeException -> IO (Maybe Extension)
forall e a. Exception e => e -> IO a
throwIO HandshakeException
NotSupported
                    Right Extension
pmd1 -> Maybe Extension -> IO (Maybe Extension)
forall (m :: * -> *) a. Monad m => a -> m a
return (Extension -> Maybe Extension
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 Extension -> Maybe Extension
forall a. a -> Maybe a
Just Extension
strictUnicode else Maybe Extension
forall a. Maybe a
Nothing

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

        let subproto :: Headers
subproto = Headers -> (ByteString -> Headers) -> Maybe ByteString -> Headers
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\ByteString
p -> [(CI ByteString
"Sec-WebSocket-Protocol", ByteString
p)]) (Maybe ByteString -> Headers) -> Maybe ByteString -> Headers
forall a b. (a -> b) -> a -> b
$ AcceptRequest -> Maybe ByteString
acceptSubprotocol AcceptRequest
ar
            headers :: Headers
headers = Headers
subproto Headers -> Headers -> Headers
forall a. [a] -> [a] -> [a]
++ AcceptRequest -> Headers
acceptHeaders AcceptRequest
ar Headers -> Headers -> Headers
forall a. [a] -> [a] -> [a]
++ (Extension -> Headers) -> [Extension] -> Headers
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

        (HandshakeException -> IO ())
-> (Response -> IO ())
-> Either HandshakeException Response
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either HandshakeException -> IO ()
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 <- (([Message] -> IO ()) -> Extension -> IO ([Message] -> IO ()))
-> ([Message] -> IO ()) -> [Extension] -> IO ([Message] -> IO ())
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 <- (IO (Maybe Message) -> Extension -> IO (IO (Maybe Message)))
-> IO (Maybe Message) -> [Extension] -> IO (IO (Maybe Message))
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    <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
        let connection :: Connection
connection = Connection :: ConnectionOptions
-> ConnectionType
-> Protocol
-> IO (Maybe Message)
-> ([Message] -> IO ())
-> IORef Bool
-> 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
                , connectionSentClose :: IORef Bool
connectionSentClose = IORef Bool
sentRef
                }

        PendingConnection -> Connection -> IO ()
pendingOnAccept PendingConnection
pc Connection
connection
        Connection -> IO 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
", " ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Protocol -> [ByteString]) -> [Protocol] -> [ByteString]
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 :: Int -> ByteString -> Headers -> ByteString -> RejectRequest
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 (Response -> IO ()) -> Response -> IO ()
forall a b. (a -> b) -> a -> b
$ ResponseHead -> ByteString -> Response
Response
    ResponseHead :: Int -> ByteString -> Headers -> ResponseHead
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)


--------------------------------------------------------------------------------
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 -> 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  -> ConnectionException -> IO Message
forall e a. Exception e => e -> IO a
throwIO ConnectionException
ConnectionClosed
        Just Message
msg -> Message -> IO Message
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 -> DataMessage -> IO DataMessage
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 <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (IORef Bool -> IO Bool) -> IORef Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Connection -> IORef Bool
connectionSentClose Connection
conn
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hasSentClose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Message -> IO ()
send Connection
conn Message
msg
                ConnectionException -> IO DataMessage
forall e a. Exception e => e -> IO a
throwIO (ConnectionException -> IO DataMessage)
-> ConnectionException -> IO DataMessage
forall a b. (a -> b) -> a -> b
$ Word16 -> ByteString -> ConnectionException
CloseRequest Word16
i ByteString
closeMsg
            Pong ByteString
_    -> do
                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 :: Connection -> IO a
receiveData Connection
conn = DataMessage -> a
forall a. WebSocketsData a => DataMessage -> a
fromDataMessage (DataMessage -> a) -> IO DataMessage -> IO a
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 ([Message] -> IO ()) -> (Message -> [Message]) -> Message -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> [Message]
forall (m :: * -> *) a. Monad m => a -> m a
return

--------------------------------------------------------------------------------
sendAll :: Connection -> [Message] -> IO ()
sendAll :: Connection -> [Message] -> IO ()
sendAll Connection
_    []   = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendAll Connection
conn [Message]
msgs = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Message -> Bool) -> [Message] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Message -> Bool
isCloseMessage [Message]
msgs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      IORef Bool -> Bool -> IO ()
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 ([DataMessage] -> IO ())
-> (DataMessage -> [DataMessage]) -> DataMessage -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataMessage -> [DataMessage]
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 ([Message] -> IO ())
-> ([DataMessage] -> [Message]) -> [DataMessage] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DataMessage -> Message) -> [DataMessage] -> [Message]
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 :: Connection -> a -> IO ()
sendTextData Connection
conn = Connection -> [a] -> IO ()
forall a. WebSocketsData a => Connection -> [a] -> IO ()
sendTextDatas Connection
conn ([a] -> IO ()) -> (a -> [a]) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a]
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 :: Connection -> [a] -> IO ()
sendTextDatas Connection
conn =
    Connection -> [DataMessage] -> IO ()
sendDataMessages Connection
conn ([DataMessage] -> IO ()) -> ([a] -> [DataMessage]) -> [a] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (a -> DataMessage) -> [a] -> [DataMessage]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> ByteString -> Maybe Text -> DataMessage
Text (a -> ByteString
forall a. WebSocketsData a => a -> ByteString
toLazyByteString a
x) Maybe Text
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 :: Connection -> a -> IO ()
sendBinaryData Connection
conn = Connection -> [a] -> IO ()
forall a. WebSocketsData a => Connection -> [a] -> IO ()
sendBinaryDatas Connection
conn ([a] -> IO ()) -> (a -> [a]) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a]
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 :: Connection -> [a] -> IO ()
sendBinaryDatas Connection
conn = Connection -> [DataMessage] -> IO ()
sendDataMessages Connection
conn ([DataMessage] -> IO ()) -> ([a] -> [DataMessage]) -> [a] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> DataMessage) -> [a] -> [DataMessage]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> DataMessage
Binary (ByteString -> DataMessage)
-> (a -> ByteString) -> a -> DataMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
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 :: Connection -> a -> IO ()
sendClose Connection
conn = Connection -> Word16 -> a -> IO ()
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 :: Connection -> Word16 -> a -> IO ()
sendCloseCode Connection
conn Word16
code =
    Connection -> Message -> IO ()
send Connection
conn (Message -> IO ()) -> (a -> Message) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ControlMessage -> Message
ControlMessage (ControlMessage -> Message)
-> (a -> ControlMessage) -> a -> Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> ByteString -> ControlMessage
Close Word16
code (ByteString -> ControlMessage)
-> (a -> ByteString) -> a -> ControlMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. WebSocketsData a => a -> ByteString
toLazyByteString


--------------------------------------------------------------------------------
-- | Send a ping
sendPing :: WebSocketsData a => Connection -> a -> IO ()
sendPing :: Connection -> a -> IO ()
sendPing Connection
conn = Connection -> Message -> IO ()
send Connection
conn (Message -> IO ()) -> (a -> Message) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ControlMessage -> Message
ControlMessage (ControlMessage -> Message)
-> (a -> ControlMessage) -> a -> Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ControlMessage
Ping (ByteString -> ControlMessage)
-> (a -> ByteString) -> a -> ControlMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
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.
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 :: Connection -> Int -> IO () -> IO a -> IO a
withPingThread Connection
conn Int
n IO ()
action IO a
app =
    IO () -> (Async () -> IO a) -> IO a
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 (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Connection -> Int -> IO () -> IO ()
pingThread Connection
conn Int
n (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    () -> IO ()
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise = SomeException -> IO ()
ignore (SomeException -> IO ()) -> IO () -> IO ()
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)
        Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendPing Connection
conn (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i)
        IO ()
action
        Int -> IO ()
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

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