{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -Wall #-}

-- | TCP Boxes.
module Box.TCP
  ( TCPConfig (..),
    defaultTCPConfig,
    Env (..),
    new,
    close,
    tcpEmitter,
    tcpCommitter,
    tcpBox,
    tcpServer,
    tcpResponder,
    tcpSender,
    tcpStdClient,
    testHarness,
    testResponder,
    testServerSender,
  )
where

import Box hiding (close)
import Control.Concurrent.Async
import Control.Monad
import Data.ByteString (ByteString)
import Data.Functor
import Data.Functor.Contravariant
import Data.Text (Text, unpack)
import Data.Text.Encoding
import GHC.Generics
import Network.Simple.TCP

-- | TCP configuration
--
-- >>> defaultTCPConfig
-- TCPConfig {host = "127.0.0.1", port = "3566"}
data TCPConfig = TCPConfig
  { TCPConfig -> Text
host :: Text,
    TCPConfig -> Text
port :: Text
  }
  deriving (Int -> TCPConfig -> ShowS
[TCPConfig] -> ShowS
TCPConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TCPConfig] -> ShowS
$cshowList :: [TCPConfig] -> ShowS
show :: TCPConfig -> String
$cshow :: TCPConfig -> String
showsPrec :: Int -> TCPConfig -> ShowS
$cshowsPrec :: Int -> TCPConfig -> ShowS
Show, TCPConfig -> TCPConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TCPConfig -> TCPConfig -> Bool
$c/= :: TCPConfig -> TCPConfig -> Bool
== :: TCPConfig -> TCPConfig -> Bool
$c== :: TCPConfig -> TCPConfig -> Bool
Eq, forall x. Rep TCPConfig x -> TCPConfig
forall x. TCPConfig -> Rep TCPConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TCPConfig x -> TCPConfig
$cfrom :: forall x. TCPConfig -> Rep TCPConfig x
Generic)

-- | default
defaultTCPConfig :: TCPConfig
defaultTCPConfig :: TCPConfig
defaultTCPConfig = Text -> Text -> TCPConfig
TCPConfig Text
"127.0.0.1" Text
"3566"

-- | An active TCP environment
data Env = Env
  { Env -> Socket
socket :: Socket,
    Env -> SockAddr
sockaddr :: SockAddr,
    -- | A screen dump thread
    Env -> Maybe (Async ())
ascreendump :: Maybe (Async ()),
    -- | A file dump thread
    Env -> Maybe (Async ())
afiledump :: Maybe (Async ())
  }

-- | Connects to a server with no screen or file dump.
new ::
  -- | Configuration
  TCPConfig ->
  IO Env
new :: TCPConfig -> IO Env
new TCPConfig
cfg = do
  (Socket
sock, SockAddr
sa) <- forall (m :: * -> *).
MonadIO m =>
String -> String -> m (Socket, SockAddr)
connectSock (Text -> String
unpack forall a b. (a -> b) -> a -> b
$ TCPConfig -> Text
host TCPConfig
cfg) (Text -> String
unpack forall a b. (a -> b) -> a -> b
$ TCPConfig -> Text
port TCPConfig
cfg)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Socket -> SockAddr -> Maybe (Async ()) -> Maybe (Async ()) -> Env
Env Socket
sock SockAddr
sa forall a. Maybe a
Nothing forall a. Maybe a
Nothing)

-- | close an Env
close :: Env -> IO ()
close :: Env -> IO ()
close Env
env = do
  forall (m :: * -> *). MonadIO m => Socket -> m ()
closeSock (Env -> Socket
socket Env
env)
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall a. Async a -> IO ()
cancel (Env -> Maybe (Async ())
ascreendump Env
env)
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall a. Async a -> IO ()
cancel (Env -> Maybe (Async ())
afiledump Env
env)

-- | Emits from a 'Socket'
tcpEmitter :: Socket -> Emitter IO ByteString
tcpEmitter :: Socket -> Emitter IO ByteString
tcpEmitter Socket
s = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Socket -> Int -> m (Maybe ByteString)
recv Socket
s Int
2048

-- | Commits to a 'Socket'
tcpCommitter :: Socket -> Committer IO ByteString
tcpCommitter :: Socket -> Committer IO ByteString
tcpCommitter Socket
s = forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer forall a b. (a -> b) -> a -> b
$ \ByteString
bs -> forall (m :: * -> *). MonadIO m => Socket -> ByteString -> m ()
send Socket
s ByteString
bs forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True

-- | 'Box' connection for a 'Socket'
tcpBox :: Socket -> Box IO ByteString ByteString
tcpBox :: Socket -> Box IO ByteString ByteString
tcpBox Socket
s = forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box (Socket -> Committer IO ByteString
tcpCommitter Socket
s) (Socket -> Emitter IO ByteString
tcpEmitter Socket
s)

-- | TCP server 'Box'
tcpServer :: TCPConfig -> Box IO ByteString ByteString -> IO ()
tcpServer :: TCPConfig -> Box IO ByteString ByteString -> IO ()
tcpServer TCPConfig
cfg (Box Committer IO ByteString
c Emitter IO ByteString
e) =
  forall (m :: * -> *) a.
