{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -Wall #-}
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
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)
defaultTCPConfig :: TCPConfig
defaultTCPConfig :: TCPConfig
defaultTCPConfig = Text -> Text -> TCPConfig
TCPConfig Text
"127.0.0.1" Text
"3566"
data Env = Env
{ Env -> Socket
socket :: Socket,
Env -> SockAddr
sockaddr :: SockAddr,
Env -> Maybe (Async ())
ascreendump :: Maybe (Async ()),
Env -> Maybe (Async ())
afiledump :: Maybe (Async ())
}
new ::
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 :: 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)
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
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
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)
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))
)
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)
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)))
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)
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
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)
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 ()
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
<>)))
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!"]