{-# 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
data PendingConnection = PendingConnection
{ PendingConnection -> ConnectionOptions
pendingOptions :: !ConnectionOptions
, PendingConnection -> RequestHead
pendingRequest :: !RequestHead
, PendingConnection -> Connection -> IO ()
pendingOnAccept :: !(Connection -> IO ())
, PendingConnection -> Stream
pendingStream :: !Stream
}
data AcceptRequest = AcceptRequest
{ AcceptRequest -> Maybe ByteString
acceptSubprotocol :: !(Maybe B.ByteString)
, :: !Headers
}
defaultAcceptRequest :: AcceptRequest
defaultAcceptRequest :: AcceptRequest
defaultAcceptRequest = Maybe ByteString -> Headers -> AcceptRequest
AcceptRequest Maybe ByteString
forall a. Maybe a
Nothing []
sendResponse :: PendingConnection -> Response -> IO ()
sendResponse :: PendingConnection -> Response -> IO ()
sendResponse pc :: PendingConnection
pc rsp :: Response
rsp = Stream -> ByteString -> IO ()
Stream.write (PendingConnection -> Stream
pendingStream PendingConnection
pc)
(Builder -> ByteString
Builder.toLazyByteString (Response -> Builder
encodeResponse Response
rsp))
acceptRequest :: PendingConnection -> IO Connection
acceptRequest :: PendingConnection -> IO Connection
acceptRequest pc :: PendingConnection
pc = PendingConnection -> AcceptRequest -> IO Connection
acceptRequestWith PendingConnection
pc AcceptRequest
defaultAcceptRequest
acceptRequestWith :: PendingConnection -> AcceptRequest -> IO Connection
acceptRequestWith :: PendingConnection -> AcceptRequest -> IO Connection
acceptRequestWith pc :: PendingConnection
pc ar :: 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
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 ""
HandshakeException -> IO Connection
forall e a. Exception e => e -> IO a
throwIO HandshakeException
NotSupported
Just protocol :: Protocol
protocol -> do
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
Maybe Extension
pmdExt <- case ConnectionOptions -> CompressionOptions
connectionCompressionOptions (PendingConnection -> ConnectionOptions
pendingOptions PendingConnection
pc) of
NoCompression -> Maybe Extension -> IO (Maybe Extension)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Extension
forall a. Maybe a
Nothing
PermessageDeflateCompression pmd0 :: 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 err :: 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 pmd1 :: 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)
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
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 [] (\p :: ByteString
p -> [("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 (\x :: [Message] -> IO ()
x ext :: 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 (\x :: IO (Maybe Message)
x ext :: 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 = $WConnection :: 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 = [("Sec-WebSocket-Version",
ByteString -> [ByteString] -> ByteString
B.intercalate ", " ([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)]
data RejectRequest = RejectRequest
{
RejectRequest -> Int
rejectCode :: !Int
,
RejectRequest -> ByteString
rejectMessage :: !B.ByteString
,
:: Headers
,
RejectRequest -> ByteString
rejectBody :: !B.ByteString
}
defaultRejectRequest :: RejectRequest
defaultRejectRequest :: RejectRequest
defaultRejectRequest = $WRejectRequest :: Int -> ByteString -> Headers -> ByteString -> RejectRequest
RejectRequest
{ rejectCode :: Int
rejectCode = 400
, rejectMessage :: ByteString
rejectMessage = "Bad Request"
, rejectHeaders :: Headers
rejectHeaders = []
, rejectBody :: ByteString
rejectBody = ""
}
rejectRequestWith
:: PendingConnection
-> RejectRequest
-> IO ()
rejectRequestWith :: PendingConnection -> RejectRequest -> IO ()
rejectRequestWith pc :: PendingConnection
pc reject :: RejectRequest
reject = PendingConnection -> Response -> IO ()
sendResponse PendingConnection
pc (Response -> IO ()) -> Response -> IO ()
forall a b. (a -> b) -> a -> b
$ ResponseHead -> ByteString -> Response
Response
$WResponseHead :: 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
-> B.ByteString
-> IO ()
rejectRequest :: PendingConnection -> ByteString -> IO ()
rejectRequest pc :: PendingConnection
pc body :: 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)
}
receive :: Connection -> IO Message
receive :: Connection -> IO Message
receive conn :: Connection
conn = do
Maybe Message
mbMsg <- Connection -> IO (Maybe Message)
connectionParse Connection
conn
case Maybe Message
mbMsg of
Nothing -> ConnectionException -> IO Message
forall e a. Exception e => e -> IO a
throwIO ConnectionException
ConnectionClosed
Just msg :: Message
msg -> Message -> IO Message
forall (m :: * -> *) a. Monad m => a -> m a
return Message
msg
receiveDataMessage :: Connection -> IO DataMessage
receiveDataMessage :: Connection -> IO DataMessage
receiveDataMessage conn :: Connection
conn = do
Message
msg <- Connection -> IO Message
receive Connection
conn
case Message
msg of
DataMessage _ _ _ am :: DataMessage
am -> DataMessage -> IO DataMessage
forall (m :: * -> *) a. Monad m => a -> m a
return DataMessage
am
ControlMessage cm :: ControlMessage
cm -> case ControlMessage
cm of
Close i :: Word16
i closeMsg :: 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 _ -> do
ConnectionOptions -> IO ()
connectionOnPong (Connection -> ConnectionOptions
connectionOptions Connection
conn)
Connection -> IO DataMessage
receiveDataMessage Connection
conn
Ping pl :: ByteString
pl -> do
Connection -> Message -> IO ()
send Connection
conn (ControlMessage -> Message
ControlMessage (ByteString -> ControlMessage
Pong ByteString
pl))
Connection -> IO DataMessage
receiveDataMessage Connection
conn
receiveData :: WebSocketsData a => Connection -> IO a
receiveData :: Connection -> IO a
receiveData conn :: 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 conn :: 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 _ [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendAll conn :: Connection
conn msgs :: [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 _ _)) = Bool
True
isCloseMessage _ = Bool
False
sendDataMessage :: Connection -> DataMessage -> IO ()
sendDataMessage :: Connection -> DataMessage -> IO ()
sendDataMessage conn :: 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
sendDataMessages :: Connection -> [DataMessage] -> IO ()
sendDataMessages :: Connection -> [DataMessage] -> IO ()
sendDataMessages conn :: 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)
sendTextData :: WebSocketsData a => Connection -> a -> IO ()
sendTextData :: Connection -> a -> IO ()
sendTextData conn :: 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
sendTextDatas :: WebSocketsData a => Connection -> [a] -> IO ()
sendTextDatas :: Connection -> [a] -> IO ()
sendTextDatas conn :: 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 (\x :: 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)
sendBinaryData :: WebSocketsData a => Connection -> a -> IO ()
sendBinaryData :: Connection -> a -> IO ()
sendBinaryData conn :: 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
sendBinaryDatas :: WebSocketsData a => Connection -> [a] -> IO ()
sendBinaryDatas :: Connection -> [a] -> IO ()
sendBinaryDatas conn :: 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)
sendClose :: WebSocketsData a => Connection -> a -> IO ()
sendClose :: Connection -> a -> IO ()
sendClose conn :: Connection
conn = Connection -> Word16 -> a -> IO ()
forall a. WebSocketsData a => Connection -> Word16 -> a -> IO ()
sendCloseCode Connection
conn 1000
sendCloseCode :: WebSocketsData a => Connection -> Word16 -> a -> IO ()
sendCloseCode :: Connection -> Word16 -> a -> IO ()
sendCloseCode conn :: Connection
conn code :: 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
sendPing :: WebSocketsData a => Connection -> a -> IO ()
sendPing :: Connection -> a -> IO ()
sendPing conn :: 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
withPingThread
:: Connection
-> Int
-> IO ()
-> IO a
-> IO a
withPingThread :: Connection -> Int -> IO () -> IO a -> IO a
withPingThread conn :: Connection
conn n :: Int
n action :: IO ()
action app :: 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) (\_ -> IO a
app)
forkPingThread :: Connection -> Int -> IO ()
forkPingThread :: Connection -> Int -> IO ()
forkPingThread conn :: Connection
conn n :: 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" #-}
pingThread :: Connection -> Int -> IO () -> IO ()
pingThread :: Connection -> Int -> IO () -> IO ()
pingThread conn :: Connection
conn n :: Int
n action :: IO ()
action
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 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 1
where
go :: Int -> IO ()
go :: Int -> IO ()
go i :: Int
i = do
Int -> IO ()
threadDelay (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 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
+ 1)
ignore :: SomeException -> IO ()
ignore e :: SomeException
e = case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just async :: AsyncException
async -> AsyncException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (AsyncException
async :: AsyncException)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()