{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -Wall #-}

-- | Websocket components built with 'Box'es.
module Box.Socket
  ( SocketConfig (..),
    defaultSocketConfig,
    runClient,
    runServer,
    connect,
    clientApp,
    responderApp,
    serverApp,
    receiver',
    receiver,
    sender,
    responder,
  )
where

import Box
import qualified Control.Concurrent.Classy.Async as C
import Control.Lens
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Conc.Class as C
import Control.Monad.IO.Class
import qualified Data.ByteString as BS
import Data.Generics.Labels ()
import Data.Text (Text, pack, unpack)
import GHC.Generics
import qualified Network.WebSockets as WS

-- | 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
(Int -> SocketConfig -> ShowS)
-> (SocketConfig -> String)
-> ([SocketConfig] -> ShowS)
-> Show SocketConfig
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
(SocketConfig -> SocketConfig -> Bool)
-> (SocketConfig -> SocketConfig -> Bool) -> Eq SocketConfig
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. SocketConfig -> Rep SocketConfig x)
-> (forall x. Rep SocketConfig x -> SocketConfig)
-> Generic SocketConfig
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
"/"

-- | Run a client app.
runClient :: (MonadIO m) => SocketConfig -> WS.ClientApp () -> m ()
runClient :: SocketConfig -> ClientApp () -> m ()
runClient SocketConfig
c ClientApp ()
app = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> String -> ClientApp () -> IO ()
forall a. String -> Int -> String -> ClientApp a -> IO a
WS.runClient (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ SocketConfig
c SocketConfig -> Getting Text SocketConfig Text -> Text
forall s a. s -> Getting a s a -> a
^. IsLabel "host" (Getting Text SocketConfig Text)
Getting Text SocketConfig Text
#host) (SocketConfig
c SocketConfig -> Getting Int SocketConfig Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "port" (Getting Int SocketConfig Int)
Getting Int SocketConfig Int
#port) (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ SocketConfig
c SocketConfig -> Getting Text SocketConfig Text -> Text
forall s a. s -> Getting a s a -> a
^. IsLabel "path" (Getting Text SocketConfig Text)
Getting Text SocketConfig Text
#path) ClientApp ()
app

-- | Run a server app.
runServer :: (MonadIO m) => SocketConfig -> WS.ServerApp -> m ()
runServer :: SocketConfig -> ServerApp -> m ()
runServer SocketConfig
c ServerApp
app = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> ServerApp -> IO ()
WS.runServer (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ SocketConfig
c SocketConfig -> Getting Text SocketConfig Text -> Text
forall s a. s -> Getting a s a -> a
^. IsLabel "host" (Getting Text SocketConfig Text)
Getting Text SocketConfig Text
#host) (SocketConfig
c SocketConfig -> Getting Int SocketConfig Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "port" (Getting Int SocketConfig Int)
Getting Int SocketConfig Int
#port) ServerApp
app

-- | Connection continuation.
connect :: (MonadIO m, MonadConc m) => WS.PendingConnection -> Cont m WS.Connection
connect :: PendingConnection -> Cont m Connection
connect PendingConnection
p = (forall r. (Connection -> m r) -> m r) -> Cont m Connection
forall (m :: * -> *) a. (forall r. (a -> m r) -> m r) -> Cont m a
Cont ((forall r. (Connection -> m r) -> m r) -> Cont m Connection)
-> (forall r. (Connection -> m r) -> m r) -> Cont m Connection
forall a b. (a -> b) -> a -> b
$ \Connection -> m r
action ->
  m Connection -> (Connection -> m ()) -> (Connection -> m r) -> m r
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket
    (IO Connection -> m Connection
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> m Connection) -> IO Connection -> m Connection
forall a b. (a -> b) -> a -> b
$ PendingConnection -> IO Connection
WS.acceptRequest PendingConnection
p)
    (\Connection
conn -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendClose Connection
conn (Text
"Bye from connect!" :: Text))
    ( \Connection
conn ->
        m Any -> (Async m Any -> m r) -> m r
forall (m :: * -> *) a b.
MonadConc m =>
m a -> (Async m a -> m b) -> m b
C.withAsync
          (IO Any -> m Any
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Any -> m Any) -> IO Any -> m Any
forall a b. (a -> b) -> a -> b
$ IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendPing Connection
conn (ByteString
"ping" :: BS.ByteString) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Double -> IO ()
forall (m :: * -> *). MonadConc m => Double -> m ()
sleep Double
30)
          (\Async m Any
_ -> Connection -> m r
action Connection
conn)
    )

