{-# 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
import Control.Concurrent.Async
import Control.Lens
import Control.Monad
import Data.ByteString (ByteString)
import Data.Functor
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
(Int -> TCPConfig -> ShowS)
-> (TCPConfig -> String)
-> ([TCPConfig] -> ShowS)
-> Show TCPConfig
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
(TCPConfig -> TCPConfig -> Bool)
-> (TCPConfig -> TCPConfig -> Bool) -> Eq TCPConfig
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. TCPConfig -> Rep TCPConfig x)
-> (forall x. Rep TCPConfig x -> TCPConfig) -> Generic TCPConfig
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) <- String -> String -> IO (Socket, SockAddr)
forall (m :: * -> *).
MonadIO m =>
String -> String -> m (Socket, SockAddr)
connectSock (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TCPConfig -> Text
host TCPConfig
cfg) (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TCPConfig -> Text
port TCPConfig
cfg)
  Env -> IO Env
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Socket -> SockAddr -> Maybe (Async ()) -> Maybe (Async ()) -> Env
Env Socket
sock SockAddr
sa Maybe (Async ())
forall a. Maybe a
Nothing Maybe (Async ())
forall a. Maybe a
Nothing)

-- | close an Env
close :: Env -> IO ()
close :: Env -> IO ()
close Env
env = do
  Socket -> IO ()
forall (m :: * -> *). MonadIO m => Socket -> m ()
closeSock (Env -> Socket
socket Env
env)
  IO () -> (Async () -> IO ()) -> Maybe (Async ()) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Async () -> IO ()
forall a. Async a -> IO ()
cancel (Env -> Maybe (Async ())
ascreendump Env
env)
  IO () -> (Async () -> IO ()) -> Maybe (Async ()) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Async () -> IO ()
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 = IO (Maybe ByteString) -> Emitter IO ByteString
forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (IO (Maybe ByteString) -> Emitter IO ByteString)
-> IO (Maybe ByteString) -> Emitter IO ByteString
forall a b. (a -> b) -> a -> b
$ Socket -> Int -> IO (Maybe ByteString)
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 = (ByteString -> IO Bool) -> Committer IO ByteString
forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer ((ByteString -> IO Bool) -> Committer IO ByteString)
-> (ByteString -> IO Bool) -> Committer IO ByteString
forall a b. (a -> b) -> a -> b
$ \ByteString
bs -> Socket -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Socket -> ByteString -> m ()
send Socket
s ByteString
bs IO () -> Bool -> IO Bool
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 = Committer IO ByteString
-> Emitter IO ByteString -> Box IO ByteString ByteString
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) =
  HostPreference -> String -> ((Socket, SockAddr) -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
HostPreference -> String -> ((Socket, SockAddr) -> IO ()) -> m a
serve
    HostPreference
HostAny
    (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TCPConfig -> Text
port TCPConfig
cfg)
    ( \(Socket
s, SockAddr
_) ->
        IO (Either () ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either () ()) -> IO ()) -> IO (Either () ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
          IO () -> IO () -> IO (Either () ())
forall a b. IO a -> IO b -> IO (Either a b)
race
            (Committer IO ByteString -> Emitter IO ByteString -> IO ()
forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue (Socket -> Committer IO ByteString
tcpCommitter Socket
s) Emitter IO ByteString
e)
            (Committer IO ByteString -> Emitter IO ByteString -> IO ()
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 (Box Committer IO ByteString
c Emitter IO ByteString
e) =
  Committer IO ByteString -> Emitter IO ByteString -> IO ()
forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue Committer IO ByteString
c ((ByteString -> IO (Maybe ByteString))
-> Emitter IO ByteString -> Emitter IO ByteString
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Emitter m a -> Emitter m b
mapE ((ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (IO ByteString -> IO (Maybe ByteString))
-> (ByteString -> IO ByteString)
-> ByteString
-> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ByteString
f) Emitter IO ByteString
e)

-- | 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 =
  HostPreference -> String -> ((Socket, SockAddr) -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
HostPreference -> String -> ((Socket, SockAddr) -> IO ()) -> m a
serve
    HostPreference
HostAny
    (Text -> String
unpack (Text -> String) -> Text -> String
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 (Committer IO ByteString
-> Emitter IO ByteString -> Box IO ByteString ByteString
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 =
  HostPreference -> String -> ((Socket, SockAddr) -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
HostPreference -> String -> ((Socket, SockAddr) -> IO ()) -> m a
serve
    HostPreference
HostAny
    (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TCPConfig -> Text
port TCPConfig
cfg)
    (\(Socket
s, SockAddr
_) -> Committer IO ByteString -> Emitter IO ByteString -> IO ()
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
  IO ((), ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ((), ()) -> IO ()) -> IO ((), ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
    IO () -> IO () -> IO ((), ())
forall a b. IO a -> IO b -> IO (a, b)
concurrently
      (Committer IO ByteString -> Emitter IO ByteString -> IO ()
forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue Committer IO ByteString
o (Socket -> Emitter IO ByteString
tcpEmitter Socket
s))
      (Committer IO ByteString -> Emitter IO ByteString -> IO ()
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 = (ByteString -> Text)
-> Committer IO Text -> Committer IO ByteString
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ByteString -> Text
decodeUtf8 Committer IO Text
toStdout
    i :: Emitter IO ByteString
i = (Text -> ByteString) -> Emitter IO Text -> Emitter IO ByteString
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 =
  IO (Either () ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either () ()) -> IO ()) -> IO (Either () ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
    IO () -> IO () -> IO (Either () ())
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' <- 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 ()
    Just Text
x -> String -> IO ()
putStrLn (String
"badly handled: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
x)
    Maybe Text
Nothing -> () -> IO ()
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 (ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString)
-> (ByteString -> ByteString) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
"echo: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>)))

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