wai-middleware-delegate-0.1.4.0: test/Test/WithExtras.hs

module Test.WithExtras
  ( defaultTlsSettings
  , testWithTLSApplication
  , testWithTLSApplicationSettings
  , withTLSApplication
  , withTLSApplicationSettings
  )
where

import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception
import Control.Monad (when)
import Network.Socket (Socket, close)
import Network.Wai (Application)
import Network.Wai.Handler.Warp
  ( Port
  , Settings
  , defaultSettings
  , defaultShouldDisplayException
  , openFreePort
  )
import Network.Wai.Handler.Warp.Internal (settingsBeforeMainLoop)
import Network.Wai.Handler.WarpTLS
  ( TLSSettings
  , runTLSSocket
  , tlsSettings
  )
import Paths_wai_middleware_delegate (getDataFileName)


-- | The settings used in the integration tests
defaultTlsSettings :: IO TLSSettings
defaultTlsSettings =
  tlsSettings
    <$> (getDataFileName "test/certificate.pem")
    <*> (getDataFileName "test/key.pem")


{- | Runs the given 'Application' on a free port. Passes the port to the given
 operation and executes it, while the 'Application' is running. Shuts down the
 server before returning.
-}
withTLSApplication :: TLSSettings -> IO Application -> (Port -> IO a) -> IO a
withTLSApplication = withTLSApplicationSettings defaultSettings


{- | 'withTLSApplication' with given 'Settings'. This will ignore the port value
 set by 'setPort' in 'Settings'.
-}
withTLSApplicationSettings :: Settings -> TLSSettings -> IO Application -> (Port -> IO a) -> IO a
withTLSApplicationSettings settings' tlsSettings' mkApp action = do
  app <- mkApp
  withFreePort $ \(port, sock) -> do
    started <- mkWaiter
    let settings =
          settings'
            { settingsBeforeMainLoop =
                notify started () >> settingsBeforeMainLoop settings'
            }
    result <-
      race
        (runTLSSocket tlsSettings' settings sock app)
        (waitFor started >> action port)
    case result of
      Left () -> throwIO $ ErrorCall "Unexpected: runSettingsSocket exited"
      Right x -> return x


testWithTLSApplication :: TLSSettings -> IO Application -> (Port -> IO a) -> IO a
testWithTLSApplication = testWithTLSApplicationSettings defaultSettings


testWithTLSApplicationSettings :: Settings -> TLSSettings -> IO Application -> (Port -> IO a) -> IO a
testWithTLSApplicationSettings settings tlsSettings' mkApp action = do
  callingThread <- myThreadId
  app <- mkApp
  let wrappedApp request respond =
        app request respond `catch` \e -> do
          when
            (defaultShouldDisplayException e)
            (throwTo callingThread e)
          throwIO e
  withTLSApplicationSettings settings tlsSettings' (return wrappedApp) action


data Waiter a = Waiter
  { notify :: a -> IO ()
  , waitFor :: IO a
  }


mkWaiter :: IO (Waiter a)
mkWaiter = do
  mvar <- newEmptyMVar
  return
    Waiter
      { notify = putMVar mvar
      , waitFor = readMVar mvar
      }


-- | Like 'openFreePort' but closes the socket before exiting.
withFreePort :: ((Port, Socket) -> IO a) -> IO a
withFreePort = bracket openFreePort (close . snd)