{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE NamedFieldPuns   #-}
{-# OPTIONS_HADDOCK prune not-home #-}
{-|
Copyright   : (c) 2020-2021 Tim Emiola
SPDX-License-Identifier: BSD3
Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>

Provides functions that make it easy to run /'Application's/
 that access services running as @tmp@ @procs@ in integration tests.

-}
module System.TmpProc.Warp
  ( -- * Continuation-style setup
    testWithApplication
  , testWithReadyApplication
  , testWithTLSApplication
  , testWithReadyTLSApplication

    -- * ServerHandle
  , ServerHandle
  , serverPort
  , handles
  , shutdown
  , runServer
  , runReadyServer
  , runTLSServer
  , runReadyTLSServer

    -- * Health check support
  , checkHealth
  )

where

import           Control.Concurrent          (myThreadId, newEmptyMVar, putMVar,
                                              readMVar, takeMVar, threadDelay,
                                              throwTo)
import           Control.Exception           (ErrorCall (..))
import           Control.Monad               (void, when)
import           Control.Monad.Cont          (cont, runCont)
import           Network.Socket              (Socket, close)
import           Network.Wai                 (Application)
import qualified Network.Wai.Handler.Warp    as Warp
import qualified Network.Wai.Handler.WarpTLS as Warp
import           UnliftIO                    (Async, async, bracket, cancel,
                                              catch, onException, race, throwIO,
                                              waitEither)

import           System.TmpProc.Docker       (AreProcs, HList (..), HandlesOf,
                                              startupAll, terminateAll,
                                              withTmpProcs)


-- | Represents a started Warp application and any 'AreProcs' dependencies.
data ServerHandle procs = ServerHandle
  { ServerHandle procs -> Async ()
shServer  :: !(Async ())
  , ServerHandle procs -> Port
shPort    :: !Warp.Port
  , ServerHandle procs -> Socket
shSocket  :: !Socket
  , ServerHandle procs -> HandlesOf procs
shHandles :: !(HandlesOf procs)
  }

-- | Runs an 'Application' with @ProcHandle@ dependencies on a free port.
runServer
  :: AreProcs procs
  => HList procs
  -> (HandlesOf procs -> IO Application)
  -> IO (ServerHandle procs)
runServer :: HList procs
-> (HandlesOf procs -> IO Application) -> IO (ServerHandle procs)
runServer = (Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
forall (procs :: [*]).
AreProcs procs =>
(Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
runReadyServer Port -> IO ()
forall b. b -> IO ()
doNothing


{-| Like 'runServer'; with an additional @ready@ that determines if the server is ready.'. -}
runReadyServer
  :: AreProcs procs
  => (Warp.Port -> IO ())       --  ^ throws an exception if the server is not ready
  -> HList procs                --  ^ defines the dependent @Proc@s
  -> (HandlesOf procs -> IO Application)
  -> IO (ServerHandle procs)
runReadyServer :: (Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
runReadyServer = (Settings -> Socket -> Application -> IO ())
-> (Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
forall (procs :: [*]).
AreProcs procs =>
(Settings -> Socket -> Application -> IO ())
-> (Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
runReadyServer' Settings -> Socket -> Application -> IO ()
Warp.runSettingsSocket


{-| Like 'runServer'; the port is secured with 'Warp.TLSSettings'. -}
runTLSServer
  :: AreProcs procs
  => Warp.TLSSettings
  -> HList procs
  -> (HandlesOf procs -> IO Application)
  -> IO (ServerHandle procs)
runTLSServer :: TLSSettings
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
runTLSServer TLSSettings
tlsSettings = (Settings -> Socket -> Application -> IO ())
-> (Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
forall (procs :: [*]).
AreProcs procs =>
(Settings -> Socket -> Application -> IO ())
-> (Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
runReadyServer' (TLSSettings -> Settings -> Socket -> Application -> IO ()
Warp.runTLSSocket TLSSettings
tlsSettings)  Port -> IO ()
forall b. b -> IO ()
doNothing


{-| Like 'runReadyServer'; the port is secured with 'Warp.TLSSettings'. -}
runReadyTLSServer
  :: AreProcs procs
  => Warp.TLSSettings
  -> (Warp.Port -> IO ())       --  ^ throws an exception if the server is not ready
  -> HList procs                --  ^ defines the dependent @Proc@s
  -> (HandlesOf procs -> IO Application)
  -> IO (ServerHandle procs)
runReadyTLSServer :: TLSSettings
-> (Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
runReadyTLSServer TLSSettings
tlsSettings = (Settings -> Socket -> Application -> IO ())
-> (Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
forall (procs :: [*]).
AreProcs procs =>
(Settings -> Socket -> Application -> IO ())
-> (Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
runReadyServer' (TLSSettings -> Settings -> Socket -> Application -> IO ()
Warp.runTLSSocket TLSSettings
tlsSettings)


-- | Used to implement 'runReadyServer'
runReadyServer'
  :: AreProcs procs
  => (Warp.Settings -> Socket -> Application -> IO ())
  -> (Warp.Port -> IO ())       --  ^ throws an exception if the server is not ready
  -> HList procs                   --  ^ defines the dependent @Proc@s
  -> (HandlesOf procs -> IO Application)
  -> IO (ServerHandle procs)
runReadyServer' :: (Settings -> Socket -> Application -> IO ())
-> (Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
runReadyServer' Settings -> Socket -> Application -> IO ()
runApp Port -> IO ()
check HList procs
procs HandlesOf procs -> IO Application
mkApp = do
  ThreadId
callingThread <- IO ThreadId
myThreadId
  HandlesOf procs
h <- HList procs -> IO (HandlesOf procs)
forall (procs :: [*]).
AreProcs procs =>
HList procs -> IO (HandlesOf procs)
startupAll HList procs
procs
  (Port
p, Socket
sock) <- IO (Port, Socket)
Warp.openFreePort
  MVar ()
signal <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  let settings :: Settings
settings = IO () -> Settings
readySettings(MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
signal ())
  Application
app <- HandlesOf procs -> IO Application
mkApp HandlesOf procs
h
  let wrappedApp :: Application
wrappedApp Request
request Response -> IO ResponseReceived
respond =
        Application
app Request
request Response -> IO ResponseReceived
respond IO ResponseReceived
-> (SomeException -> IO ResponseReceived) -> IO ResponseReceived
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \ SomeException
e -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
            (SomeException -> Bool
Warp.defaultShouldDisplayException SomeException
e)
            (ThreadId -> SomeException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
callingThread SomeException
e)
          SomeException -> IO ResponseReceived
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e
  Async ()
s <- IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (Application -> IO Application
forall (f :: * -> *) a. Applicative f => a -> f a
pure Application
wrappedApp IO Application -> (Application -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Settings -> Socket -> Application -> IO ()
runApp Settings
settings Socket
sock)
  Async ()
aConfirm <- IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
signal)
  let result :: ServerHandle procs
result = Async () -> Port -> Socket -> HandlesOf procs -> ServerHandle procs
forall (procs :: [*]).
Async () -> Port -> Socket -> HandlesOf procs -> ServerHandle procs
ServerHandle Async ()
s Port
p Socket
sock HandlesOf procs
h
  Async () -> Async () -> IO (Either () ())
forall (m :: * -> *) a b.
MonadIO m =>
Async a -> Async b -> m (Either a b)
waitEither Async ()
s Async ()
aConfirm IO (Either () ())
-> (Either () () -> IO (ServerHandle procs))
-> IO (ServerHandle procs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left ()
_ -> do
      ServerHandle procs -> IO ()
forall (procs :: [*]).
AreProcs procs =>
ServerHandle procs -> IO ()
shutdown ServerHandle procs
result
      [Char] -> IO (ServerHandle procs)
forall a. HasCallStack => [Char] -> a
error [Char]
"setup: server thread stopped unexpectedly"
    Right ()
_ -> do
      Port -> IO ()
check Port
p IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException` ServerHandle procs -> IO ()
forall (procs :: [*]).
AreProcs procs =>
ServerHandle procs -> IO ()
shutdown ServerHandle procs
result
      ServerHandle procs -> IO (ServerHandle procs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerHandle procs
result


-- | Shuts down the 'ServerHandle' server and its @tmp proc@ dependencies.
shutdown :: AreProcs procs => ServerHandle procs -> IO ()
shutdown :: ServerHandle procs -> IO ()
shutdown ServerHandle procs
h = do
  let ServerHandle { Async ()
shServer :: Async ()
shServer :: forall (procs :: [*]). ServerHandle procs -> Async ()
shServer, Socket
shSocket :: Socket
shSocket :: forall (procs :: [*]). ServerHandle procs -> Socket
shSocket, HandlesOf procs
shHandles :: HandlesOf procs
shHandles :: forall (procs :: [*]). ServerHandle procs -> HandlesOf procs
shHandles } = ServerHandle procs
h
  HandlesOf procs -> IO ()
forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAll HandlesOf procs
shHandles
  Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel Async ()
shServer
  Socket -> IO ()
close Socket
shSocket


-- | The @'ServerHandle's@  @ProcHandles@.
handles :: AreProcs procs => ServerHandle procs -> HandlesOf procs
handles :: ServerHandle procs -> HandlesOf procs
handles = ServerHandle procs -> HandlesOf procs
forall (procs :: [*]). ServerHandle procs -> HandlesOf procs
shHandles


-- | The 'Warp.Port' on which the 'ServerHandle's server is running.
serverPort :: ServerHandle procs -> Warp.Port
serverPort :: ServerHandle procs -> Port
serverPort = ServerHandle procs -> Port
forall (procs :: [*]). ServerHandle procs -> Port
shPort


{-| Set up some @ProcHandles@ then run an 'Application' that uses them on a free
   port.

Allows the app to configure itself using the @tmp procs@, then provides a
callback with access to the handles.

The @tmp procs@ are shut down when the application is shut down.
-}
testWithApplication
  :: AreProcs procs
  => HList procs
  -> (HandlesOf procs -> IO Application)
  -> ((HandlesOf procs, Warp.Port) -> IO a)
  -> IO a
testWithApplication :: HList procs
-> (HandlesOf procs -> IO Application)
-> ((HandlesOf procs, Port) -> IO a)
-> IO a
testWithApplication HList procs
procs HandlesOf procs -> IO Application
mkApp = Cont (IO a) (HandlesOf procs, Port)
-> ((HandlesOf procs, Port) -> IO a) -> IO a
forall r a. Cont r a -> (a -> r) -> r
runCont (Cont (IO a) (HandlesOf procs, Port)
 -> ((HandlesOf procs, Port) -> IO a) -> IO a)
-> Cont (IO a) (HandlesOf procs, Port)
-> ((HandlesOf procs, Port) -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ do
  HandlesOf procs
oh <- ((HandlesOf procs -> IO a) -> IO a)
-> Cont (IO a) (HandlesOf procs)
forall a r. ((a -> r) -> r) -> Cont r a
cont (((HandlesOf procs -> IO a) -> IO a)
 -> Cont (IO a) (HandlesOf procs))
-> ((HandlesOf procs -> IO a) -> IO a)
-> Cont (IO a) (HandlesOf procs)
forall a b. (a -> b) -> a -> b
$ HList procs -> (HandlesOf procs -> IO a) -> IO a
forall (procs :: [*]) b.
AreProcs procs =>
HList procs -> (HandlesOf procs -> IO b) -> IO b
withTmpProcs HList procs
procs
  Port
p <- ((Port -> IO a) -> IO a) -> Cont (IO a) Port
forall a r. ((a -> r) -> r) -> Cont r a
cont (((Port -> IO a) -> IO a) -> Cont (IO a) Port)
-> ((Port -> IO a) -> IO a) -> Cont (IO a) Port
forall a b. (a -> b) -> a -> b
$ IO Application -> (Port -> IO a) -> IO a
forall a. IO Application -> (Port -> IO a) -> IO a
Warp.testWithApplication (IO Application -> (Port -> IO a) -> IO a)
-> IO Application -> (Port -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ HandlesOf procs -> IO Application
mkApp HandlesOf procs
oh
  (HandlesOf procs, Port) -> Cont (IO a) (HandlesOf procs, Port)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HandlesOf procs
oh, Port
p)


{-| Like 'testWithApplication', but the port is secured using a 'Warp.TLSSettings. '-}
testWithTLSApplication
  :: AreProcs procs
  =>  Warp.TLSSettings
  -> HList procs
  -> (HandlesOf procs -> IO Application)
  -> ((HandlesOf procs, Warp.Port) -> IO a)
  -> IO a
testWithTLSApplication :: TLSSettings
-> HList procs
-> (HandlesOf procs -> IO Application)
-> ((HandlesOf procs, Port) -> IO a)
-> IO a
testWithTLSApplication TLSSettings
tlsSettings HList procs
procs HandlesOf procs -> IO Application
mkApp = Cont (IO a) (HandlesOf procs, Port)
-> ((HandlesOf procs, Port) -> IO a) -> IO a
forall r a. Cont r a -> (a -> r) -> r
runCont (Cont (IO a) (HandlesOf procs, Port)
 -> ((HandlesOf procs, Port) -> IO a) -> IO a)
-> Cont (IO a) (HandlesOf procs, Port)
-> ((HandlesOf procs, Port) -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ do
  HandlesOf procs
oh <- ((HandlesOf procs -> IO a) -> IO a)
-> Cont (IO a) (HandlesOf procs)
forall a r. ((a -> r) -> r) -> Cont r a
cont (((HandlesOf procs -> IO a) -> IO a)
 -> Cont (IO a) (HandlesOf procs))
-> ((HandlesOf procs -> IO a) -> IO a)
-> Cont (IO a) (HandlesOf procs)
forall a b. (a -> b) -> a -> b
$ HList procs -> (HandlesOf procs -> IO a) -> IO a
forall (procs :: [*]) b.
AreProcs procs =>
HList procs -> (HandlesOf procs -> IO b) -> IO b
withTmpProcs HList procs
procs
  Port
p <- ((Port -> IO a) -> IO a) -> Cont (IO a) Port
forall a r. ((a -> r) -> r) -> Cont r a
cont (((Port -> IO a) -> IO a) -> Cont (IO a) Port)
-> ((Port -> IO a) -> IO a) -> Cont (IO a) Port
forall a b. (a -> b) -> a -> b
$ TLSSettings -> Settings -> IO Application -> (Port -> IO a) -> IO a
forall a.
TLSSettings -> Settings -> IO Application -> (Port -> IO a) -> IO a
withTLSApplicationSettings TLSSettings
tlsSettings Settings
Warp.defaultSettings (IO Application -> (Port -> IO a) -> IO a)
-> IO Application -> (Port -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ HandlesOf procs -> IO Application
mkApp HandlesOf procs
oh
  (HandlesOf procs, Port) -> Cont (IO a) (HandlesOf procs, Port)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HandlesOf procs
oh, Port
p)


{-| Set up some @ProcHandles@ then run an 'Application' that uses them on a free
   port.

Allows the app to configure itself using the @tmp procs@, then provides a
callback with access to the handles.

Also runs a @ready@ action that to determine if the application started
correctly.

The @tmp procs@ are shut down when the application is shut down.
-}
testWithReadyApplication
  :: AreProcs procs
  => (Warp.Port -> IO ()) -- throws an exception if the server is not ready
  -> HList procs
  -> (HandlesOf procs -> IO Application)
  -> ((HandlesOf procs, Warp.Port) -> IO a)
  -> IO a
testWithReadyApplication :: (Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> ((HandlesOf procs, Port) -> IO a)
-> IO a
testWithReadyApplication Port -> IO ()
check HList procs
procs HandlesOf procs -> IO Application
mkApp = Cont (IO a) (HandlesOf procs, Port)
-> ((HandlesOf procs, Port) -> IO a) -> IO a
forall r a. Cont r a -> (a -> r) -> r
runCont (Cont (IO a) (HandlesOf procs, Port)
 -> ((HandlesOf procs, Port) -> IO a) -> IO a)
-> Cont (IO a) (HandlesOf procs, Port)
-> ((HandlesOf procs, Port) -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ do
  HandlesOf procs
oh <- ((HandlesOf procs -> IO a) -> IO a)
-> Cont (IO a) (HandlesOf procs)
forall a r. ((a -> r) -> r) -> Cont r a
cont (((HandlesOf procs -> IO a) -> IO a)
 -> Cont (IO a) (HandlesOf procs))
-> ((HandlesOf procs -> IO a) -> IO a)
-> Cont (IO a) (HandlesOf procs)
forall a b. (a -> b) -> a -> b
$ HList procs -> (HandlesOf procs -> IO a) -> IO a
forall (procs :: [*]) b.
AreProcs procs =>
HList procs -> (HandlesOf procs -> IO b) -> IO b
withTmpProcs HList procs
procs
  PortWaiter ()
w <- ((PortWaiter () -> IO a) -> IO a) -> Cont (IO a) (PortWaiter ())
forall a r. ((a -> r) -> r) -> Cont r a
cont (((PortWaiter () -> IO a) -> IO a) -> Cont (IO a) (PortWaiter ()))
-> ((PortWaiter () -> IO a) -> IO a) -> Cont (IO a) (PortWaiter ())
forall a b. (a -> b) -> a -> b
$ IO (PortWaiter ())
-> (PortWaiter () -> IO ()) -> (PortWaiter () -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket ((Port -> IO ()) -> IO (PortWaiter ())
forall a. (Port -> IO a) -> IO (PortWaiter a)
mkWaiter Port -> IO ()
check) PortWaiter () -> IO ()
forall b. b -> IO ()
doNothing
  Port
p <- ((Port -> IO a) -> IO a) -> Cont (IO a) Port
forall a r. ((a -> r) -> r) -> Cont r a
cont (((Port -> IO a) -> IO a) -> Cont (IO a) Port)
-> ((Port -> IO a) -> IO a) -> Cont (IO a) Port
forall a b. (a -> b) -> a -> b
$ Settings -> IO Application -> (Port -> IO a) -> IO a
forall a. Settings -> IO Application -> (Port -> IO a) -> IO a
Warp.testWithApplicationSettings (PortWaiter () -> Settings
waiterSettings PortWaiter ()
w) (IO Application -> (Port -> IO a) -> IO a)
-> IO Application -> (Port -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ HandlesOf procs -> IO Application
mkApp HandlesOf procs
oh
  ()
_ <- ((() -> IO a) -> IO a) -> Cont (IO a) ()
forall a r. ((a -> r) -> r) -> Cont r a
cont (((() -> IO a) -> IO a) -> Cont (IO a) ())
-> ((() -> IO a) -> IO a) -> Cont (IO a) ()
forall a b. (a -> b) -> a -> b
$ IO () -> (() -> IO ()) -> (() -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (PortWaiter () -> Port -> IO ()
forall a. PortWaiter a -> Port -> IO a
waitFor PortWaiter ()
w Port
p) () -> IO ()
forall b. b -> IO ()
doNothing
  (HandlesOf procs, Port) -> Cont (IO a) (HandlesOf procs, Port)
forall (m :: * -> *) a. Monad m => a -> m a
return (HandlesOf procs
oh, Port
p)


{-| Like 'testWithReadyApplication'; the port is secured with 'Warp.TLSSettings'. -}
testWithReadyTLSApplication
  :: AreProcs procs
  => Warp.TLSSettings
  -> (Warp.Port -> IO ()) -- throws an exception if the server is not ready
  -> HList procs
  -> (HandlesOf procs -> IO Application)
  -> ((HandlesOf procs, Warp.Port) -> IO a)
  -> IO a
testWithReadyTLSApplication :: TLSSettings
-> (Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> ((HandlesOf procs, Port) -> IO a)
-> IO a
testWithReadyTLSApplication TLSSettings
tlsSettings Port -> IO ()
check HList procs
procs HandlesOf procs -> IO Application
mkApp = Cont (IO a) (HandlesOf procs, Port)
-> ((HandlesOf procs, Port) -> IO a) -> IO a
forall r a. Cont r a -> (a -> r) -> r
runCont (Cont (IO a) (HandlesOf procs, Port)
 -> ((HandlesOf procs, Port) -> IO a) -> IO a)
-> Cont (IO a) (HandlesOf procs, Port)
-> ((HandlesOf procs, Port) -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ do
  HandlesOf procs
oh <- ((HandlesOf procs -> IO a) -> IO a)
-> Cont (IO a) (HandlesOf procs)
forall a r. ((a -> r) -> r) -> Cont r a
cont (((HandlesOf procs -> IO a) -> IO a)
 -> Cont (IO a) (HandlesOf procs))
-> ((HandlesOf procs -> IO a) -> IO a)
-> Cont (IO a) (HandlesOf procs)
forall a b. (a -> b) -> a -> b
$ HList procs -> (HandlesOf procs -> IO a) -> IO a
forall (procs :: [*]) b.
AreProcs procs =>
HList procs -> (HandlesOf procs -> IO b) -> IO b
withTmpProcs HList procs
procs
  PortWaiter ()
w <- ((PortWaiter () -> IO a) -> IO a) -> Cont (IO a) (PortWaiter ())
forall a r. ((a -> r) -> r) -> Cont r a
cont (((PortWaiter () -> IO a) -> IO a) -> Cont (IO a) (PortWaiter ()))
-> ((PortWaiter () -> IO a) -> IO a) -> Cont (IO a) (PortWaiter ())
forall a b. (a -> b) -> a -> b
$ IO (PortWaiter ())
-> (PortWaiter () -> IO ()) -> (PortWaiter () -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket ((Port -> IO ()) -> IO (PortWaiter ())
forall a. (Port -> IO a) -> IO (PortWaiter a)
mkWaiter Port -> IO ()
check) PortWaiter () -> IO ()
forall b. b -> IO ()
doNothing
  Port
p <- ((Port -> IO a) -> IO a) -> Cont (IO a) Port
forall a r. ((a -> r) -> r) -> Cont r a
cont (((Port -> IO a) -> IO a) -> Cont (IO a) Port)
-> ((Port -> IO a) -> IO a) -> Cont (IO a) Port
forall a b. (a -> b) -> a -> b
$ TLSSettings -> Settings -> IO Application -> (Port -> IO a) -> IO a
forall a.
TLSSettings -> Settings -> IO Application -> (Port -> IO a) -> IO a
withTLSApplicationSettings TLSSettings
tlsSettings (PortWaiter () -> Settings
waiterSettings PortWaiter ()
w) (IO Application -> (Port -> IO a) -> IO a)
-> IO Application -> (Port -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ HandlesOf procs -> IO Application
mkApp HandlesOf procs
oh
  ()
_ <- ((() -> IO a) -> IO a) -> Cont (IO a) ()
forall a r. ((a -> r) -> r) -> Cont r a
cont (((() -> IO a) -> IO a) -> Cont (IO a) ())
-> ((() -> IO a) -> IO a) -> Cont (IO a) ()
forall a b. (a -> b) -> a -> b
$ IO () -> (() -> IO ()) -> (() -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (PortWaiter () -> Port -> IO ()
forall a. PortWaiter a -> Port -> IO a
waitFor PortWaiter ()
w Port
p) () -> IO ()
forall b. b -> IO ()
doNothing
  (HandlesOf procs, Port) -> Cont (IO a) (HandlesOf procs, Port)
forall (m :: * -> *) a. Monad m => a -> m a
return (HandlesOf procs
oh, Port
p)


-- | Simplifies writing the health checks used by @ready@ variants of this module.
checkHealth :: Int -> IO (Either a b) -> IO ()
checkHealth :: Port -> IO (Either a b) -> IO ()
checkHealth Port
tries IO (Either a b)
h = Port -> IO ()
forall t. (Eq t, Num t) => t -> IO ()
go Port
tries
  where
    go :: t -> IO ()
go t
0 = [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"healthy: server isn't healthy"
    go t
n = IO (Either a b)
h IO (Either a b) -> (Either a b -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left  a
_ -> Port -> IO ()
threadDelay Port
pingPeriod IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> t -> IO ()
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
      Right b
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()



-- | A 'Warp.Settings' configured with a ready action.
--
-- The ready action is used to check if a server is healthy.
readySettings :: IO () -> Warp.Settings
readySettings :: IO () -> Settings
readySettings IO ()
ready = IO () -> Settings -> Settings
Warp.setBeforeMainLoop IO ()
ready Settings
Warp.defaultSettings



-- | A 'Warp.Settings' configured with a ready action.
--
-- The ready action is used to check if a server is healthy.
waiterSettings :: PortWaiter () -> Warp.Settings
waiterSettings :: PortWaiter () -> Settings
waiterSettings PortWaiter ()
w = IO () -> Settings -> Settings
Warp.setBeforeMainLoop (PortWaiter () -> () -> IO ()
forall a. PortWaiter a -> a -> IO ()
notify PortWaiter ()
w ()) Settings
Warp.defaultSettings



-- | Simplifies creation of a ready action.
data PortWaiter a =
  PortWaiter
  { PortWaiter a -> a -> IO ()
notify  :: a -> IO ()
  , PortWaiter a -> Port -> IO a
waitFor :: Warp.Port -> IO a
  }


-- | Simplifies creation of a ready action.
mkWaiter :: (Warp.Port -> IO a) -> IO (PortWaiter a)
mkWaiter :: (Port -> IO a) -> IO (PortWaiter a)
mkWaiter Port -> IO a
check = do
  MVar a
mvar <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
  let waitFor :: Port -> IO a
waitFor Port
p = do
        a
res <- MVar a -> IO a
forall a. MVar a -> IO a
readMVar MVar a
mvar
        IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> IO a -> IO ()
forall a b. (a -> b) -> a -> b
$ Port -> IO a
check Port
p
        a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
  PortWaiter a -> IO (PortWaiter a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure PortWaiter :: forall a. (a -> IO ()) -> (Port -> IO a) -> PortWaiter a
PortWaiter
    { notify :: a -> IO ()
notify = MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
mvar
    , Port -> IO a
waitFor :: Port -> IO a
waitFor :: Port -> IO a
waitFor
    }


-- | Gap between service pings in milliseconds.
pingPeriod :: Int
pingPeriod :: Port
pingPeriod = Port
1000000


-- | Like 'Warp.testWithApplicationSettings' , but the port is secured using the
-- provided 'Warp.TLSSettings'.
withTLSApplicationSettings
  :: Warp.TLSSettings
  -> Warp.Settings
  -> IO Application
  -> (Warp.Port -> IO a)
  -> IO a
withTLSApplicationSettings :: TLSSettings -> Settings -> IO Application -> (Port -> IO a) -> IO a
withTLSApplicationSettings TLSSettings
tlsSettings Settings
settings IO Application
mkApp Port -> IO a
action = do
  Application
app <- IO Application
mkApp
  ((Port, Socket) -> IO a) -> IO a
forall a. ((Port, Socket) -> IO a) -> IO a
withFreePort (((Port, Socket) -> IO a) -> IO a)
-> ((Port, Socket) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ (Port
p, Socket
sock) -> do
    PortWaiter ()
started <- (Port -> IO ()) -> IO (PortWaiter ())
forall a. (Port -> IO a) -> IO (PortWaiter a)
mkWaiter Port -> IO ()
forall b. b -> IO ()
doNothing
    let settings' :: Settings
settings' = IO () -> Settings -> Settings
Warp.setBeforeMainLoop (PortWaiter () -> () -> IO ()
forall a. PortWaiter a -> a -> IO ()
notify PortWaiter ()
started ()) Settings
settings
    Either () a
result <- IO () -> IO a -> IO (Either () a)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
race
      (TLSSettings -> Settings -> Socket -> Application -> IO ()
Warp.runTLSSocket TLSSettings
tlsSettings Settings
settings' Socket
sock Application
app)
      (PortWaiter () -> Port -> IO ()
forall a. PortWaiter a -> Port -> IO a
waitFor PortWaiter ()
started Port
p IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Port -> IO a
action Port
p)
    case Either () a
result of
      Left () -> ErrorCall -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ErrorCall -> IO a) -> ErrorCall -> IO a
forall a b. (a -> b) -> a -> b
$ [Char] -> ErrorCall
ErrorCall [Char]
"Unexpected: runSettingsSocket exited"
      Right a
x -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x


-- | Like "Network.Wai.Handler.Warp.openFreePort" but closes the socket before exiting.
withFreePort :: ((Warp.Port, Socket) -> IO a) -> IO a
withFreePort :: ((Port, Socket) -> IO a) -> IO a
withFreePort = IO (Port, Socket)
-> ((Port, Socket) -> IO ()) -> ((Port, Socket) -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket IO (Port, Socket)
Warp.openFreePort (Socket -> IO ()
close (Socket -> IO ())
-> ((Port, Socket) -> Socket) -> (Port, Socket) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Port, Socket) -> Socket
forall a b. (a, b) -> b
snd)


-- | Improves readability...
doNothing :: b -> IO ()
doNothing :: b -> IO ()
doNothing = IO () -> b -> IO ()
forall a b. a -> b -> a
const (IO () -> b -> IO ()) -> IO () -> b -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()