{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}

{-

It's a box. It's a socket. It's an example.

-}

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

-- | test of clientApp via a cRef committer and a canned list of Text
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"]))

-- | main test run of client-server functionality
-- the code starts a server in a thread, starts the client in the main thread, and cancels the server on completion.
-- >>> testRun
-- [Left "receiver: received: echo:1",Right "echo:1",Left "receiver: received: echo:2",Right "echo:2",Left "receiver: received: echo:3",Right "echo:3",Left "receiver: received: close: 1000 \"received close signal: responder closed.\""]
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