packages feed

tmp-proc 0.5.1.4 → 0.5.2.0

raw patch · 6 files changed

+266/−252 lines, 6 filesdep ~warp-tls

Dependency ranges changed: warp-tls

Files

ChangeLog.md view
@@ -2,6 +2,12 @@  `tmp-proc` uses [PVP Versioning][1]. +## 0.5.2.0 -- 2023-07-12++* Bump minimum required version of warp-tls+* Refactor/Disable tests to avoid direct/indirect dependencies on+  Network.Connection+ ## 0.5.1.4 -- 2023-07-12  * Extend the version bounds of bytestring to allow 0.12
src/System/TmpProc/TypeLevel/Sort.hs view
@@ -1,18 +1,18 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoStarIsType          #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoStarIsType #-} {-# OPTIONS_HADDOCK prune not-home #-} -{-|+{- | Copyright   : (c) 2020-2021 Tim Emiola SPDX-License-Identifier: BSD3 Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>@@ -26,144 +26,149 @@  This is an internal module that provides type-level functions used in various constraints in "System.TmpProc.Docker".- -}-module System.TmpProc.TypeLevel.Sort-  ( -- * Merge sort for @Symbols@.-    SortSymbols+module System.TmpProc.TypeLevel.Sort (+  -- * Merge sort for @Symbols@.+  SortSymbols, -     -- * Sort combinators-   , Take-   , Drop-   , LengthOf-   , HalfOf-  )-where+  -- * Sort combinators+  Take,+  Drop,+  LengthOf,+  HalfOf,+) where -import           GHC.TypeLits (CmpNat, CmpSymbol, Nat, Symbol, type (*),-                               type (+), type (-))+import GHC.TypeLits (+  CmpNat,+  CmpSymbol,+  Nat,+  Symbol,+  type (*),+  type (+),+  type (-),+ )  --- $setup--- >>> import Data.Proxy--- >>> :set -XDataKinds--- >>> :set -XTypeFamilies+{- $setup+>>> import Data.Proxy+>>> :set -XDataKinds+>>> :set -XTypeFamilies+-}  -{-| Takes 1 element at a time from a list until the desired length is reached.+{- | Takes 1 element at a time from a list until the desired length is reached.  ==== __Examples__ ->>> :kind! Take '[1, 2, 3, 4] 2-Take '[1, 2, 3, 4] 2 :: [Nat]-= '[1, 2]-+>>> :kind! Take '["a", "b", "c", "d"] 2+Take '["a", "b", "c", "d"] 2 :: [Symbol]+= '["a", "b"] -} type family Take (xs :: [k]) (n :: Nat) :: [k] where-    Take '[] n = '[]-    Take xs 0 = '[]-    Take (x ': xs) n = (x ': Take xs (n - 1))+  Take '[] n = '[]+  Take xs 0 = '[]+  Take (x ': xs) n = (x ': Take xs (n - 1))  -{-| Drops 1 element at a time until the the dropped target is reached.+{- | Drops 1 element at a time until the the dropped target is reached.  ==== __Examples__ ->>> :kind! Drop '[1, 2, 3, 4] 2-Drop '[1, 2, 3, 4] 2 :: [Nat]-= '[3, 4]+>>> :kind! Drop '["a", "b", "c", "d"] 2+Drop '["a", "b", "c", "d"] 2 :: [Symbol]+= '["c", "d"]  ->>> :kind! Drop '[1] 2-Drop '[1] 2 :: [Nat]+>>> :kind! Drop '["a"] 2+Drop '["a"] 2 :: [Symbol] = '[]- -} type family Drop (xs :: [k]) (n :: Nat) :: [k] where-    Drop '[] n = '[]-    Drop xs 0 = xs-    Drop (x ': xs) n = Drop xs (n - 1)+  Drop '[] n = '[]+  Drop xs 0 = xs+  Drop (x ': xs) n = Drop xs (n - 1)  -{-| Counts a list, 1 element at a time.+{- | Counts a list, 1 element at a time.  ==== __Examples__ ->>> :kind! LengthOf '[1, 2, 3, 4]-LengthOf '[1, 2, 3, 4] :: Nat-= 4-+>>> :kind! CmpNat 4 (LengthOf '[1, 2, 3, 4])+CmpNat 4 (LengthOf '[1, 2, 3, 4]) :: Ordering+= 'EQ -} type family LengthOf (xs :: [k]) :: Nat where-    LengthOf '[] = 0-    LengthOf (x ': xs) = 1 + LengthOf xs+  LengthOf '[] = 0+  LengthOf (x ': xs) = 1 + LengthOf xs  -{-| Computes the midpoint of a number.+{- | Computes the midpoint of a number.  N.B: maximum value that this works for depends on the reduction limit of the type-checker.  ==== __Examples__ ->>> :kind! HalfOf 99-HalfOf 99 :: Nat-= 49-->>> :kind! HalfOf 100-HalfOf 100 :: Nat-= 50+>>> :kind! CmpNat 49 (HalfOf 99)+CmpNat 49 (HalfOf 99) :: Ordering+= 'EQ +>>> :kind! CmpNat 50 (HalfOf 100)+CmpNat 50 (HalfOf 100) :: Ordering+= 'EQ -} type family HalfOf (n :: Nat) :: Nat where-    -- optimizations for faster compilation-    HalfOf 0 = 0-    HalfOf 1 = 1-    HalfOf 2 = 1-    HalfOf 3 = 1-    HalfOf 4 = 2-    HalfOf 5 = 2-    HalfOf 6 = 3-    HalfOf 7 = 3-    -- the general case-    HalfOf n = HalfOfImpl n 0 n 'LT+  -- optimizations for faster compilation+  HalfOf 0 = 0+  HalfOf 1 = 1+  HalfOf 2 = 1+  HalfOf 3 = 1+  HalfOf 4 = 2+  HalfOf 5 = 2+  HalfOf 6 = 3+  HalfOf 7 = 3+  -- the general case+  HalfOf n = HalfOfImpl n 0 n 'LT -{-| Implements 'HalfOf'. -}++-- | Implements 'HalfOf'. type family HalfOfImpl (n :: Nat) (i :: Nat) (dist :: Nat) (o :: Ordering) :: Nat where-    HalfOfImpl n m dist 'GT = m - 1-    HalfOfImpl n m dist 'EQ = m-    HalfOfImpl n m 1 'LT = m-    HalfOfImpl n m dist 'LT = HalfOfImpl n (m + 2) (n - ((m + 2) * 2)) (CmpNat ((m + 2) * 2) n)+  HalfOfImpl n m dist 'GT = m - 1+  HalfOfImpl n m dist 'EQ = m+  HalfOfImpl n m 1 'LT = m+  HalfOfImpl n m dist 'LT = HalfOfImpl n (m + 2) (n - ((m + 2) * 2)) (CmpNat ((m + 2) * 2) n)  -{-| Sort a list of type-level @symbols@ using merge sort.+{- | Sort a list of type-level @symbols@ using merge sort.  ==== __Examples__  >>> :kind! SortSymbols '["xyz", "def", "abc"] SortSymbols '["xyz", "def", "abc"] :: [Symbol] = '["abc", "def", "xyz"]- -} type family SortSymbols (xs :: [Symbol]) :: [Symbol] where-    SortSymbols '[]     = '[]-    SortSymbols '[x]    = '[x]-    SortSymbols '[x, y] = MergeSymbols '[x] '[y] -- an optimization, could be removed-    SortSymbols xs      = SortSymbolsStep xs (HalfOf (LengthOf xs))+  SortSymbols '[] = '[]+  SortSymbols '[x] = '[x]+  SortSymbols '[x, y] = MergeSymbols '[x] '[y] -- an optimization, could be removed+  SortSymbols xs = SortSymbolsStep xs (HalfOf (LengthOf xs))  -{-| Used internally by @SortSymbols. -}+-- | Used internally by @SortSymbols. type family SortSymbolsStep (xs :: [Symbol]) (halfLen :: Nat) :: [Symbol] where-    SortSymbolsStep xs halfLen = MergeSymbols+  SortSymbolsStep xs halfLen =+    MergeSymbols       (SortSymbols (Take xs halfLen))       (SortSymbols (Drop xs halfLen)) -{-| Used internally by @SortSymbols. -}++-- | Used internally by @SortSymbols. type family MergeSymbols (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where-    MergeSymbols xs '[]              = xs-    MergeSymbols '[] ys              = ys-    MergeSymbols (x ': xs) (y ': ys) = MergeSymbolsImpl (x ': xs) (y ': ys) (CmpSymbol x y)+  MergeSymbols xs '[] = xs+  MergeSymbols '[] ys = ys+  MergeSymbols (x ': xs) (y ': ys) = MergeSymbolsImpl (x ': xs) (y ': ys) (CmpSymbol x y) + type family MergeSymbolsImpl (xs :: [Symbol]) (ys :: [Symbol]) (o :: Ordering) :: [Symbol] where-    MergeSymbolsImpl (x ': xs) (y ': ys) 'GT = y ': MergeSymbols (x ': xs) ys-    MergeSymbolsImpl (x ': xs) (y ': ys) leq = x ': MergeSymbols xs (y ': ys)+  MergeSymbolsImpl (x ': xs) (y ': ys) 'GT = y ': MergeSymbols (x ': xs) ys+  MergeSymbolsImpl (x ': xs) (y ': ys) leq = x ': MergeSymbols xs (y ': ys)
test/Test/HttpBin.hs view
@@ -1,120 +1,129 @@-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+ module Test.HttpBin where  import qualified Data.ByteString.Char8 as C8-import           Data.List             (foldl')-import           Data.Proxy            (Proxy (..))-import           Data.Text             (Text)-import qualified Data.Text             as Text-import           Network.HTTP.Req--import           System.TmpProc        (HList (..), HandlesOf, HostIpAddress,-                                        Pinged (..), Proc (..), ProcHandle (..),-                                        SvcURI, manyNamed, startupAll, toPinged,-                                        (&:))+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Network.HTTP.Client as HC+import Network.HTTP.Types.Status (statusCode)+import System.TmpProc (+  HList (..),+  HandlesOf,+  HostIpAddress,+  Pinged (..),+  Proc (..),+  ProcHandle (..),+  SvcURI,+  manyNamed,+  startupAll,+  toPinged,+  (&:),+ )   setupHandles :: IO (HandlesOf '[HttpBinTest, HttpBinTest2, HttpBinTest3]) setupHandles = startupAll $ HttpBinTest &: HttpBinTest2 &: HttpBinTest3 &: HNil  -{-| A data type representing a connection to a HttpBin server. -}+-- | A data type representing a connection to a HttpBin server. data HttpBinTest = HttpBinTest -{-| Run HttpBin as temporary process.  -}++-- | Run HttpBin as temporary process. instance Proc HttpBinTest where   type Image HttpBinTest = "kennethreitz/httpbin"   type Name HttpBinTest = "http-bin-test" +   uriOf = mkUri'   runArgs = []   reset _ = pure ()   ping = ping'  -{-| Another data type representing a connection to a HttpBin server.+{- | Another data type representing a connection to a HttpBin server.  Used in this module to allow mulitple types in test lists, to improve the chances of detecting type-related compilationr errors.- -} data HttpBinTest2 = HttpBinTest2 -{-| Run HttpBin as temporary process.  -}++-- | Run HttpBin as temporary process. instance Proc HttpBinTest2 where   type Image HttpBinTest2 = "kennethreitz/httpbin"   type Name HttpBinTest2 = "http-bin-test-2" +   uriOf = mkUri'   runArgs = []   reset _ = pure ()   ping = ping'  -{-| Yet another data type representing a connection to a HttpBin server.+{- | Yet another data type representing a connection to a HttpBin server.  Used in this module to allow mulitple types in test lists, to improve the chances of detecting type-related compilationr errors.- -} data HttpBinTest3 = HttpBinTest3 -{-| Run HttpBin as temporary process.  -}++-- | Run HttpBin as temporary process. instance Proc HttpBinTest3 where   type Image HttpBinTest3 = "kennethreitz/httpbin"   type Name HttpBinTest3 = "http-bin-test-3" +   uriOf = mkUri'   runArgs = []   reset _ = pure ()   ping = ping'  -{-| Make a uri access the http-bin server. -}+-- | Make a uri access the http-bin server. mkUri' :: HostIpAddress -> SvcURI mkUri' ip = "http://" <> C8.pack (Text.unpack ip) <> "/"   ping' :: ProcHandle a -> IO Pinged-ping' handle = toPinged @HttpException Proxy $ do+ping' handle = toPinged @HC.HttpException Proxy $ do   gotStatus <- handleGet handle "/status/200"-  if (gotStatus == 200) then pure OK else pure NotOK+  if gotStatus == 200 then pure OK else pure NotOK   -- | Determine the status from a Get on localhost. handleGet :: ProcHandle a -> Text -> IO Int-handleGet handle urlPath = runReq defaultHttpConfig $ do-  r <- req GET (handleUrl handle urlPath) NoReqBody ignoreResponse $ mempty-  return $ responseStatusCode r---handleUrl :: ProcHandle a -> Text -> Url 'Http-handleUrl handle urlPath = foldl' (/:) (http $ hAddr handle)-  $ Text.splitOn "/" $ Text.dropWhile (== '/') urlPath+handleGet handle urlPath = do+  let theUri = "http://" <> hAddr handle <> "/" <> Text.dropWhile (== '/') urlPath+  manager <- HC.newManager HC.defaultManagerSettings+  getReq <- HC.parseRequest $ Text.unpack theUri+  statusCode . HC.responseStatus <$> HC.httpLbs getReq manager  -{-| Verify that the compile time type computations related to 'manyNamed' are ok. -}+-- | Verify that the compile time type computations related to 'manyNamed' are ok. typeLevelCheck1 :: IO (HandlesOf '[HttpBinTest3]) typeLevelCheck1 = do   allHandles <- setupHandles-  pure $ manyNamed @'["http-bin-test-3"] Proxy  allHandles+  pure $ manyNamed @'["http-bin-test-3"] Proxy allHandles   typeLevelCheck2 :: IO (HandlesOf '[HttpBinTest, HttpBinTest3]) typeLevelCheck2 = do   allHandles <- setupHandles-  pure $ manyNamed @'["http-bin-test", "http-bin-test-3"] Proxy  allHandles+  pure $ manyNamed @'["http-bin-test", "http-bin-test-3"] Proxy allHandles   typeLevelCheck3 :: IO (HandlesOf '[HttpBinTest3, HttpBinTest]) typeLevelCheck3 = do   allHandles <- setupHandles-  pure $ manyNamed @'["http-bin-test-3", "http-bin-test"] Proxy  allHandles+  pure $ manyNamed @'["http-bin-test-3", "http-bin-test"] Proxy allHandles   typeLevelCheck4 :: IO (HandlesOf '[HttpBinTest2, HttpBinTest3, HttpBinTest])
test/Test/SimpleServer.hs view
@@ -1,63 +1,45 @@-{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-}-module Test.SimpleServer-  ( -- * functions-    statusOfGet-  , statusOfGet' -    -- * test constants-  , defaultTLSSettings-  )-where--import           Data.List                   (foldl')--import           Data.Text                   (Text)-import qualified Data.Text                   as Text--import qualified Network.Connection          as HC-import qualified Network.HTTP.Client         as HC-import           Network.HTTP.Client.TLS     (mkManagerSettings)-import           Network.HTTP.Req-import qualified Network.Wai.Handler.Warp    as Warp-import qualified Network.Wai.Handler.WarpTLS as Warp+module Test.SimpleServer (+  -- * functions+  statusOfGet,+) where -import           Paths_tmp_proc              (getDataFileName)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Network.HTTP.Client as HC+import Network.HTTP.Types.Status (statusCode)+import qualified Network.Wai.Handler.Warp as Warp  --- | The settings used in the integration tests-defaultTLSSettings :: IO Warp.TLSSettings-defaultTLSSettings =-  Warp.tlsSettings- <$> (getDataFileName "test_certs/certificate.pem")- <*> (getDataFileName "test_certs/key.pem")-+-- -- | The settings used in the integration tests+-- defaultTLSSettings :: IO Warp.TLSSettings+-- defaultTLSSettings =+--   Warp.tlsSettings+--  <$> (getDataFileName "test_certs/certificate.pem")+--  <*> (getDataFileName "test_certs/key.pem")  -- | Determine the status from a Get on localhost. statusOfGet :: Warp.Port -> Text -> IO Int-statusOfGet p path = runReq defaultHttpConfig $ do-  r <- req GET (localUrl path) NoReqBody ignoreResponse $ port p-  return $ responseStatusCode r---statusOfGet' :: Int -> Text -> IO Int-statusOfGet' p path = do-  manager <- mkSimpleTLSManager-  runReq (defaultHttpConfig { httpConfigAltManager = Just manager }) $ do-    r <- req GET (localHttpsUrl path) NoReqBody ignoreResponse $ port p-    return $ responseStatusCode r---localUrl :: Text -> Url 'Http-localUrl p = foldl' (/:) (http "localhost")-  $ Text.splitOn "/" $ Text.dropWhile (== '/') p-+statusOfGet p urlPath = do+  let theUri = "GET http://localhost/" <> Text.dropWhile (== '/') urlPath+  manager <- HC.newManager HC.defaultManagerSettings+  getReq <- HC.parseRequest $ Text.unpack theUri+  let theReq = getReq {HC.port = p}+  statusCode . HC.responseStatus <$> HC.httpLbs theReq manager -localHttpsUrl :: Text -> Url 'Https-localHttpsUrl p = foldl' (/:) (https "localhost")-  $ Text.splitOn "/" $ Text.dropWhile (== '/') p+-- statusOfGet' :: Int -> Text -> IO Int+-- statusOfGet' p path = do+--   manager <- mkSimpleTLSManager+--   runReq (defaultHttpConfig { httpConfigAltManager = Just manager }) $ do+--     r <- req GET (localHttpsUrl path) NoReqBody ignoreResponse $ port p+--     return $ responseStatusCode r +-- localHttpsUrl :: Text -> Url 'Https+-- localHttpsUrl p = foldl' (/:) (https "localhost")+--   $ Text.splitOn "/" $ Text.dropWhile (== '/') p -mkSimpleTLSManager :: IO HC.Manager-mkSimpleTLSManager = HC.newManager-  $ mkManagerSettings (HC.TLSSettingsSimple True False False) Nothing+-- mkSimpleTLSManager :: IO HC.Manager+-- mkSimpleTLSManager = HC.newManager+--   $ mkManagerSettings (HC.TLSSettingsSimple True False False) Nothing
test/Test/System/TmpProc/WarpSpec.hs view
@@ -1,32 +1,42 @@-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeFamilies        #-}-module Test.System.TmpProc.WarpSpec where--import           Test.Hspec+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} -import           Control.Exception     (catch)-import           Data.Proxy            (Proxy (..))-import           Data.Text             (Text)-import           Network.HTTP.Req-import           Network.HTTP.Types    (status200, status400)-import           Network.Wai           (Application, pathInfo, responseLBS)+module Test.System.TmpProc.WarpSpec where -import           System.TmpProc.Docker (HList (..), HandlesOf, Pinged (..),-                                        ProcHandle, handleOf, ixPing)-import           System.TmpProc.Warp   (ServerHandle, handles, runServer,-                                        runTLSServer, serverPort, shutdown,-                                        testWithApplication,-                                        testWithTLSApplication)-import           Test.Hspec.TmpProc    (tdescribe)-import           Test.HttpBin-import           Test.SimpleServer     (defaultTLSSettings, statusOfGet,-                                        statusOfGet')+import Control.Exception (catch)+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import qualified Network.HTTP.Client as HC+import Network.HTTP.Types (status200, status400)+import Network.Wai (Application, pathInfo, responseLBS)+import System.TmpProc.Docker (+  HList (..),+  HandlesOf,+  Pinged (..),+  ProcHandle,+  handleOf,+  ixPing,+ )+import System.TmpProc.Warp (+  ServerHandle,+  handles,+  runServer,+  runTLSServer,+  serverPort,+  shutdown,+  testWithApplication,+  testWithTLSApplication,+ )+import Test.Hspec+import Test.Hspec.TmpProc (tdescribe)+import Test.HttpBin+import Test.SimpleServer (statusOfGet)   spec :: Spec@@ -39,20 +49,20 @@   testApp :: HandlesOf '[HttpBinTest] -> IO Application-testApp hs = mkTestApp'-  (pingOrFail $ handleOf @"http-bin-test" Proxy hs)-  (pingOrFail $ handleOf @"http-bin-test" Proxy hs)+testApp hs =+  mkTestApp'+    (pingOrFail $ handleOf @"http-bin-test" Proxy hs)+    (pingOrFail $ handleOf @"http-bin-test" Proxy hs)   setupBeforeAll :: IO (ServerHandle '[HttpBinTest]) setupBeforeAll = runServer testProcs testApp  -setupBeforeAllTls :: IO (ServerHandle '[HttpBinTest])-setupBeforeAllTls = do-  tls <- defaultTLSSettings-  runTLSServer tls testProcs testApp-+-- setupBeforeAllTls :: IO (ServerHandle '[HttpBinTest])+-- setupBeforeAllTls = do+--   tls <- defaultTLSSettings+--   runTLSServer tls testProcs testApp  suffixAround, suffixBeforeAll, prefixHttp, prefixHttps :: String suffixAround = " when the server is restarted for each test"@@ -64,16 +74,17 @@ beforeAllSpec :: Spec beforeAllSpec = do   checkBeforeAll prefixHttp setupBeforeAll statusOfGet-  checkBeforeAll prefixHttps setupBeforeAllTls statusOfGet'  -checkBeforeAll-  :: String-  -> IO (ServerHandle '[HttpBinTest])-  -> (Int -> Text -> IO Int) -> Spec-checkBeforeAll descPrefix setup getter =  beforeAll setup $ afterAll shutdown $ do-  describe (descPrefix ++ suffixBeforeAll) $ do+-- checkBeforeAll prefixHttps setupBeforeAllTls statusOfGet' +checkBeforeAll ::+  String ->+  IO (ServerHandle '[HttpBinTest]) ->+  (Int -> Text -> IO Int) ->+  Spec+checkBeforeAll descPrefix setup getter = beforeAll setup $ afterAll shutdown $ do+  describe (descPrefix ++ suffixBeforeAll) $ do     it "should ping the proc handle" $ \sh ->       ixPing @"http-bin-test" Proxy (handles sh) `shouldReturn` OK @@ -85,39 +96,39 @@ setupAround = testWithApplication testProcs testApp  -setupAroundTls :: ((HandlesOf '[HttpBinTest], Int) -> IO a) -> IO a-setupAroundTls cont = do-  tls <- defaultTLSSettings-  testWithTLSApplication tls testProcs testApp cont-+-- setupAroundTls :: ((HandlesOf '[HttpBinTest], Int) -> IO a) -> IO a+-- setupAroundTls cont = do+--   tls <- defaultTLSSettings+--   testWithTLSApplication tls testProcs testApp cont  aroundSpec :: Spec aroundSpec = do   checkEachTest prefixHttp setupAround statusOfGet-  checkEachTest prefixHttps setupAroundTls statusOfGet'  -checkEachTest-  :: String-  -> (ActionWith (HandlesOf '[HttpBinTest], Int) -> IO ())-  -> (Int -> Text -> IO Int)-  -> Spec+-- checkEachTest prefixHttps setupAroundTls statusOfGet'++checkEachTest ::+  String ->+  (ActionWith (HandlesOf '[HttpBinTest], Int) -> IO ()) ->+  (Int -> Text -> IO Int) ->+  Spec checkEachTest descPrefix setup getter = around setup $ do   describe (descPrefix ++ suffixAround) $ do-     it "should ping the proc handle" $ \(h, _) ->-        ixPing @"http-bin-test" Proxy h `shouldReturn` OK+      ixPing @"http-bin-test" Proxy h `shouldReturn` OK      it "should invoke the warp server via its port" $ \(_, p) ->-        getter p "test" `shouldReturn` 200+      getter p "test" `shouldReturn` 200  --- | A WAI app that triggers an action on a TmpProc dependency on /test, and--- responds to health checks on /health.-mkTestApp'-  :: IO ()-  -> IO ()-  -> IO Application+{- | A WAI app that triggers an action on a TmpProc dependency on /test, and+responds to health checks on /health.+-}+mkTestApp' ::+  IO () ->+  IO () ->+  IO Application mkTestApp' onStart onTest = onStart >> pure app   where     app rq respond@@ -133,9 +144,13 @@  pingOrFail :: ProcHandle a -> IO () pingOrFail handle = do-  let catchHttp x = x `catch` (\(_ :: HttpException) ->-                                  fail "tmp proc:httpbin:ping failed")+  let catchHttp x =+        x+          `catch` ( \(_ :: HC.HttpException) ->+                      fail "tmp proc:httpbin:ping failed"+                  )   catchHttp $ do     gotStatus <- handleGet handle "/status/200"-    if (gotStatus == 200) then pure () else-      fail "tmp proc:httpbin:incorrect ping status"+    if (gotStatus == 200)+      then pure ()+      else fail "tmp proc:httpbin:incorrect ping status"
tmp-proc.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               tmp-proc-version:            0.5.1.4+version:            0.5.2.0 synopsis:           Run 'tmp' processes in integration tests description:   @tmp-proc@ runs services in docker containers for use in integration tests.@@ -64,7 +64,7 @@     , unliftio    ^>=0.2.7     , wai         >=3.2      && <3.3     , warp        >=3.3      && <3.5-    , warp-tls    >=3.3      && <3.5+    , warp-tls    >=3.4      && <3.5    default-language: Haskell2010   ghc-options:      -fno-ignore-asserts -Wall@@ -87,18 +87,15 @@   build-depends:     , base     , bytestring-    , connection     , data-default     , hspec     , http-client-    , http-client-tls     , http-types     , req     , text     , tmp-proc     , wai     , warp-    , warp-tls    default-language: Haskell2010   ghc-options: