{-# 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.Async
import Data.Bool
import Data.Functor.Contravariant
import Data.Text (Text, pack)
serverIO :: IO ()
serverIO :: IO ()
serverIO =
SocketConfig -> ServerApp -> IO ()
runServer
SocketConfig
defaultSocketConfig
((Text -> Either Text Text) -> ServerApp
responderApp (\Text
x -> forall a. a -> a -> Bool -> a
bool (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text
"echo:" forall a. Semigroup a => a -> a -> a
<> Text
x) (forall a b. a -> Either a b
Left Text
"quit") (Text
x forall a. Eq a => a -> a -> Bool
== Text
"q")))
clientIO :: IO ()
clientIO :: IO ()
clientIO =
(SocketConfig -> ClientApp () -> IO ()
runClient SocketConfig
defaultSocketConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box IO (Either Text Text) Text -> ClientApp ()
clientApp)
(forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Committer IO Text
toStdout) Emitter IO Text
fromStdin)
q' :: IO a -> IO (Either () a)
q' :: forall a. IO a -> IO (Either () a)
q' IO a
f = forall a b. IO a -> IO b -> IO (Either a b)
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' <- forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO Text
e
case Maybe Text
e' of
Just Text
"q" -> 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) <- forall a. IO (Committer IO a, IO [a])
refCommitter
SocketConfig -> ClientApp () -> IO ()
runClient
SocketConfig
defaultSocketConfig
( \Connection
conn ->
(\Box IO (Either Text Text) Text
b -> Box IO (Either Text Text) Text -> ClientApp ()
clientApp Box IO (Either Text Text) Text
b Connection
conn) forall a (m :: * -> *) r. (a -> m r) -> Codensity m a -> m r
<$|>
( forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box Committer IO (Either Text Text)
c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> CoEmitter IO a
qList ([Text]
xs 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 ()
runClient SocketConfig
defaultSocketConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box IO (Either Text Text) Text -> ClientApp ()
clientApp) forall a (m :: * -> *) r. (a -> m r) -> Codensity m a -> m r
<$|>
(forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Committer IO Text
toStdout) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> CoEmitter IO a
qList ([Text]
xs forall a. Semigroup a => a -> a -> a
<> [Text
"q"]))
testRun :: IO [Either Text Text]
testRun :: IO [Either Text Text]
testRun = do
Async ()
a <- forall a. IO a -> IO (Async a)
async (SocketConfig -> ServerApp -> IO ()
runServer SocketConfig
defaultSocketConfig ((Text -> Either Text Text) -> ServerApp
responderApp (\Text
x -> forall a. a -> a -> Bool -> a
bool (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text
"echo:" forall a. Semigroup a => a -> a -> a
<> Text
x) (forall a b. a -> Either a b
Left Text
"quit") (Text
x forall a. Eq a => a -> a -> Bool
== Text
"q"))))
Double -> IO ()
sleep Double
0.1
[Either Text Text]
r <- [Text] -> IO [Either Text Text]
tClient (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
1 .. Int
3 :: Int])
forall a. Async a -> IO ()
cancel Async ()
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Either Text Text]
r