-- | A simple client app for a box with Left debug messages.
clientApp ::
  (MonadIO m, MonadConc m) =>
  Box m (Either Text Text) Text ->
  WS.Connection ->
  m ()
clientApp :: Box m (Either Text Text) Text -> Connection -> m ()
clientApp (Box Committer m (Either Text Text)
c Emitter m Text
e) Connection
conn =
  m (Either Bool ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Either Bool ()) -> m ()) -> m (Either Bool ()) -> m ()
forall a b. (a -> b) -> a -> b
$
    m Bool -> m () -> m (Either Bool ())
forall (m :: * -> *) a b.
MonadConc m =>
m a -> m b -> m (Either a b)
C.race
      (Committer m (Either Text Text) -> Connection -> m Bool
forall (m :: * -> *).
MonadIO m =>
Committer m (Either Text Text) -> Connection -> m Bool
receiver' Committer m (Either Text Text)
c Connection
conn)
      (Box m Text Text -> Connection -> m ()
forall (m :: * -> *) a.
(MonadIO m, WebSocketsData a, Show a) =>
Box m Text a -> Connection -> m ()
sender (Committer m Text -> Emitter m Text -> Box m Text Text
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box Committer m Text
forall a. Monoid a => a
mempty Emitter m Text
e) Connection
conn)

-- | Canned response function.
responderApp ::
  (Text -> Either Text Text) ->
  WS.PendingConnection ->
  IO ()
responderApp :: (Text -> Either Text Text) -> ServerApp
responderApp Text -> Either Text Text
f PendingConnection
p = Cont IO Connection -> ClientApp () -> IO ()
forall (m :: * -> *) a. Cont m a -> forall r. (a -> m r) -> m r
with (PendingConnection -> Cont IO Connection
forall (m :: * -> *).
(MonadIO m, MonadConc m) =>
PendingConnection -> Cont m Connection
connect PendingConnection
p) ((Text -> Either Text Text) -> Committer IO Text -> ClientApp ()
forall (m :: * -> *).
MonadIO m =>
(Text -> Either Text Text)
-> Committer m Text -> Connection -> m ()
responder Text -> Either Text Text
f Committer IO Text
forall a. Monoid a => a
mempty)

-- | Standard server app for a box.
serverApp ::
  (MonadConc m, MonadIO m) =>
  Box m Text Text ->
  WS.PendingConnection ->
  m ()
serverApp :: Box m Text Text -> PendingConnection -> m ()
serverApp (Box Committer m Text
c Emitter m Text
e) PendingConnection
p =
  m (Either () ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Either () ()) -> m ()) -> m (Either () ()) -> m ()
forall a b. (a -> b) -> a -> b
$
    Cont m Connection
-> (Connection -> m (Either () ())) -> m (Either () ())
forall (m :: * -> *) a. Cont m a -> forall r. (a -> m r) -> m r
with
      (PendingConnection -> Cont m Connection
forall (m :: * -> *).
(MonadIO m, MonadConc m) =>
PendingConnection -> Cont m Connection
connect PendingConnection
p)
      ( \Connection
conn ->
          m () -> m () -> m (Either () ())
forall (m :: * -> *) a b.
MonadConc m =>
m a -> m b -> m (Either a b)
C.race
            (Committer m Text -> Connection -> m ()
forall (m :: * -> *).
MonadIO m =>
Committer m Text -> Connection -> m ()
receiver Committer m Text
c Connection
conn)
            (Box m Text Text -> Connection -> m ()
forall (m :: * -> *) a.
(MonadIO m, WebSocketsData a, Show a) =>
Box m Text a -> Connection -> m ()
sender (Committer m Text -> Emitter m Text -> Box m Text Text
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box Committer m Text
forall a. Monoid a => a
mempty Emitter m Text
e) Connection
conn)
      )

-- | default websocket receiver with messages
-- Lefts are info/debug
receiver' ::
  (MonadIO m) =>
  Committer m (Either Text Text) ->
  WS.Connection ->
  m Bool
receiver' :: Committer m (Either Text Text) -> Connection -> m Bool
receiver' Committer m (Either Text Text)
c Connection
conn = m Bool
go
  where
    go :: m Bool
go = do
      Message
msg <- IO Message -> m Message
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Message -> m Message) -> IO Message -> m Message
forall a b. (a -> b) -> a -> b
$ Connection -> IO Message
WS.receive Connection
conn
      case Message
msg of
        WS.ControlMessage (WS.Close Word16
w ByteString
b) ->
          Committer m (Either Text Text) -> Either Text Text -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit
            Committer m (Either Text Text)
