{-# LANGUAGE DeriveGeneric #-}
{-# 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 Control.Concurrent.Async
import Control.Monad
import Control.Monad.Catch
import qualified Data.ByteString as BS
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
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
"/"

-- | Run a client app.
runClient :: SocketConfig -> WS.ClientApp () -> IO ()
runClient :: SocketConfig -> ClientApp () -> IO ()
runClient SocketConfig
c ClientApp ()
app = forall a. String -> Int -> String -> ClientApp a -> IO a
WS.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) ClientApp ()
app

-- | Run a server app.
runServer :: SocketConfig -> WS.ServerApp -> IO ()
runServer :: SocketConfig -> ServerApp -> IO ()
runServer SocketConfig
c ServerApp
app = String -> Int -> ServerApp -> IO ()
WS.runServer (Text -> String
unpack forall a b. (a -> b) -> a -> b
$ SocketConfig -> Text
host SocketConfig
c) (SocketConfig -> Int
port SocketConfig
c) ServerApp
app

-- | Connection continuation.
connect :: WS.PendingConnection -> Codensity IO WS.Connection
connect :: PendingConnection -> Codensity IO Connection
connect 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 (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket
    (PendingConnection -> IO Connection
WS.acceptRequest PendingConnection
p)
    (\Connection
conn -> forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendClose Connection
conn (Text
"Bye from connect!" :: Text))
    ( \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 ()
WS.sendPing Connection
conn (ByteString
"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)
    )

-- | A simple client app for a box with Left debug messages.
clientApp ::
  Box IO (Either Text Text) Text ->
  WS.Connection ->
  IO ()
clientApp :: Box IO (Either Text Text) Text -> ClientApp ()
clientApp (Box Committer IO (Either Text Text)
c Emitter IO Text
e) Connection
conn =
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    forall a b. IO a -> IO b -> IO (Either a b)
race
      (Committer IO (Either Text Text) -> Connection -> IO Bool
receiver' Committer IO (Either Text Text)
c Connection
conn)
      (forall a.
(WebSocketsData a, Show a) =>
Box IO Text a -> ClientApp ()
sender (forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box forall a. Monoid a => a
mempty Emitter IO 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 = forall a (m :: * -> *) r. (a -> m r) -> Codensity m a -> m r
process ((Text -> Either Text Text) -> Committer IO Text -> ClientApp ()
responder Text -> Either Text Text
f forall a. Monoid a => a
mempty) (PendingConnection -> Codensity IO Connection
connect PendingConnection
p)

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

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

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

-- | Sender that only emits.
sender ::
  (WS.WebSocketsData a, Show a) =>
  Box IO Text a ->
  WS.Connection ->
  IO ()
sender :: forall a.
(WebSocketsData a, Show a) =>
Box IO Text a -> ClientApp ()
sender (Box Committer IO Text
c Emitter IO a
e) Connection
conn = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ 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 ()
    Just a
msg' -> do
      Bool
_ <- forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO Text
c forall a b. (a -> b) -> a -> b
$ Text
"sender: sending: " forall a. Semigroup a => a -> a -> a
<> ((String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) a
msg' :: Text)
      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 ::
  (Text -> Either Text Text) ->
  Committer IO Text ->
  WS.Connection ->
  IO ()
responder :: (Text -> Either Text Text) -> Committer IO Text -> ClientApp ()
responder Text -> Either Text Text
f Committer IO Text
c Connection
conn = IO ()
go
  where
    go :: IO ()
go = do
      Message
msg <- Connection -> IO Message
WS.receive Connection
conn
      case Message
msg of
        WS.ControlMessage (WS.Close Word16
_ ByteString
_) -> do
          Bool
_ <- forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO Text
c Text
"responder: normal close"
          forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendClose Connection
conn (Text
"received close signal: responder closed." :: Text)
        WS.ControlMessage ControlMessage
_ -> IO ()
go
        WS.DataMessage Bool
_ Bool
_ Bool
_ DataMessage
msg' -> do
          case Text -> Either Text Text
f forall a b. (a -> b) -> a -> b
$ forall a. WebSocketsData a => DataMessage -> a
WS.fromDataMessage DataMessage
msg' of
            Left Text
_ -> do
              Bool
_ <- forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO Text
c Text
"responder: sender initiated close"
              forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendClose Connection
conn (Text
"received close signal: responder closed." :: Text)
            Right Text
r -> do
              Bool
_ <- forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO Text
c (Text
"responder: sending" forall a. Semigroup a => a -> a -> a
<> Text
r)
              forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn Text
r
              IO ()
go