{-# LANGUAGE OverloadedStrings #-}

-- | Websocket components built with 'Box'es.
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

-- | Socket configuration
--
-- >>> defaultSocketConfig
-- SocketConfig {host = "127.0.0.1", port = 9160, path = "/"}
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)

-- | official default
defaultSocketConfig :: SocketConfig
defaultSocketConfig :: SocketConfig
defaultSocketConfig = Text -> Int -> Text -> SocketConfig
SocketConfig Text
"127.0.0.1" Int
9160 Text
"/"

-- | connect an action (ie a client)
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 an action (ie a server)
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

-- | Attach a box to a 'PendingConnection' in wai-style.
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'

-- | Given a 'PendingConnection', provide a 'Connection' continuation.
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)
    )

-- | Commit received messages, finalising on receiving a 'CloseRequest'
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

-- | Commit received messages, finalising on receiving a 'CloseRequest', with event logging.
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

-- | Send emitted messages, returning whether the socket remained open (the 'Emitter' ran out of emits) or closed (a 'CloseRequest' was received).
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

-- | Send emitted messages, returning whether the socket remained open (the 'Emitter' ran out of emits) or closed (a 'CloseRequest' was received). With event logging.
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

-- | A two-way connection. Closes if it receives a 'CloseRequest' exception, or if 'PostSend' is 'CloseAfter'.
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)

-- | A two-way connection. Closes if it receives a 'CloseRequest' exception, or if 'PostSend' is 'CloseAfter'. With event logging.
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"

-- | A 'Box' action for a client.
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

-- | A client 'CoBox'.
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)

-- | A 'Box' action for a server.
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

-- | A server 'CoBox'.
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)

-- | A receiver that applies a response function to received messages.
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)