{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}

module Metro.TCPServer
  ( TCPServer
  , tcpServer
  ) where

import           Control.Monad      (void)
import           Metro.Class        (Servable (..))
import           Metro.Socket       (listen)
import           Metro.TP.TCPSocket (TCPSocket, tcpSocket_)
import           Network.Socket     (Socket, SocketOption (KeepAlive), accept,
                                     setSocketOption)
import qualified Network.Socket     as Socket (close)
import           UnliftIO           (async, liftIO)

newtype TCPServer = TCPServer Socket

instance Servable TCPServer where
  data ServerConfig TCPServer = TCPConfig String
  type SID TCPServer = Socket
  type STP TCPServer = TCPSocket
  newServer :: ServerConfig TCPServer -> m TCPServer
newServer (TCPConfig hostPort) = IO TCPServer -> m TCPServer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TCPServer -> m TCPServer) -> IO TCPServer -> m TCPServer
forall a b. (a -> b) -> a -> b
$ Socket -> TCPServer
TCPServer (Socket -> TCPServer) -> IO Socket -> IO TCPServer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Socket
listen String
hostPort
  servOnce :: TCPServer
-> (Maybe (SID TCPServer, TransportConfig (STP TCPServer)) -> m ())
-> m ()
servOnce (TCPServer Socket
serv) Maybe (SID TCPServer, TransportConfig (STP TCPServer)) -> m ()
done = do
    (Socket
sock, SockAddr
_) <- IO (Socket, SockAddr) -> m (Socket, SockAddr)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Socket, SockAddr) -> m (Socket, SockAddr))
-> IO (Socket, SockAddr) -> m (Socket, SockAddr)
forall a b. (a -> b) -> a -> b
$ Socket -> IO (Socket, SockAddr)
accept Socket
serv
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
sock SocketOption
KeepAlive Int
1
    m (Async ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Async ()) -> m ()) -> m (Async ()) -> m ()
forall a b. (a -> b) -> a -> b
$ m () -> m (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (m () -> m (Async ())) -> m () -> m (Async ())
forall a b. (a -> b) -> a -> b
$ do
      Maybe (SID TCPServer, TransportConfig (STP TCPServer)) -> m ()
done (Maybe (SID TCPServer, TransportConfig (STP TCPServer)) -> m ())
-> Maybe (SID TCPServer, TransportConfig (STP TCPServer)) -> m ()
forall a b. (a -> b) -> a -> b
$ (Socket, TransportConfig TCPSocket)
-> Maybe (Socket, TransportConfig TCPSocket)
forall a. a -> Maybe a
Just (Socket
sock, Socket -> TransportConfig TCPSocket
tcpSocket_ Socket
sock)
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Socket -> IO ()
Socket.close Socket
sock
  onConnEnter :: TCPServer -> SID TCPServer -> m ()
onConnEnter TCPServer
_ SID TCPServer
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  onConnLeave :: TCPServer -> SID TCPServer -> m ()
onConnLeave TCPServer
_ SID TCPServer
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  servClose :: TCPServer -> m ()
servClose (TCPServer Socket
serv) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Socket -> IO ()
Socket.close Socket
serv

tcpServer :: String -> ServerConfig TCPServer
tcpServer :: String -> ServerConfig TCPServer
tcpServer = String -> ServerConfig TCPServer
TCPConfig