MonadIO m =>
HostPreference -> String -> ((Socket, SockAddr) -> IO ()) -> m a
serve
    HostPreference
HostAny
    (Text -> String
unpack forall a b. (a -> b) -> a -> b
$ TCPConfig -> Text
port TCPConfig
cfg)
    ( \(Socket
s, SockAddr
_) ->
        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
            (forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue (Socket -> Committer IO ByteString
tcpCommitter Socket
s) Emitter IO ByteString
e)
            (forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue Committer IO ByteString
c (Socket -> Emitter IO ByteString
tcpEmitter Socket
s))
    )

-- | Response function.
responder :: (ByteString -> IO ByteString) -> Box IO ByteString ByteString -> IO ()
responder :: (ByteString -> IO ByteString)
-> Box IO ByteString ByteString -> IO ()
responder ByteString -> IO ByteString
f = forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Box m b a -> m ()
fuse (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ByteString
f)

-- | A server that explicitly responds to client messages.
tcpResponder :: TCPConfig -> (ByteString -> IO ByteString) -> IO ()
tcpResponder :: TCPConfig -> (ByteString -> IO ByteString) -> IO ()
tcpResponder TCPConfig
cfg ByteString -> IO ByteString
f =
  forall (m :: * -> *) a.
MonadIO m =>
HostPreference -> String -> ((Socket, SockAddr) -> IO ()) -> m a
serve
    HostPreference
HostAny
    (Text -> String
unpack forall a b. (a -> b) -> a -> b
$ TCPConfig -> Text
port TCPConfig
cfg)
    (\(Socket
s, SockAddr
_) -> (ByteString -> IO ByteString)
-> Box IO ByteString ByteString -> IO ()
responder ByteString -> IO ByteString
f (forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box (Socket -> Committer IO ByteString
tcpCommitter Socket
s) (Socket -> Emitter IO ByteString
tcpEmitter Socket
s)))

-- | A server independent of incoming messages.
tcpSender :: TCPConfig -> Emitter IO ByteString -> IO ()
tcpSender :: TCPConfig -> Emitter IO ByteString -> IO ()
tcpSender TCPConfig
cfg Emitter IO ByteString
e =
  forall (m :: * -> *) a.
MonadIO m =>
HostPreference -> String -> ((Socket, SockAddr) -> IO ()) -> m a
serve
    HostPreference
HostAny
    (Text -> String
unpack forall a b. (a -> b) -> a -> b
$ TCPConfig -> Text
port TCPConfig
cfg)
    (\(Socket
s, SockAddr
_) -> forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue (Socket -> Committer IO ByteString
tcpCommitter Socket
s) Emitter IO ByteString
e)

-- | A TCP client connected to stdin
tcpStdClient :: TCPConfig -> IO ()
tcpStdClient :: TCPConfig -> IO ()
tcpStdClient TCPConfig
cfg = do
  (Env Socket
s SockAddr
_ Maybe (Async ())
_ Maybe (Async ())
_) <- TCPConfig -> IO Env
new TCPConfig
cfg
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    forall a b. IO a -> IO b -> IO (a, b)
concurrently
      (forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue Committer IO ByteString
o (Socket -> Emitter IO ByteString
tcpEmitter Socket
s))
      (forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue (Socket -> Committer IO ByteString
tcpCommitter Socket
s) Emitter IO ByteString
i)
  where
    o :: Committer IO ByteString
o = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap ByteString -> Text
decodeUtf8 Committer IO Text
toStdout
    i :: Emitter IO ByteString
i = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
encodeUtf8 Emitter IO Text
fromStdin

-- | test harness wrapping an action with a "q" escape.
testHarness :: IO () -> IO ()
testHarness :: IO () -> IO ()
testHarness IO ()
io =
  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
      IO ()
io
      (Emitter IO Text -> IO ()
cancelQ Emitter IO Text
fromStdin)

-- | Cancel with a "q".
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 ()
    Just Text
x -> String -> IO ()
putStrLn (String
"badly handled: " forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
x)
    Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | @"echo: " <>@ Responder
testResponder :: IO ()
testResponder :: IO ()
testResponder = IO () -> IO ()
testHarness (TCPConfig -> (ByteString -> IO ByteString) -> IO ()
tcpResponder TCPConfig
defaultTCPConfig (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
"echo: " forall a. Semigroup a => a -> a -> a
<>)))

-- | Test server.
testServerSender :: IO ()
testServerSender :: IO ()
testServerSender =
  IO () -> IO ()
testHarness forall a b. (a -> b) -> a -> b
$
    TCPConfig -> Emitter IO ByteString -> IO ()
tcpSender TCPConfig
defaultTCPConfig forall a (m :: * -> *) r. (a -> m r) -> Codensity m a -> m r
<$|>
      forall a. [a] -> CoEmitter IO a
qList [ByteString
"hi!"]