diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/src/System/TmpProc/TypeLevel/Sort.hs b/src/System/TmpProc/TypeLevel/Sort.hs --- a/src/System/TmpProc/TypeLevel/Sort.hs +++ b/src/System/TmpProc/TypeLevel/Sort.hs @@ -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 @@ -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) diff --git a/test/Test/HttpBin.hs b/test/Test/HttpBin.hs --- a/test/Test/HttpBin.hs +++ b/test/Test/HttpBin.hs @@ -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]) diff --git a/test/Test/SimpleServer.hs b/test/Test/SimpleServer.hs --- a/test/Test/SimpleServer.hs +++ b/test/Test/SimpleServer.hs @@ -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 diff --git a/test/Test/System/TmpProc/WarpSpec.hs b/test/Test/System/TmpProc/WarpSpec.hs --- a/test/Test/System/TmpProc/WarpSpec.hs +++ b/test/Test/System/TmpProc/WarpSpec.hs @@ -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" diff --git a/tmp-proc.cabal b/tmp-proc.cabal --- a/tmp-proc.cabal +++ b/tmp-proc.cabal @@ -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: