module SocketsAndPipes.Serve.Loop ( run ) where

import Control.Concurrent.Async       ( race_ )
import Control.Monad                  ( forever )

import SocketsAndPipes.Serve.OnError  ( OnError, bracketOnError, forkOnError )
import SocketsAndPipes.Serve.Finally  ( finallyInterruptible )
import SocketsAndPipes.Serve.Log      ( Write, writeException )
import SocketsAndPipes.Serve.Shutdown ( withRunStateVar, waitForShutdown )
import SocketsAndPipes.Serve.Sockets  ( PeerSocket, PassiveSocket, accept,
                                        closePeerSocketPolitely,
                                        closePeerSocketAbruptly )

run ::
    Write -- ^ How to write log messages
    -> (PeerSocket -> IO a) -- ^ What to do when a new client connects.
    -> PassiveSocket -- ^ A socket that is listening for connections.
    -> IO b -- ^ Perpetually awaits new connections, forking a new thread to handle each one.
run :: Write -> (PeerSocket -> IO a) -> PassiveSocket -> IO b
run Write
write PeerSocket -> IO a
go PassiveSocket
s =
  (RunStateVar -> IO b) -> IO b
forall a. (RunStateVar -> IO a) -> IO a
withRunStateVar ((RunStateVar -> IO b) -> IO b) -> (RunStateVar -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \RunStateVar
runStateVar ->
    IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$
      IO PeerSocket
-> (PeerSocket -> OnError) -> (PeerSocket -> IO ()) -> IO ()
forall resource c.
IO resource -> (resource -> OnError) -> (resource -> IO c) -> IO c
bracketOnError (PassiveSocket -> IO PeerSocket
accept PassiveSocket
s) ({-2-} Write -> PeerSocket -> OnError
logAndCloseAbruptly Write
write) ((PeerSocket -> IO ()) -> IO ()) -> (PeerSocket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PeerSocket
peer ->
        OnError -> IO () -> IO ()
forall a. OnError -> IO a -> IO ()
forkOnError ({-3-} Write -> PeerSocket -> OnError
logAndCloseAbruptly Write
write PeerSocket
peer) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          IO () -> IO a -> IO ()
forall a b. IO a -> IO b -> IO ()
race_ (RunStateVar -> IO ()
waitForShutdown RunStateVar
runStateVar IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> {-4-} PeerSocket -> IO ()
closePeerSocketAbruptly PeerSocket
peer) (IO a -> IO ()) -> IO a -> IO ()
forall a b. (a -> b) -> a -> b
$
            PeerSocket -> IO a
go PeerSocket
peer IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finallyInterruptible` {-1-} PeerSocket -> IO ()
closePeerSocketPolitely PeerSocket
peer

{-

Threads normally conclude with a graceful close of the peer socket. (1)

Since the graceful close procedure is a network operation that potentially
blocks for several seconds, exceptions are made in the following circumstances
where the delay would be unacceptable:

  * When a fork fails, thereby forcing the close to take place on the main thread,
    which needs to stay free to accept connections responsively. (2)

  * When the goal is to stop the forked thread as quickly as possible:

      * If an asynchronous exception has been thrown to the forked thread. (3)

      * If we're shutting down because an async exception has been thrown
        to the main thread. (4)

-}

logAndCloseAbruptly :: Write -> PeerSocket -> OnError
logAndCloseAbruptly :: Write -> PeerSocket -> OnError
logAndCloseAbruptly Write
write PeerSocket
peer SomeException
e =
  do
    PeerSocket -> IO ()
closePeerSocketAbruptly PeerSocket
peer
    Write -> OnError
writeException Write
write SomeException
e