{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
module Box.Socket.Example where
import Box
import Box.Socket
import Control.Concurrent.Classy.Async as C
import Data.Bool
import Data.Functor.Contravariant
import Data.Text (Text, pack)
serverIO :: IO ()
serverIO :: IO ()
serverIO =
SocketConfig -> ServerApp -> IO ()
forall (m :: * -> *).
MonadIO m =>
SocketConfig -> ServerApp -> m ()
runServer
SocketConfig
defaultSocketConfig
((Text -> Either Text Text) -> ServerApp
responderApp (\Text
x -> Either Text Text -> Either Text Text -> Bool -> Either Text Text
forall a. a -> a -> Bool -> a
bool (Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"echo:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x) (Text -> Either Text Text
forall a b. a -> Either a b
Left Text
"quit") (Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"q")))
clientIO :: IO ()
clientIO :: IO ()
clientIO =
(SocketConfig -> ClientApp () -> IO ()
forall (m :: * -> *).
MonadIO m =>
SocketConfig -> ClientApp () -> m ()
runClient SocketConfig
defaultSocketConfig (ClientApp () -> IO ())
-> (Box IO (Either Text Text) Text -> ClientApp ())
-> Box IO (Either Text Text) Text
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box IO (Either Text Text) Text -> ClientApp ()
forall (m :: * -> *).
(MonadIO m, MonadConc m) =>
Box m (Either Text Text) Text -> Connection -> m ()
clientApp)
(Committer IO (Either Text Text)
-> Emitter IO Text -> Box IO (Either Text Text) Text
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box ((Either Text Text -> Text)
-> Committer IO Text -> Committer IO (Either Text Text)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (String -> Text
pack (String -> Text)
-> (Either Text Text -> String) -> Either Text Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text Text -> String
forall a. Show a => a -> String
show) Committer IO Text
toStdout) Emitter IO Text
fromStdin)
q' :: IO a -> IO (Either () a)
q' :: IO a -> IO (Either () a)
q' IO a
f = IO () -> IO a -> IO (Either () a)
forall (m :: * -> *) a b.
MonadConc m =>
m a -> m b -> m (Either a b)
C.race (Emitter IO Text -> IO ()
cancelQ Emitter IO Text
fromStdin) IO a
f
cancelQ :: Emitter IO Text -> IO ()
cancelQ :: Emitter IO Text -> IO ()
cancelQ Emitter IO Text
e = do
Maybe Text
e' <- Emitter IO Text -> IO (Maybe Text)
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO Text
e
case Maybe Text
e' of
Just Text
"q" -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Maybe Text
_notQ -> do
String -> IO ()
putStrLn String
"nothing happens"
Emitter IO Text -> IO ()
cancelQ Emitter IO Text
e
tClient :: [Text] -> IO [Either Text Text]
tClient :: [Text] -> IO [Either Text Text]
tClient [Text]
xs = do
(Committer IO (Either Text Text)
c, IO [Either Text Text]
r) <- IO (Committer IO (Either Text Text), IO [Either Text Text])
forall (m :: * -> *) a. MonadConc m => m (Committer m a, m [a])
refCommitter
SocketConfig -> ClientApp () -> IO ()
forall (m :: * -> *).
MonadIO m =>
SocketConfig -> ClientApp () -> m ()
runClient
SocketConfig
defaultSocketConfig
( \Connection
conn ->
(\Box IO (Either Text Text) Text
b -> Box IO (Either Text Text) Text -> ClientApp ()
forall (m :: * -> *).
(MonadIO m, MonadConc m) =>
Box m (Either Text Text) Text -> Connection -> m ()
clientApp Box IO (Either Text Text) Text
b Connection
conn)
(Box IO (Either Text Text) Text -> IO ())
-> Codensity IO (Box IO (Either Text Text) Text) -> IO ()
forall a (m :: * -> *) r. (a -> m r) -> Codensity m a -> m r
<$|> ( Committer IO (Either Text Text)
-> Emitter IO Text -> Box IO (Either Text Text) Text
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box Committer IO (Either Text Text)
c
(Emitter IO Text -> Box IO (Either Text Text) Text)
-> Codensity IO (Emitter IO Text)
-> Codensity IO (Box IO (Either Text Text) Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Codensity IO (Emitter IO Text)
forall (m :: * -> *) a. MonadConc m => [a] -> CoEmitter m a
qList ([Text]
xs [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"q"])
)
)
IO [Either Text Text]
r
tClientIO :: [Text] -> IO ()
tClientIO :: [Text] -> IO ()
tClientIO [Text]
xs =
(SocketConfig -> ClientApp () -> IO ()
forall (m :: * -> *).
MonadIO m =>
SocketConfig -> ClientApp () -> m ()
runClient SocketConfig
defaultSocketConfig (ClientApp () -> IO ())
-> (Box IO (Either Text Text) Text -> ClientApp ())
-> Box IO (Either Text Text) Text
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box IO (Either Text Text) Text -> ClientApp ()
forall (m :: * -> *).
(MonadIO m, MonadConc m) =>
Box m (Either Text Text) Text -> Connection -> m ()
clientApp)
(Box IO (Either Text Text) Text -> IO ())
-> Codensity IO (Box IO (Either Text Text) Text) -> IO ()
forall a (m :: * -> *) r. (a -> m r) -> Codensity m a -> m r
<$|> (Committer IO (Either Text Text)
-> Emitter IO Text -> Box IO (Either Text Text) Text
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box ((Either Text Text -> Text)
-> Committer IO Text -> Committer IO (Either Text Text)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (String -> Text
pack (String -> Text)
-> (Either Text Text -> String) -> Either Text Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text Text -> String
forall a. Show a => a -> String
show) Committer IO Text
toStdout) (Emitter IO Text -> Box IO (Either Text Text) Text)
-> Codensity IO (Emitter IO Text)
-> Codensity IO (Box IO (Either Text Text) Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Codensity IO (Emitter IO Text)
forall (m :: * -> *) a. MonadConc m => [a] -> CoEmitter m a
qList ([Text]
xs [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"q"]))
testRun :: IO [Either Text Text]
testRun :: IO [Either Text Text]
testRun = do
Async IO ()
a <- IO () -> IO (Async IO ())
forall (m :: * -> *) a. MonadConc m => m a -> m (Async m a)
C.async (SocketConfig -> ServerApp -> IO ()
forall (m :: * -> *).
MonadIO m =>
SocketConfig -> ServerApp -> m ()
runServer SocketConfig
defaultSocketConfig ((Text -> Either Text Text) -> ServerApp
responderApp (\Text
x -> Either Text Text -> Either Text Text -> Bool -> Either Text Text
forall a. a -> a -> Bool -> a
bool (Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"echo:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x) (Text -> Either Text Text
forall a b. a -> Either a b
Left Text
"quit") (Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"q"))))
Double -> IO ()
forall (m :: * -> *). MonadConc m => Double -> m ()
sleep Double
0.1
[Either Text Text]
r <- [Text] -> IO [Either Text Text]
tClient (String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> [Int] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
1 .. Int
3 :: Int])
Async IO () -> IO ()
forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
C.cancel Async IO ()
a
[Either Text Text] -> IO [Either Text Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Either Text Text]
r