{-# 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 System.TmpProc.Docker
( AreProcs
, HList (..)
, HandlesOf
, startupAll
, terminateAll
, withTmpProcs
)
import UnliftIO
( Async
, async
, bracket
, cancel
, catch
, onException
, race
, throwIO
, waitEither
)
data ServerHandle procs = ServerHandle
{ forall (procs :: [*]). ServerHandle procs -> Async ()
shServer :: !(Async ())
, forall (procs :: [*]). ServerHandle procs -> Port
shPort :: !Warp.Port
, forall (procs :: [*]). ServerHandle procs -> Socket
shSocket :: !Socket
, forall (procs :: [*]). ServerHandle procs -> HandlesOf procs
shHandles :: !(HandlesOf procs)
}
runServer ::
(AreProcs procs) =>
HList procs ->
(HandlesOf procs -> IO Application) ->
IO (ServerHandle procs)
runServer :: forall (procs :: [*]).
AreProcs procs =>
HList procs
-> (HandlesOf procs -> IO Application) -> IO (ServerHandle procs)
runServer = forall (procs :: [*]).
AreProcs procs =>
(Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
runReadyServer forall b. b -> IO ()
doNothing
runReadyServer ::
(AreProcs procs) =>
(Warp.Port -> IO ()) ->
HList procs ->
(HandlesOf procs -> IO Application) ->
IO (ServerHandle procs)
runReadyServer :: forall (procs :: [*]).
AreProcs procs =>
(Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
runReadyServer = 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 :: forall (procs :: [*]).
AreProcs procs =>
TLSSettings
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
runTLSServer TLSSettings
tlsSettings = 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) forall b. b -> IO ()
doNothing
runReadyTLSServer ::
(AreProcs procs) =>
Warp.TLSSettings ->
(Warp.Port -> IO ()) ->
HList procs ->
(HandlesOf procs -> IO Application) ->
IO (ServerHandle procs)
runReadyTLSServer :: forall (procs :: [*]).
AreProcs procs =>
TLSSettings
-> (Port -> IO ())
-> HList procs
-> (HandlesOf procs -> IO Application)
-> IO (ServerHandle procs)
runReadyTLSServer TLSSettings
tlsSettings = 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' :: forall (procs :: [*]).
AreProcs procs =>
(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 <- forall (procs :: [*]).
AreProcs procs =>
HList procs -> IO (HandlesOf procs)
startupAll HList procs
procs
(Port
p, Socket
sock) <- IO (Port, Socket)
Warp.openFreePort
MVar ()
signal <- forall a. IO (MVar a)
newEmptyMVar
let settings :: Settings
settings = IO () -> Settings
readySettings (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 forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \SomeException
e -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
(SomeException -> Bool
Warp.defaultShouldDisplayException SomeException
e)
(forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
callingThread SomeException
e)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e
Async ()
s <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async forall a b. (a -> b) -> a -> b
$ Settings -> Socket -> Application -> IO ()
runApp Settings
settings Socket
sock Application
wrappedApp
Async ()
aConfirm <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (forall a. MVar a -> IO a
takeMVar MVar ()
signal)
let result :: ServerHandle procs
result = forall (procs :: [*]).
Async () -> Port -> Socket -> HandlesOf procs -> ServerHandle procs
ServerHandle Async ()
s Port
p Socket
sock HandlesOf procs
h
forall (m :: * -> *) a b.
MonadIO m =>
Async a -> Async b -> m (Either a b)
waitEither Async ()
s Async ()
aConfirm forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left ()
_ -> do
forall (procs :: [*]).
AreProcs procs =>
ServerHandle procs -> IO ()
shutdown ServerHandle procs
result
forall a. HasCallStack => [Char] -> a
error [Char]
"setup: server thread stopped unexpectedly"
Right ()
_ -> do
Port -> IO ()
check Port
p forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException` forall (procs :: [*]).
AreProcs procs =>
ServerHandle procs -> IO ()
shutdown ServerHandle procs
result
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerHandle procs
result
shutdown :: (AreProcs procs) => ServerHandle procs -> IO ()
shutdown :: forall (procs :: [*]).
AreProcs procs =>
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
forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAll HandlesOf procs
shHandles
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel Async ()
shServer
Socket -> IO ()
close Socket
shSocket
handles :: (AreProcs procs) => ServerHandle procs -> HandlesOf procs
handles :: forall (procs :: [*]).
AreProcs procs =>
ServerHandle procs -> HandlesOf procs
handles = forall (procs :: [*]). ServerHandle procs -> HandlesOf procs
shHandles
serverPort :: ServerHandle procs -> Warp.Port
serverPort :: forall (procs :: [*]). ServerHandle procs -> Port
serverPort = forall (procs :: [*]). ServerHandle procs -> Port
shPort
testWithApplication ::
(AreProcs procs) =>
HList procs ->
(HandlesOf procs -> IO Application) ->
((HandlesOf procs, Warp.Port) -> IO a) ->
IO a
testWithApplication :: forall (procs :: [*]) a.
AreProcs procs =>
HList procs
-> (HandlesOf procs -> IO Application)
-> ((HandlesOf procs, Port) -> IO a)
-> IO a
testWithApplication HList procs
procs HandlesOf procs -> IO Application
mkApp = forall r a. Cont r a -> (a -> r) -> r
runCont forall a b. (a -> b) -> a -> b
$ do
HandlesOf procs
oh <- forall a r. ((a -> r) -> r) -> Cont r a
cont forall a b. (a -> b) -> a -> b
$ forall (procs :: [*]) b.
AreProcs procs =>
HList procs -> (HandlesOf procs -> IO b) -> IO b
withTmpProcs HList procs
procs
Port
p <- forall a r. ((a -> r) -> r) -> Cont r a
cont forall a b. (a -> b) -> a -> b
$ forall a. IO Application -> (Port -> IO a) -> IO a
Warp.testWithApplication forall a b. (a -> b) -> a -> b
$ HandlesOf procs -> IO Application
mkApp HandlesOf procs
oh
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 :: forall (procs :: [*]) a.
AreProcs procs =>
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 = forall r a. Cont r a -> (a -> r) -> r
runCont forall a b. (a -> b) -> a -> b
$ do
HandlesOf procs
oh <- forall a r. ((a -> r) -> r) -> Cont r a
cont forall a b. (a -> b) -> a -> b
$ forall (procs :: [*]) b.
AreProcs procs =>
HList procs -> (HandlesOf procs -> IO b) -> IO b
withTmpProcs HList procs
procs
Port
p <- forall a r. ((a -> r) -> r) -> Cont r a
cont forall a b. (a -> b) -> a -> b
$ forall a.
TLSSettings -> Settings -> IO Application -> (Port -> IO a) -> IO a
withTLSApplicationSettings TLSSettings
tlsSettings Settings
Warp.defaultSettings forall a b. (a -> b) -> a -> b
$ HandlesOf procs -> IO Application
mkApp HandlesOf procs
oh
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 :: forall (procs :: [*]) a.
AreProcs procs =>
(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 = forall r a. Cont r a -> (a -> r) -> r
runCont forall a b. (a -> b) -> a -> b
$ do
HandlesOf procs
oh <- forall a r. ((a -> r) -> r) -> Cont r a
cont forall a b. (a -> b) -> a -> b
$ forall (procs :: [*]) b.
AreProcs procs =>
HList procs -> (HandlesOf procs -> IO b) -> IO b
withTmpProcs HList procs
procs
PortWaiter ()
w <- forall a r. ((a -> r) -> r) -> Cont r a
cont forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (forall a. (Port -> IO a) -> IO (PortWaiter a)
mkWaiter Port -> IO ()
check) forall b. b -> IO ()
doNothing
Port
p <- forall a r. ((a -> r) -> r) -> Cont r a
cont forall a b. (a -> b) -> a -> b
$ forall a. Settings -> IO Application -> (Port -> IO a) -> IO a
Warp.testWithApplicationSettings (PortWaiter () -> Settings
waiterSettings PortWaiter ()
w) forall a b. (a -> b) -> a -> b
$ HandlesOf procs -> IO Application
mkApp HandlesOf procs
oh
()
_ <- forall a r. ((a -> r) -> r) -> Cont r a
cont forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (forall a. PortWaiter a -> Port -> IO a
waitFor PortWaiter ()
w Port
p) forall b. b -> IO ()
doNothing
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 :: forall (procs :: [*]) a.
AreProcs procs =>
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 = forall r a. Cont r a -> (a -> r) -> r
runCont forall a b. (a -> b) -> a -> b
$ do
HandlesOf procs
oh <- forall a r. ((a -> r) -> r) -> Cont r a
cont forall a b. (a -> b) -> a -> b
$ forall (procs :: [*]) b.
AreProcs procs =>
HList procs -> (HandlesOf procs -> IO b) -> IO b
withTmpProcs HList procs
procs
PortWaiter ()
w <- forall a r. ((a -> r) -> r) -> Cont r a
cont forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (forall a. (Port -> IO a) -> IO (PortWaiter a)
mkWaiter Port -> IO ()
check) forall b. b -> IO ()
doNothing
Port
p <- forall a r. ((a -> r) -> r) -> Cont r a
cont forall a b. (a -> b) -> a -> b
$ forall a.
TLSSettings -> Settings -> IO Application -> (Port -> IO a) -> IO a
withTLSApplicationSettings TLSSettings
tlsSettings (PortWaiter () -> Settings
waiterSettings PortWaiter ()
w) forall a b. (a -> b) -> a -> b
$ HandlesOf procs -> IO Application
mkApp HandlesOf procs
oh
()
_ <- forall a r. ((a -> r) -> r) -> Cont r a
cont forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (forall a. PortWaiter a -> Port -> IO a
waitFor PortWaiter ()
w Port
p) forall b. b -> IO ()
doNothing
forall (m :: * -> *) a. Monad m => a -> m a
return (HandlesOf procs
oh, Port
p)
checkHealth :: Int -> IO (Either a b) -> IO ()
checkHealth :: forall a b. Port -> IO (Either a b) -> IO ()
checkHealth Port
tries IO (Either a b)
h = forall {t}. (Eq t, Num t) => t -> IO ()
go Port
tries
where
go :: t -> IO ()
go t
0 = forall a. HasCallStack => [Char] -> a
error [Char]
"healthy: server isn't healthy"
go t
n =
IO (Either a b)
h forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left a
_ -> Port -> IO ()
threadDelay Port
pingPeriod forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> t -> IO ()
go (t
n forall a. Num a => a -> a -> a
- t
1)
Right b
_ -> 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 (forall a. PortWaiter a -> a -> IO ()
notify PortWaiter ()
w ()) Settings
Warp.defaultSettings
data PortWaiter a = PortWaiter
{ forall a. PortWaiter a -> a -> IO ()
notify :: a -> IO ()
, forall a. PortWaiter a -> Port -> IO a
waitFor :: Warp.Port -> IO a
}
mkWaiter :: (Warp.Port -> IO a) -> IO (PortWaiter a)
mkWaiter :: forall a. (Port -> IO a) -> IO (PortWaiter a)
mkWaiter Port -> IO a
check = do
MVar a
mvar <- forall a. IO (MVar a)
newEmptyMVar
let waitFor :: Port -> IO a
waitFor Port
p = do
a
res <- forall a. MVar a -> IO a
readMVar MVar a
mvar
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Port -> IO a
check Port
p
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
forall (f :: * -> *) a. Applicative f => a -> f a
pure
PortWaiter
{ notify :: a -> IO ()
notify = 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 :: forall a.
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
forall a. ((Port, Socket) -> IO a) -> IO a
withFreePort forall a b. (a -> b) -> a -> b
$ \(Port
p, Socket
sock) -> do
PortWaiter ()
started <- forall a. (Port -> IO a) -> IO (PortWaiter a)
mkWaiter forall b. b -> IO ()
doNothing
let settings' :: Settings
settings' = IO () -> Settings -> Settings
Warp.setBeforeMainLoop (forall a. PortWaiter a -> a -> IO ()
notify PortWaiter ()
started ()) Settings
settings
Either () a
result <-
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)
(forall a. PortWaiter a -> Port -> IO a
waitFor PortWaiter ()
started Port
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Port -> IO a
action Port
p)
case Either () a
result of
Left () -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> ErrorCall
ErrorCall [Char]
"Unexpected: runSettingsSocket exited"
Right a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
withFreePort :: ((Warp.Port, Socket) -> IO a) -> IO a
withFreePort :: forall a. ((Port, Socket) -> IO a) -> IO a
withFreePort = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
doNothing :: b -> IO ()
doNothing :: forall b. b -> IO ()
doNothing = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()