c
            ( Text -> Either Text Text
forall a b. a -> Either a b
Left
                ( Text
"receiver: received: close: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (Word16 -> String) -> Word16 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> String
forall a. Show a => a -> String
show) Word16
w Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (ByteString -> String) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
forall a. Show a => a -> String
show) ByteString
b
                )
            )
        WS.ControlMessage ControlMessage
_ -> m Bool
go
        WS.DataMessage Bool
_ Bool
_ Bool
_ DataMessage
msg' -> do
          Bool
_ <- Committer m (Either Text Text) -> Either Text Text -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m (Either Text Text)
c (Either Text Text -> m Bool) -> Either Text Text -> m Bool
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"receiver: received: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (DataMessage -> Text
forall a. WebSocketsData a => DataMessage -> a
WS.fromDataMessage DataMessage
msg' :: Text)
          Bool
_ <- Committer m (Either Text Text) -> Either Text Text -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m (Either Text Text)
c (Text -> Either Text Text
forall a b. b -> Either a b
Right (DataMessage -> Text
forall a. WebSocketsData a => DataMessage -> a
WS.fromDataMessage DataMessage
msg'))
          m Bool
go

-- | Receiver that only commits.
receiver ::
  (MonadIO m) =>
  Committer m Text ->
  WS.Connection ->
  m ()
receiver :: Committer m Text -> Connection -> m ()
receiver Committer m Text
c Connection
conn = m ()
go
  where
    go :: m ()
go = do
      Message
msg <- IO Message -> m Message
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Message -> m Message) -> IO Message -> m Message
forall a b. (a -> b) -> a -> b
$ Connection -> IO Message
WS.receive Connection
conn
      case Message
msg of
        WS.ControlMessage (WS.Close Word16
_ ByteString
_) -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        WS.ControlMessage ControlMessage
_ -> m ()
go
        WS.DataMessage Bool
_ Bool
_ Bool
_ DataMessage
msg' -> Committer m Text -> Text -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m Text
c (DataMessage -> Text
forall a. WebSocketsData a => DataMessage -> a
WS.fromDataMessage DataMessage
msg') m Bool -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
go

-- | Sender that only emits.
sender ::
  (MonadIO m, WS.WebSocketsData a, Show a) =>
  Box m Text a ->
  WS.Connection ->
  m ()
sender :: Box m Text a -> Connection -> m ()
sender (Box Committer m Text
c Emitter m a
e) Connection
conn = m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Maybe a
msg <- Emitter m a -> m (Maybe a)
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
e
  case Maybe a
msg of
    Maybe a
Nothing -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just a
msg' -> do
      Bool
_ <- Committer m Text -> Text -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m Text
c (Text -> m Bool) -> Text -> m Bool
forall a b. (a -> b) -> a -> b
$ Text
"sender: sending: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ((String -> Text
pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show) a
msg' :: Text)
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> a -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn a
msg'

-- | A receiver that responds based on received Text.
-- lefts are quit signals. Rights are response text.
responder ::
  (MonadIO m) =>
  (Text -> Either Text Text) ->
  Committer m Text ->
  WS.Connection ->
  m ()
responder :: (Text -> Either Text Text)
-> Committer m Text -> Connection -> m ()
responder Text -> Either Text Text
f Committer m Text
c Connection
conn = m ()
go
  where
    go :: m ()
go = do
      Message
msg <- IO Message -> m Message
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Message -> m Message) -> IO Message -> m Message
forall a b. (a -> b) -> a -> b
$ Connection -> IO Message
WS.receive Connection
conn
      case Message
msg of
        WS.ControlMessage (WS.Close Word16
_ ByteString
_) -> do
          Bool
_ <- Committer m Text -> Text -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m Text
c Text
"responder: normal close"
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendClose Connection
conn (Text
"received close signal: responder closed." :: Text)
        WS.ControlMessage ControlMessage
_ -> m ()
go
        WS.DataMessage Bool
_ Bool
_ Bool
_ DataMessage
msg' -> do
          case Text -> Either Text Text
f (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ DataMessage -> Text
forall a. WebSocketsData a => DataMessage -> a
WS.fromDataMessage DataMessage
msg' of
            Left Text
_ -> do
              Bool
_ <- Committer m Text -> Text -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m Text
c Text
"responder: sender initiated close"
              IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendClose Connection
conn (Text
"received close signal: responder closed." :: Text)
            Right Text
r -> do
              Bool
_ <- Committer m Text -> Text -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m Text
c (Text
"responder: sending" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r)
              IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn Text
r
              m ()
go