{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -Wall #-}
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
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)
defaultSocketConfig :: SocketConfig
defaultSocketConfig :: SocketConfig
defaultSocketConfig = Text -> Int -> Text -> SocketConfig
SocketConfig Text
"127.0.0.1" Int
9160 Text
"/"
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
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
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)
)
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)
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)
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)
)
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 ::
(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 ::
(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'
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