{-# LANGUAGE OverloadedStrings #-}
module Network.Run.TCP.Timeout (
runTCPServer,
TimeoutServer,
) where
import Control.Concurrent (forkFinally)
import qualified Control.Exception as E
import Control.Monad (forever, void)
import Network.Socket
import qualified System.TimeManager as T
import Network.Run.Core
type TimeoutServer a =
T.Manager
-> T.Handle
-> Socket
-> IO a
runTCPServer
:: Int
-> Maybe HostName
-> ServiceName
-> TimeoutServer a
-> IO a
runTCPServer :: forall a.
Int -> Maybe HostName -> HostName -> TimeoutServer a -> IO a
runTCPServer Int
tm Maybe HostName
mhost HostName
port TimeoutServer a
server = forall a. IO a -> IO a
withSocketsDo forall a b. (a -> b) -> a -> b
$ do
forall a. Int -> (Manager -> IO a) -> IO a
T.withManager (Int
tm forall a. Num a => a -> a -> a
* Int
1000000) forall a b. (a -> b) -> a -> b
$ \Manager
mgr -> do
AddrInfo
addr <- SocketType -> Maybe HostName -> HostName -> Bool -> IO AddrInfo
resolve SocketType
Stream Maybe HostName
mhost HostName
port Bool
True
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (AddrInfo -> IO Socket
open AddrInfo
addr) Socket -> IO ()
close forall a b. (a -> b) -> a -> b
$ forall {b}. Manager -> Socket -> IO b
loop Manager
mgr
where
open :: AddrInfo -> IO Socket
open AddrInfo
addr = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError (AddrInfo -> IO Socket
openServerSocket AddrInfo
addr) Socket -> IO ()
close forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
Socket -> Int -> IO ()
listen Socket
sock Int
1024
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
loop :: Manager -> Socket -> IO b
loop Manager
mgr Socket
sock = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError (Socket -> IO (Socket, SockAddr)
accept Socket
sock) (Socket -> IO ()
close forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
\(Socket
conn, SockAddr
_peer) ->
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (Manager -> Socket -> IO a
server' Manager
mgr Socket
conn) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Socket -> IO ()
gclose Socket
conn)
server' :: Manager -> Socket -> IO a
server' Manager
mgr Socket
conn = do
Handle
th <- Manager -> IO () -> IO Handle
T.registerKillThread Manager
mgr forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
TimeoutServer a
server Manager
mgr Handle
th Socket
conn