{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_HADDOCK prune not-home #-}
module System.TmpProc.Warp
(
testWithApplication
, testWithReadyApplication
, testWithTLSApplication
, testWithReadyTLSApplication
, ServerHandle
, serverPort
, handles
, shutdown
, runServer
, runReadyServer
, runTLSServer
, runReadyTLSServer
, 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)
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)
}
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
runReadyServer
:: AreProcs procs
=> (Warp.Port -> IO ())
-> HList procs
-> (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
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
runReadyTLSServer
:: AreProcs procs
=> Warp.TLSSettings
-> (Warp.Port -> IO ())
-> HList procs
-> (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)
runReadyServer'
:: AreProcs procs
=> (Warp.Settings -> Socket -> Application -> IO ())
-> (Warp.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)
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
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
handles :: AreProcs procs => ServerHandle procs -> HandlesOf procs
handles :: ServerHandle procs -> HandlesOf procs
handles = ServerHandle procs -> HandlesOf procs
forall (procs :: [*]). ServerHandle procs -> HandlesOf procs
shHandles
serverPort :: ServerHandle procs -> Warp.Port
serverPort :: ServerHandle procs -> Port
serverPort = ServerHandle procs -> Port
forall (procs :: [*]). ServerHandle procs -> Port
shPort
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)
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)
testWithReadyApplication
:: AreProcs procs
=> (Warp.Port -> IO ())
-> 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)
testWithReadyTLSApplication
:: AreProcs procs
=> Warp.TLSSettings
-> (Warp.Port -> IO ())
-> 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)
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 ()
readySettings :: IO () -> Warp.Settings
readySettings :: IO () -> Settings
readySettings IO ()
ready = IO () -> Settings -> Settings
Warp.setBeforeMainLoop IO ()
ready Settings
Warp.defaultSettings
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
data PortWaiter a =
PortWaiter
{ PortWaiter a -> a -> IO ()
notify :: a -> IO ()
, PortWaiter a -> Port -> IO a
waitFor :: Warp.Port -> IO a
}
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
}
pingPeriod :: Int
pingPeriod :: Port
pingPeriod = Port
1000000
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
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)
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 ()