{-# LANGUAGE OverloadedStrings #-}
module Box.Websocket
( SocketConfig (..),
defaultSocketConfig,
connect,
serve,
pending,
serverApp,
receiver,
receiver_,
sender,
sender_,
duplex,
duplex_,
clientBox,
clientCoBox,
serverBox,
serverCoBox,
responseServer,
)
where
import Box
import Box.Socket.Types
import Control.Concurrent.Async
import Control.Exception
import Control.Monad
import Data.ByteString qualified as BS
import Data.Functor.Contravariant
import Data.Text (Text, pack, unpack)
import GHC.Generics (Generic)
import Network.WebSockets
data SocketConfig = SocketConfig
{ SocketConfig -> Text
host :: Text,
SocketConfig -> Int
port :: Int,
SocketConfig -> Text
path :: Text
}
deriving (Int -> SocketConfig -> ShowS
[SocketConfig] -> ShowS
SocketConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SocketConfig] -> ShowS
$cshowList :: [SocketConfig] -> ShowS
show :: SocketConfig -> String
$cshow :: SocketConfig -> String
showsPrec :: Int -> SocketConfig -> ShowS
$cshowsPrec :: Int -> SocketConfig -> ShowS
Show, SocketConfig -> SocketConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SocketConfig -> SocketConfig -> Bool
$c/= :: SocketConfig -> SocketConfig -> Bool
== :: SocketConfig -> SocketConfig -> Bool
$c== :: SocketConfig -> SocketConfig -> Bool
Eq, forall x. Rep SocketConfig x -> SocketConfig
forall x. SocketConfig -> Rep SocketConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SocketConfig x -> SocketConfig
$cfrom :: forall x. SocketConfig -> Rep SocketConfig x
Generic)
defaultSocketConfig :: SocketConfig
defaultSocketConfig :: SocketConfig
defaultSocketConfig = Text -> Int -> Text -> SocketConfig
SocketConfig Text
"127.0.0.1" Int
9160 Text
"/"
connect :: SocketConfig -> Codensity IO Connection
connect :: SocketConfig -> Codensity IO Connection
connect SocketConfig
c = forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity forall a b. (a -> b) -> a -> b
$ \Connection -> IO b
action ->
forall a. String -> Int -> String -> ClientApp a -> IO a
runClient (Text -> String
unpack forall a b. (a -> b) -> a -> b
$ SocketConfig -> Text
host SocketConfig
c) (SocketConfig -> Int
port SocketConfig
c) (Text -> String
unpack forall a b. (a -> b) -> a -> b
$ SocketConfig -> Text
path SocketConfig
c) Connection -> IO b
action
serve :: SocketConfig -> Codensity IO Connection
serve :: SocketConfig -> Codensity IO Connection
serve SocketConfig
c =
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity forall a b. (a -> b) -> a -> b
$
forall a. ServerOptions -> ServerApp -> IO a
runServerWithOptions (ServerOptions
defaultServerOptions {serverHost :: String
serverHost = Text -> String
unpack (SocketConfig -> Text
host SocketConfig
c), serverPort :: Int
serverPort = SocketConfig -> Int
port SocketConfig
c}) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Connection -> IO a) -> ServerApp
upgrade
where
upgrade :: (Connection -> IO a) -> ServerApp
upgrade Connection -> IO a
action PendingConnection
p = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Connection -> IO a
action forall {k} a (m :: k -> *) (r :: k).
(a -> m r) -> Codensity m a -> m r
<$|> PendingConnection -> Codensity IO Connection
pending PendingConnection
p
serverApp ::
Box IO Text Text ->
PendingConnection ->
IO ()
serverApp :: Box IO Text Text -> ServerApp
serverApp Box IO Text Text
b PendingConnection
p = forall {a}. (Connection -> IO a) -> ServerApp
upgrade (forall a.
WebSocketsData a =>
PostSend -> Box IO a a -> Connection -> IO ()
duplex (Double -> PostSend
CloseAfter Double
0.2) Box IO Text Text
b) PendingConnection
p
where
upgrade :: (Connection -> IO a) -> ServerApp
upgrade Connection -> IO a
action PendingConnection
p' = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Connection -> IO a
action forall {k} a (m :: k -> *) (r :: k).
(a -> m r) -> Codensity m a -> m r
<$|> PendingConnection -> Codensity IO Connection
pending PendingConnection
p'
pending :: PendingConnection -> Codensity IO Connection
pending :: PendingConnection -> Codensity IO Connection
pending PendingConnection
p = forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity forall a b. (a -> b) -> a -> b
$ \Connection -> IO b
action ->
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
(PendingConnection -> IO Connection
acceptRequest PendingConnection
p)
(\Connection
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
( \Connection
conn ->
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync
(forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ forall a. WebSocketsData a => Connection -> a -> IO ()
sendPing Connection
conn (ByteString
"connect ping" :: BS.ByteString) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Double -> IO ()
sleep Double
30)
(\Async Any
_ -> Connection -> IO b
action Connection
conn)
)
receiver ::
(WebSocketsData a) =>
Committer IO a ->
Connection ->
IO ()
receiver :: forall a. WebSocketsData a => Committer IO a -> Connection -> IO ()
receiver Committer IO a
c Connection
conn = IO ()
go
where
go :: IO ()
go = do
Either ConnectionException a
msg <- forall e a. Exception e => IO a -> IO (Either e a)
try (forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn)
case Either ConnectionException a
msg of
Left (CloseRequest Word16
_ ByteString
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Left ConnectionException
err -> forall e a. Exception e => e -> IO a
throwIO ConnectionException
err
Right a
msg' -> forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO a
c a
msg' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
go
receiver_ ::
(WebSocketsData a, Show a) =>
Committer IO a ->
Committer IO Text ->
Connection ->
IO ()
receiver_ :: forall a.
(WebSocketsData a, Show a) =>
Committer IO a -> Committer IO Text -> Connection -> IO ()
receiver_ Committer IO a
c Committer IO Text
cLog Connection
conn = IO ()
go
where
go :: IO ()
go = do
Either ConnectionException a
msg <- forall e a. Exception e => IO a -> IO (Either e a)
try (forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn)
Bool
_ <- forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO Text
cLog (Text
"receiveData:" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show Either ConnectionException a
msg))
case Either ConnectionException a
msg of
Left (CloseRequest Word16
_ ByteString
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Left ConnectionException
err -> forall e a. Exception e => e -> IO a
throwIO ConnectionException
err
Right a
msg' -> forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO a
c a
msg' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
go
sender ::
(WebSocketsData a) =>
Emitter IO a ->
Connection ->
IO SocketStatus
sender :: forall a.
WebSocketsData a =>
Emitter IO a -> Connection -> IO SocketStatus
sender Emitter IO a
e Connection
conn = IO SocketStatus
go
where
go :: IO SocketStatus
go = do
Maybe a
msg <- forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO a
e
case Maybe a
msg of
Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SocketStatus
SocketOpen
Just a
msg' -> do
Either ConnectionException ()
ok <- forall e a. Exception e => IO a -> IO (Either e a)
try (forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn a
msg')
case Either ConnectionException ()
ok of
Left (CloseRequest Word16
_ ByteString
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SocketStatus
SocketClosed
Left ConnectionException
err -> forall e a. Exception e => e -> IO a
throwIO ConnectionException
err
Right () -> IO SocketStatus
go
sender_ ::
(WebSocketsData a, Show a) =>
Emitter IO a ->
Committer IO Text ->
Connection ->
IO SocketStatus
sender_ :: forall a.
(WebSocketsData a, Show a) =>
Emitter IO a -> Committer IO Text -> Connection -> IO SocketStatus
sender_ Emitter IO a
e Committer IO Text
cLog Connection
conn = IO SocketStatus
go
where
go :: IO SocketStatus
go = do
Maybe a
msg <- forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO a
e
Bool
_ <- forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO Text
cLog (Text
"emit:" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show Maybe a
msg))
case Maybe a
msg of
Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SocketStatus
SocketOpen
Just a
msg' -> do
Either ConnectionException ()
ok <- forall e a. Exception e => IO a -> IO (Either e a)
try (forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn a
msg')
Bool
_ <- forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO Text
cLog (Text
"sendTextData:" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show Either ConnectionException ()
ok))
case Either ConnectionException ()
ok of
Left (CloseRequest Word16
_ ByteString
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SocketStatus
SocketClosed
Left ConnectionException
err -> forall e a. Exception e => e -> IO a
throwIO ConnectionException
err
Right () -> IO SocketStatus
go
duplex ::
(WebSocketsData a) =>
PostSend ->
Box IO a a ->
Connection ->
IO ()
duplex :: forall a.
WebSocketsData a =>
PostSend -> Box IO a a -> Connection -> IO ()
duplex PostSend
ps (Box Committer IO a
c Emitter IO a
e) Connection
conn = do
forall a b. IO a -> IO b -> IO b
concurrentlyRight
( do
SocketStatus
status <- forall a.
WebSocketsData a =>
Emitter IO a -> Connection -> IO SocketStatus
sender Emitter IO a
e Connection
conn
case (PostSend
ps, SocketStatus
status) of
(CloseAfter Double
s, SocketStatus
SocketOpen) -> do
Double -> IO ()
sleep Double
s
forall a. WebSocketsData a => Connection -> a -> IO ()
sendClose Connection
conn (Text
"close after sending" :: Text)
(PostSend, SocketStatus)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
)
(forall a. WebSocketsData a => Committer IO a -> Connection -> IO ()
receiver Committer IO a
c Connection
conn)
duplex_ ::
(WebSocketsData a, Show a) =>
PostSend ->
Committer IO Text ->
Box IO a a ->
Connection ->
IO ()
duplex_ :: forall a.
(WebSocketsData a, Show a) =>
PostSend -> Committer IO Text -> Box IO a a -> Connection -> IO ()
duplex_ PostSend
ps Committer IO Text
cLog (Box Committer IO a
c Emitter IO a
e) Connection
conn = do
forall a b. IO a -> IO b -> IO b
concurrentlyRight
( do
SocketStatus
status <- forall a.
(WebSocketsData a, Show a) =>
Emitter IO a -> Committer IO Text -> Connection -> IO SocketStatus
sender_ Emitter IO a
e (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (Text
"sender_:" <>) Committer IO Text
cLog) Connection
conn
Bool
_ <- forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO Text
cLog (Text
"sender_ closed with " forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show SocketStatus
status))
case (PostSend
ps, SocketStatus
status) of
(CloseAfter Double
s, SocketStatus
SocketOpen) -> do
Double -> IO ()
sleep Double
s
forall a. WebSocketsData a => Connection -> a -> IO ()
sendClose Connection
conn (Text
"close after sending" :: Text)
(PostSend, SocketStatus)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
)
( do
forall a.
(WebSocketsData a, Show a) =>
Committer IO a -> Committer IO Text -> Connection -> IO ()
receiver_ Committer IO a
c (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (Text
"receiver_:" <>) Committer IO Text
cLog) Connection
conn
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO Text
cLog Text
"receiver_ closed"
)
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO Text
cLog Text
"duplex_ closed"
clientBox ::
(WebSocketsData a) =>
SocketConfig ->
PostSend ->
Box IO a a ->
IO ()
clientBox :: forall a.
WebSocketsData a =>
SocketConfig -> PostSend -> Box IO a a -> IO ()
clientBox SocketConfig
cfg PostSend
ps Box IO a a
b = forall a.
WebSocketsData a =>
PostSend -> Box IO a a -> Connection -> IO ()
duplex PostSend
ps Box IO a a
b forall {k} a (m :: k -> *) (r :: k).
(a -> m r) -> Codensity m a -> m r
<$|> SocketConfig -> Codensity IO Connection
connect SocketConfig
cfg
clientCoBox ::
(WebSocketsData a) =>
SocketConfig ->
PostSend ->
CoBox IO a a
clientCoBox :: forall a.
WebSocketsData a =>
SocketConfig -> PostSend -> CoBox IO a a
clientCoBox SocketConfig
cfg PostSend
ps = forall a b r. (Box IO a b -> IO r) -> CoBox IO b a
fromAction (forall a.
WebSocketsData a =>
SocketConfig -> PostSend -> Box IO a a -> IO ()
clientBox SocketConfig
cfg PostSend
ps)
serverBox ::
(WebSocketsData a) =>
SocketConfig ->
PostSend ->
Box IO a a ->
IO ()
serverBox :: forall a.
WebSocketsData a =>
SocketConfig -> PostSend -> Box IO a a -> IO ()
serverBox SocketConfig
cfg PostSend
ps Box IO a a
b = forall a.
WebSocketsData a =>
PostSend -> Box IO a a -> Connection -> IO ()
duplex PostSend
ps Box IO a a
b forall {k} a (m :: k -> *) (r :: k).
(a -> m r) -> Codensity m a -> m r
<$|> SocketConfig -> Codensity IO Connection
serve SocketConfig
cfg
serverCoBox ::
(WebSocketsData a) =>
SocketConfig ->
PostSend ->
CoBox IO a a
serverCoBox :: forall a.
WebSocketsData a =>
SocketConfig -> PostSend -> CoBox IO a a
serverCoBox SocketConfig
cfg PostSend
ps = forall a b r. (Box IO a b -> IO r) -> CoBox IO b a
fromAction (forall a.
WebSocketsData a =>
SocketConfig -> PostSend -> Box IO a a -> IO ()
serverBox SocketConfig
cfg PostSend
ps)
responseServer :: (WebSocketsData a) => SocketConfig -> (a -> Maybe a) -> IO ()
responseServer :: forall a.
WebSocketsData a =>
SocketConfig -> (a -> Maybe a) -> IO ()
responseServer SocketConfig
cfg a -> Maybe a
f = forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Box m b a -> m ()
fuse (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
f) forall {k} a (m :: k -> *) (r :: k).
(a -> m r) -> Codensity m a -> m r
<$|> forall a.
WebSocketsData a =>
SocketConfig -> PostSend -> CoBox IO a a
serverCoBox SocketConfig
cfg (Double -> PostSend
CloseAfter Double
0.5)