tmp-proc 0.7.2.7 → 0.8.0.0

raw patch · 11 files changed

+389/−193 lines, 11 filesdep −doctestdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies removed: doctest

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog.md +17/−0
• README.lhs +4/−2
• doctest/Main.hs +0/−7
• src/System/TmpProc/Docker.hs +149/−46
• src/System/TmpProc/TypeLevel.hs +13/−34
• src/System/TmpProc/TypeLevel/Sort.hs +25/−59
• test/Spec.hs +4/−2
• test/Test/HttpBin.hs +27/−5
• test/Test/NginxGateway.hs +17/−15
• test/Test/System/TmpProc/DockerSpec.hs +130/−0
• tmp-proc.cabal +3/−23

@@ -2,6 +2,23 @@  `tmp-proc` uses [PVP Versioning][1]. +## 0.8.0.0 -- 2026-10-18++* Add rootless docker support: `Proc` gains `containerPort`, `uriOfRootless`,+  and `uriOfRootlessWith` with defaults; `startupAll` detects rootless mode and+  publishes ports via `-p`/`-P`; `hUri` returns the correct `127.0.0.1:<port>`+  URI in rootless mode without any change to `MkProcHandle` or `hAddr`++* Add `isRootless :: IO Bool` to detect rootless docker mode++* Fix exception handling during startup: re-throw async exceptions (e.g. Ctrl+C)+  from `ping`, protect the container-start window in `startup'`, and clean up the+  docker network on early failure in `startupAll`++* Add `addrHost` and `addrPort` helpers for constructing service URIs++* Remove doctests+ ## 0.7.2.7 -- 2026-04-20  * Relax the upper version bounds of tls

@@ -2,8 +2,8 @@  [![GitHub CI](https://github.com/adetokunbo/tmp-proc/actions/workflows/cabal.yml/badge.svg)](https://github.com/adetokunbo/tmp-proc/actions) [![Stackage Nightly][stackage-nightly-badge]][stackage-nightly]+[![Stackage LTS][stackage-lts-badge]][stackage-lts] [![Hackage][hackage-badge]][hackage]-[![Hackage Dependencies][hackage-deps-badge]][hackage-deps] [![BSD-3.0 license](https://img.shields.io/badge/license-BSD--3.0-blue.svg)](https://github.com/adetokunbo/tmp-proc/blob/master/tmp-proc/LICENSE)  `tmp-proc` is a small library designed to simplify integration tests that use@@ -222,8 +222,10 @@ [18]: https://hackage.haskell.org/package/tmp-proc-0.5.0.1/docs/System-TmpProc-Docker.html#v:ping  [hackage-deps-badge]:     <https://img.shields.io/hackage-deps/v/tmp-proc.svg>-[hackage-deps]:           <http://packdeps.haskellers.com/feed?needle=tmp-proc> [hackage-badge]:          <https://img.shields.io/hackage/v/tmp-proc.svg> [hackage]:                <https://hackage.haskell.org/package/tmp-proc>+[stackage-lts]:           <http://stackage.org/lts/package/tmp-proc>+[stackage-lts-badge]:     <http://stackage.org/package/tmp-proc/badge/lts> [stackage-nightly-badge]: <http://stackage.org/package/tmp-proc/badge/nightly> [stackage-nightly]:       <http://stackage.org/nightly/package/tmp-proc>+

@@ -1,7 +0,0 @@--- file doctests.hs-import Test.DocTest--main :: IO ()-main = doctest ["-isrc", "src/System/TmpProc/TypeLevel/Sort.hs",-                "-isrc", "src/System/TmpProc/TypeLevel.hs"-               ]

@@ -81,6 +81,8 @@   , startup   , nameOf   , uriOf'+  , uriOfRootless'+  , uriOfRootlessWith'   , runArgs'   , Pinged (..)   , toPinged@@ -131,11 +133,14 @@      -- * Docker status   , hasDocker+  , isRootless   , genNetworkName      -- * Aliases   , HostIpAddress   , SvcURI+  , addrHost+  , addrPort      -- * Re-exports   , module System.TmpProc.TypeLevel@@ -145,16 +150,21 @@ import Control.Concurrent (threadDelay) import Control.Exception   ( Exception+  , Handler (..)+  , IOException+  , SomeAsyncException   , SomeException   , bracket   , catch+  , catches   , onException+  , throwIO   ) import Control.Monad (void, when) import qualified Data.ByteString.Char8 as C8 import Data.Kind (Type)-import Data.List (dropWhileEnd)-import Data.Maybe (fromMaybe, isJust)+import Data.List (dropWhileEnd, isInfixOf)+import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Proxy (Proxy (..)) import Data.Text (Text) import qualified Data.Text as Text@@ -206,8 +216,21 @@   , (&:)   , (&:&)   )+import Text.Read (readMaybe)  +-- | Determine if docker is running in rootless mode.+isRootless :: IO Bool+isRootless =+  ( ("name=rootless" `isInfixOf`)+      <$> readProcess+        "docker"+        ["info", "--format", "{{range .SecurityOptions}}{{println .}}{{end}}"]+        ""+  )+    `catch` (\(_ :: IOException) -> pure False)++ -- | Determine if the docker daemon is accessible. hasDocker :: IO Bool hasDocker = do@@ -299,17 +322,20 @@ -} startupAll :: (AreProcs procs) => HList procs -> IO (HandlesOf procs) startupAll ps = do+  rootless <- isRootless+  when rootless $ printDebug "tmp.proc: rootless docker detected; using host port mappings"   name <- genNetworkName   let     name' = Text.unpack name+    removeNetwork = runDockerProcQuietly (removeNetworkArgs name')     go :: SomeProcs as -> HList as -> IO (HandlesOf as)     go SomeProcsNil HNil = pure HNil     go (SomeProcsCons cons) (x `HCons` y) = do       others <- go cons y-      h <- startup' (Just name) (mapSlim others) x `onException` terminateAll others+      h <- startup' rootless (Just name) (mapSlim others) x `onException` terminateAll others       pure $ h `HCons` others   void $ readProcess "docker" (createNetworkArgs name') ""-  go procProof ps+  go procProof ps `onException` removeNetwork   {-# DEPRECATED netwStartupAll "since v0.7 this is no longer needed and will be removed, use startupAll instead" #-}@@ -343,23 +369,21 @@  -- | Start up processes for each 'Proc' type. startupAll' :: (AreProcs procs) => Maybe Text -> HList procs -> IO (NetworkHandlesOf procs)-startupAll' ntwkMb ps =+startupAll' ntwkMb ps = do+  rootless <- isRootless   let     mayCreateNetwork = case ntwkMb of       Nothing -> pure ()       Just name -> void $ readProcess "docker" (createNetworkArgs $ Text.unpack name) ""     wrap x = (fromMaybe "" ntwkMb, x)-     go :: SomeProcs as -> HList as -> IO (HandlesOf as)     go SomeProcsNil HNil = pure HNil     go (SomeProcsCons cons) (x `HCons` y) = do       others <- go cons y-      h <- startup' ntwkMb (mapSlim others) x `onException` terminateAll others+      h <- startup' rootless ntwkMb (mapSlim others) x `onException` terminateAll others       pure $ h `HCons` others-   in-    do-      mayCreateNetwork-      wrap <$> go procProof ps+  mayCreateNetwork+  wrap <$> go procProof ps   -- | Terminate all processes owned by some @'ProcHandle's@.@@ -404,14 +428,14 @@ terminate :: ProcHandle p -> IO () terminate handle = do   let pid = hPid handle-  void $ readProcess "docker" ["stop", pid] ""-  void $ readProcess "docker" ["rm", pid] ""+  runDockerProcQuietly ["stop", pid]+  runDockerProcQuietly ["rm", pid]   mphTidy handle   {- | Prepare resources for use by a  @'Proc'@ - Preparation occurs before the docker container is a launched; once the+ Preparation occurs before the docker container is launched; once the  resources are set up, they are located using the @prepared@ datatype.   Usually, this means it will be used by 'toRunCmd' to provide additional@@ -431,6 +455,9 @@     -- | Clean up any resources associated with @prepared@+  --+  --   'tidy' is called exactly once per 'prepare' invocation — implementations+  --   do not need to be idempotent.   tidy :: a -> prepared -> IO ()  @@ -497,6 +524,30 @@   uriOf :: HostIpAddress -> SvcURI  +  -- | The port the service listens on inside the container.+  --   When @0@ (default), rootless mode publishes all @EXPOSE@d ports via @-P@.+  --   Set to a specific port to use @-p@ instead, for images with many @EXPOSE@s.+  containerPort :: Word16+  containerPort = 0+++  -- | The URI to use when accessing the service from the host in rootless mode.+  --   Receives the host port for 'containerPort' (or @0@ if no mapping was found).+  --   Defaults to 'uriOf', ignoring the host port; override to incorporate it.+  uriOfRootless :: HostIpAddress -> Word16 -> SvcURI+  uriOfRootless addr _ = uriOf @a addr+++  -- | Like 'uriOfRootless' but receives all published port mappings as+  --   @(containerPort, hostPort)@ pairs. Defaults to delegating to 'uriOfRootless'+  --   using the host port of the first pair. Override for multi-port images.+  uriOfRootlessWith :: HostIpAddress -> [(Word16, Word16)] -> SvcURI+  uriOfRootlessWith addr pairs =+    uriOfRootless @a addr $ case pairs of+      (_, hp) : _ -> hp+      [] -> 0++   -- | Resets some state in a tmp proc service.   reset :: ProcHandle a -> IO () @@ -560,6 +611,26 @@ uriOf' _ = uriOf @a  +-- | Simplifies use of 'uriOfRootless'.+uriOfRootless' :: forall a. (Proc a) => a -> HostIpAddress -> Word16 -> SvcURI+uriOfRootless' _ = uriOfRootless @a+++-- | Simplifies use of 'uriOfRootlessWith'.+uriOfRootlessWith' :: forall a. (Proc a) => a -> HostIpAddress -> [(Word16, Word16)] -> SvcURI+uriOfRootlessWith' _ = uriOfRootlessWith @a+++-- | Encode a 'HostIpAddress' as a 'SvcURI' fragment for embedding in URIs.+addrHost :: HostIpAddress -> SvcURI+addrHost = C8.pack . Text.unpack+++-- | Format an address and port as @host:port@ for embedding in a 'SvcURI'.+addrPort :: HostIpAddress -> Word16 -> SvcURI+addrPort addr port = addrHost addr <> ":" <> C8.pack (show port)++ -- | The full args of a @docker run@ command for starting up a 'Proc'. dockerCmdArgs ::   forall a prepared.@@ -567,13 +638,31 @@   a ->   prepared ->   Maybe Text ->+  Bool ->   [Text]-dockerCmdArgs x prep ntwkMb =+dockerCmdArgs x prep ntwkMb rootless =   let toNetworkArgs n = ["--network", n]       networkArg = maybe mempty toNetworkArgs ntwkMb-   in ["run", "-d"] <> nameArg @a <> networkArg <> toRunCmd x prep <> [imageText' @a]+      portArg+        | not rootless = []+        | containerPort @a /= 0 = ["-p", Text.pack (show (containerPort @a))]+        | otherwise = ["-P"]+   in ["run", "-d"] <> nameArg @a <> networkArg <> portArg <> toRunCmd x prep <> [imageText' @a]  +inspectPortPairs :: String -> IO [(Word16, Word16)]+inspectPortPairs pid = do+  output <- readProcess "docker" ["port", pid] ""+  pure $ mapMaybe parseLine (lines output)+  where+    parseLine line = case words line of+      [portProto, "->", endpoint] ->+        let cPortStr = takeWhile (/= '/') portProto+            hPortStr = reverse $ takeWhile (/= ':') (reverse endpoint)+         in (,) <$> readMaybe cPortStr <*> readMaybe hPortStr+      _ -> Nothing++ imageText' :: forall a. (Proc a) => Text imageText' = Text.pack $ symbolVal $ Proxy @(Image a) @@ -610,42 +699,51 @@  startup' ::   (ProcPlus a prepared) =>+  Bool ->   Maybe Text ->   [SlimHandle] ->   a ->   IO (ProcHandle a)-startup' mphNetwork addrs x = do+startup' rootless mphNetwork addrs x = do   x' <- prepare addrs x-  let fullArgs = map Text.unpack $ dockerCmdArgs x x' mphNetwork+  let fullArgs = map Text.unpack $ dockerCmdArgs x x' mphNetwork rootless       isGarbage = flip elem ['\'', '\n']       trim = dropWhileEnd isGarbage . dropWhile isGarbage   printDebug $ Text.pack $ show fullArgs   runCmd <- createDockerCmdProcess fullArgs   mphPid <- trim <$> readCreateProcess runCmd ""-  mphAddr <--    Text.pack . trim-      <$> readProcess-        "docker"-        [ "inspect"-        , mphPid-        , "--format"-        , "'{{range .NetworkSettings.Networks}}{{.IPAddress}}{{end}}'"-        ]-        ""-  let h =-        MkProcHandle-          { mphProc = x+  let stopByPid = do+        runDockerProcQuietly ["stop", mphPid]+        runDockerProcQuietly ["rm", mphPid]+        tidy x x'+  flip onException stopByPid $ do+    mphAddr <-+      Text.pack . trim+        <$> readProcess+          "docker"+          [ "inspect"           , mphPid-          , mphUri = uriOf' x mphAddr-          , mphAddr-          , mphNetwork-          , mphTidy = tidy x x'-          }-  (nPings h `onException` terminate h) >>= \case-    OK -> pure h-    pinged -> do-      terminate h-      fail $ pingedMsg x pinged+          , "--format"+          , "'{{range .NetworkSettings.Networks}}{{.IPAddress}}{{end}}'"+          ]+          ""+    portPairs <- if rootless then inspectPortPairs mphPid else pure []+    let mphUri =+          if rootless+            then uriOfRootlessWith' x "127.0.0.1" portPairs+            else uriOf' x mphAddr+    let h =+          MkProcHandle+            { mphProc = x+            , mphPid+            , mphUri+            , mphAddr+            , mphNetwork+            , mphTidy = tidy x x'+            }+    nPings h >>= \case+      OK -> pure h+      pinged -> fail $ pingedMsg x pinged   pingedMsg :: (Proc a) => a -> Pinged -> String@@ -686,11 +784,12 @@      ping' x =       ping x-        `catch` ( \(e :: SomeException) -> do-                    let errMsg = Text.pack $ show e-                    badErr errMsg-                    pure $ PingFailed errMsg-                )+        `catches` [ Handler $ \(e :: SomeAsyncException) -> throwIO e+                  , Handler $ \(e :: SomeException) -> do+                      let errMsg = Text.pack $ show e+                      badErr errMsg+                      pure $ PingFailed errMsg+                  ]      go n =       ping' h >>= \case@@ -1075,6 +1174,10 @@ printDebug t = do   canPrint <- showDebug   when canPrint $ Text.hPutStrLn stderr t+++runDockerProcQuietly :: [String] -> IO ()+runDockerProcQuietly args = (`catch` (\(_ :: IOException) -> pure ())) $ void $ readProcess "docker" args ""   {-# DEPRECATED genNetworkName "since v0.7 this is no longer needs to be exported and will be hidden in later releases" #-}

@@ -68,20 +68,13 @@ import System.TmpProc.TypeLevel.Sort  -{- $setup->>> import Data.Proxy->>> :set -XDataKinds->>> :set -XTypeApplications--}-- -- | Obtain the first element of a 'HList'. hHead :: HList (a ': as) -> a hHead (x `HCons` _) = x   -- | Get an item in an 'HList' given its type.-hOf :: forall y xs. IsInProof y xs => Proxy y -> HList xs -> y+hOf :: forall y xs. (IsInProof y xs) => Proxy y -> HList xs -> y hOf proxy = go proxy provedIsIn   where     go :: Proxy x -> IsIn x ys -> HList ys -> x@@ -173,26 +166,21 @@   lookupProof = AtHead @k @t @kvs  -instance MemberKV k t kvs => MemberKV k t (KV ok ot ': kvs) where+instance (MemberKV k t kvs) => MemberKV k t (KV ok ot ': kvs) where   lookupProof = OtherKeys lookupProof   {- | Select an item from an 'HList' of @'KV's@ by /key/. - /N.B/ Returns the first item. It assumes the keys in the KV HList are unique. /TODO:/ enforce this rule using a constraint. --==== __Examples__--->>> select @"d" @Double  @'[KV "b" Bool, KV "d" Double] (V True &:  V (3.1 :: Double) &: HNil)-3.1+For example, @select \@\"d\" \@Double@ on @(V True &: V (3.1 :: Double) &: HNil)@+typed as @HList \'[KV \"b\" Bool, KV \"d\" Double]@ returns @3.1@. -} select ::   forall k t xs.-  MemberKV k t xs =>+  (MemberKV k t xs) =>   HList xs ->   t select = go $ lookupProof @k @t @xs@@ -226,11 +214,11 @@   manyProof = FirstOfMany @k @t @ks  -instance {-# OVERLAPPING #-} ManyMemberKV ks ts kvs => ManyMemberKV (k ': ks) (t ': ts) (KV k t ': kvs) where+instance {-# OVERLAPPING #-} (ManyMemberKV ks ts kvs) => ManyMemberKV (k ': ks) (t ': ts) (KV k t ': kvs) where   manyProof = NextOfMany manyProof  -instance ManyMemberKV ks ts kvs => ManyMemberKV ks ts (KV ok ot ': kvs) where+instance (ManyMemberKV ks ts kvs) => ManyMemberKV ks ts (KV ok ot ': kvs) where   manyProof = ManyOthers manyProof  @@ -241,15 +229,12 @@ The keys must be provided in the same order as they occur in the HList, any other order will likely result in an compiler error. -==== __Examples__--->>> selectMany @'["b"] @'[Bool] @'[KV "b" Bool, KV "d" Double] (V True &:  V (3.1 :: Double) &: HNil)-True &: HNil+For example, @selectMany \@\'[\"b\"] \@\'[Bool]@ on @(V True &: V (3.1 :: Double) &: HNil)@+typed as @HList \'[KV \"b\" Bool, KV \"d\" Double]@ returns @(True &: HNil) :: HList \'[Bool]@. -} selectMany ::   forall ks ts xs.-  ManyMemberKV ks ts xs =>+  (ManyMemberKV ks ts xs) =>   HList xs ->   HList ts selectMany = go $ manyProof @ks @ts @xs@@ -262,14 +247,8 @@  {- | Allows reordering of similar @'HList's@. -==== __Examples__--->>> hReorder @_ @'[Bool, Int] ('c' &: (3 :: Int) &: True &: (3.1 :: Double) &: HNil)-True &: 3 &: HNil-->>> hReorder @_ @'[Double, Bool, Int] ('c' &: (3 :: Int) &: True &: (3.1 :: Double) &: HNil)-3.1 &: True &: 3 &: HNil+For example, @hReorder \@_ \@\'[Bool, Int]@ on @(\'c\' &: (3 :: Int) &: True &: (3.1 :: Double) &: HNil)@+returns @True &: 3 &: HNil@. -} class ReorderH xs ys where   hReorder :: HList xs -> HList ys@@ -298,5 +277,5 @@   provedIsIn = IsHead @t @tys  -instance IsInProof t tys => IsInProof t (a : tys) where+instance (IsInProof t tys) => IsInProof t (a : tys) where   provedIsIn = IsInTail provedIsIn

@@ -27,42 +27,32 @@ 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,--  -- * Sort combinators-  Take,-  Drop,-  LengthOf,-  HalfOf,-) where--import GHC.TypeLits (-  CmpNat,-  CmpSymbol,-  Nat,-  Symbol,-  type (*),-  type (+),-  type (-),- )+module System.TmpProc.TypeLevel.Sort+  ( -- * Merge sort for @Symbols@.+    SortSymbols +    -- * Sort combinators+  , Take+  , Drop+  , LengthOf+  , HalfOf+  )+where -{- $setup->>> import Data.Proxy->>> :set -XDataKinds->>> :set -XTypeFamilies--}+import GHC.TypeLits+  ( CmpNat+  , CmpSymbol+  , Nat+  , Symbol+  , type (*)+  , type (+)+  , type (-)+  )   {- | Takes 1 element at a time from a list until the desired length is reached. -==== __Examples__-->>> :kind! Take '["a", "b", "c", "d"] 2-Take '["a", "b", "c", "d"] 2 :: [Symbol]-= '["a", "b"]+For example, @Take \'[\"a\", \"b\", \"c\", \"d\"] 2@ reduces to @\'[\"a\", \"b\"]@. -} type family Take (xs :: [k]) (n :: Nat) :: [k] where   Take '[] n = '[]@@ -72,16 +62,8 @@  {- | Drops 1 element at a time until the the dropped target is reached. -==== __Examples__-->>> :kind! Drop '["a", "b", "c", "d"] 2-Drop '["a", "b", "c", "d"] 2 :: [Symbol]-= '["c", "d"]--->>> :kind! Drop '["a"] 2-Drop '["a"] 2 :: [Symbol]-= '[]+For example, @Drop \'[\"a\", \"b\", \"c\", \"d\"] 2@ reduces to @\'[\"c\", \"d\"]@,+and @Drop \'[\"a\"] 2@ reduces to @\'[]@. -} type family Drop (xs :: [k]) (n :: Nat) :: [k] where   Drop '[] n = '[]@@ -91,11 +73,7 @@  {- | Counts a list, 1 element at a time. -==== __Examples__-->>> :kind! CmpNat 4 (LengthOf '[1, 2, 3, 4])-CmpNat 4 (LengthOf '[1, 2, 3, 4]) :: Ordering-= 'EQ+For example, @LengthOf \'[1, 2, 3, 4]@ reduces to @4@. -} type family LengthOf (xs :: [k]) :: Nat where   LengthOf '[] = 0@@ -107,15 +85,7 @@ N.B: maximum value that this works for depends on the reduction limit of the type-checker. -==== __Examples__-->>> :kind! CmpNat 49 (HalfOf 99)-CmpNat 49 (HalfOf 99) :: Ordering-= 'EQ-->>> :kind! CmpNat 50 (HalfOf 100)-CmpNat 50 (HalfOf 100) :: Ordering-= 'EQ+For example, @HalfOf 99@ reduces to @49@ and @HalfOf 100@ reduces to @50@. -} type family HalfOf (n :: Nat) :: Nat where   -- optimizations for faster compilation@@ -141,11 +111,7 @@  {- | Sort a list of type-level @symbols@ using merge sort. -==== __Examples__-->>> :kind! SortSymbols '["xyz", "def", "abc"]-SortSymbols '["xyz", "def", "abc"] :: [Symbol]-= '["abc", "def", "xyz"]+For example, @SortSymbols \'[\"xyz\", \"def\", \"abc\"]@ reduces to @\'[\"abc\", \"def\", \"xyz\"]@. -} type family SortSymbols (xs :: [Symbol]) :: [Symbol] where   SortSymbols '[] = '[]

@@ -5,13 +5,15 @@ import           Test.Hspec  import           System.IO-import qualified Test.System.TmpProc.HttpBinSpec as HB-import qualified Test.System.TmpProc.WarpSpec    as W3+import qualified Test.System.TmpProc.DockerSpec   as D+import qualified Test.System.TmpProc.HttpBinSpec  as HB+import qualified Test.System.TmpProc.WarpSpec     as W3  main :: IO () main = do   hSetBuffering stdin NoBuffering   hSetBuffering stdout NoBuffering   hspec $ do+    D.spec     HB.spec     W3.spec

@@ -6,12 +6,21 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{- |+Module      : Test.HttpBin+Copyright   : (c) 2026 Tim Emiola+Maintainer  : adetokunbo@users.noreply.github.com+SPDX-License-Identifier: BSD3++Test helper types and functions for testing with an httpbin container.+-} module Test.HttpBin where  import qualified Data.ByteString.Char8 as C8 import Data.Proxy (Proxy (..)) import Data.Text (Text) import qualified Data.Text as Text+import Data.Word (Word16) import qualified Network.HTTP.Client as HC import Network.HTTP.Types.Status (statusCode) import System.TmpProc@@ -21,6 +30,8 @@   , Proc (..)   , ProcHandle (..)   , SvcURI+  , addrHost+  , addrPort   , manyNamed   , startupAll   , toPinged@@ -55,6 +66,7 @@   runArgs = []   reset _ = pure ()   ping = pingHttp+  uriOfRootlessWith = httpUriRootless   {- | Another data type representing a connection to a HttpBin server.@@ -73,6 +85,7 @@   runArgs = []   reset _ = pure ()   ping = pingHttp+  uriOfRootlessWith = httpUriRootless   {- | Yet another data type representing a connection to a HttpBin server.@@ -91,25 +104,34 @@   runArgs = []   reset _ = pure ()   ping = pingHttp+  uriOfRootlessWith = httpUriRootless  --- | Make a uri access the http-bin server.+-- | Make a uri to access the http-bin server. httpUri :: HostIpAddress -> SvcURI-httpUri ip = "http://" <> C8.pack (Text.unpack ip) <> "/"+httpUri ip = "http://" <> addrHost ip <> "/"  +-- | Make a rootless-aware uri for the http-bin server using the mapped host port for port 80.+httpUriRootless :: HostIpAddress -> [(Word16, Word16)] -> SvcURI+httpUriRootless addr pairs =+  case lookup 80 pairs of+    Just hp -> "http://" <> addrPort addr hp <> "/"+    Nothing -> httpUri addr++ pingHttp :: ProcHandle a -> IO Pinged pingHttp handle = toPinged @HC.HttpException Proxy $ do   gotStatus <- httpGet handle "/status/200"   if gotStatus == 200 then pure OK else pure NotOK  --- | Determine the status from a Get.+-- | Determine the status from a GET request, using the handle's URI as the base. httpGet :: ProcHandle a -> Text -> IO Int httpGet handle urlPath = do-  let theUri = "http://" <> hAddr handle <> "/" <> Text.dropWhile (== '/') urlPath+  let theUri = C8.unpack (hUri handle) <> Text.unpack (Text.dropWhile (== '/') urlPath)   manager <- HC.newManager HC.defaultManagerSettings-  getReq <- HC.parseRequest $ Text.unpack theUri+  getReq <- HC.parseRequest theUri   statusCode . HC.responseStatus <$> HC.httpLbs getReq manager  

@@ -10,6 +10,8 @@ Copyright   : (c) 2022 Tim Emiola Maintainer  : Tim Emiola <adetokunbo@emio.la> SPDX-License-Identifier: BSD3++Test helper types and functions for testing with an nginx reverse-proxy container. -} module Test.NginxGateway   ( -- * data types@@ -32,8 +34,6 @@ import qualified Network.HTTP.Client.TLS as HC import Network.HTTP.Types.Header (hHost) import Network.HTTP.Types.Status (statusCode)-import Network.TLS (ClientParams (..), HostName, Shared (..), Supported (..), defaultParamsClient)-import Network.TLS.Extra (ciphersuite_default) import Paths_tmp_proc (getDataDir) import System.Directory (createDirectory, removeDirectoryRecursive) import System.FilePath ((</>))@@ -49,6 +49,8 @@   , SlimHandle (..)   , SvcURI   , ToRunCmd (..)+  , addrHost+  , addrPort   , toPinged   ) import Test.Certs.Temp (CertPaths (..), defaultConfig, generateAndStore)@@ -67,10 +69,14 @@   -- config   type Image NginxGateway = "lscr.io/linuxserver/nginx"   type Name NginxGateway = "nginx-test"-  uriOf = httpUri+  uriOf = httpsUri   runArgs = []   reset _ = pure ()   ping = pingHttps+  uriOfRootlessWith addr pairs =+    case lookup 443 pairs of+      Just hp -> "https://" <> addrPort addr hp <> "/"+      Nothing -> httpsUri addr   instance ToRunCmd NginxGateway NginxPrep where@@ -200,9 +206,9 @@           pure np  --- | Make a uri access the http-bin server.-httpUri :: HostIpAddress -> SvcURI-httpUri ip = "http://" <> C8.pack (Text.unpack ip) <> "/"+-- | Make a uri to access the nginx gateway server.+httpsUri :: HostIpAddress -> SvcURI+httpsUri ip = "https://" <> addrHost ip <> "/"   pingHttps :: ProcHandle a -> IO Pinged@@ -211,20 +217,16 @@   if gotStatus == 200 then pure OK else pure NotOK  --- | Determine the status from a secure Get to host localhost.+-- | Determine the status from a secure GET, using the handle's URI as the base. httpsGet :: ProcHandle a -> Text -> IO Int httpsGet handle urlPath = do-  -- _tlsSettings <- TLSSettings <$> _mkClientParams "localHost"-  let theUri = "https://" <> hAddr handle <> "/" <> Text.dropWhile (== '/') urlPath-  -- use TLS settings that disable hostname verification. What's not-  -- currently possible is to actually specify the hostname to use for SNI-  -- that differs from the connection IP address, that's not supported by-  -- http-client-tls+  let theUri = C8.unpack (hUri handle) <> Text.unpack (Text.dropWhile (== '/') urlPath)+  -- TLS settings disable hostname verification: the cert is for "localhost"+  -- but the connection address may be a container IP or 127.0.0.1:<port>.   manager <- HC.newTlsManagerWith $ HC.mkManagerSettings noCheckSettings Nothing-  getReq <- HC.parseRequest $ Text.unpack theUri+  getReq <- HC.parseRequest theUri   let withHost = getReq {HC.requestHeaders = [(hHost, "localhost")]}   statusCode . HC.responseStatus <$> HC.httpLbs withHost manager-  -- currently unused, since the server specified in ClientParams for SNI is -- overridden by Connection, which resets it to the connection hostname

@@ -0,0 +1,130 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++{- |+Module      : Test.System.TmpProc.DockerSpec+Copyright   : (c) 2026 Tim Emiola+Maintainer  : adetokunbo@users.noreply.github.com+SPDX-License-Identifier: BSD3++Tests for exception handling during docker proc startup, rootless docker+detection, and rootless startup behaviour.+-}+module Test.System.TmpProc.DockerSpec (spec) where++import Control.Exception (AsyncException (..), SomeAsyncException, throwIO, try)+import qualified Data.ByteString.Char8 as C8+import Data.Proxy (Proxy (..))+import qualified Data.Text as Text+import qualified Network.HTTP.Client as HC+import System.Process (readProcess)+import System.TmpProc.Docker+  ( Pinged (..)+  , Proc (..)+  , ProcHandle (..)+  , hHead+  , isRootless+  , only+  , startup+  , toPinged+  , withTmpProcs+  )+import Test.Hspec+++spec :: Spec+spec = do+  describe "Rootless docker detection" $ do+    it "returns a Bool without throwing in any docker mode" $ do+      _ <- isRootless+      pure ()++  describe "Proc typeclass defaults" $ do+    it "containerPort defaults to 0" $+      containerPort @AlwaysFailPing `shouldBe` 0+    it "uriOfRootless defaults to uriOf ignoring the host port" $+      uriOfRootless @AlwaysFailPing "127.0.0.1" 5432+        `shouldBe` uriOf @AlwaysFailPing "127.0.0.1"+    it "uriOfRootlessWith delegates to uriOfRootless using the first pair's host port" $+      uriOfRootlessWith @AlwaysFailPing "127.0.0.1" [(6379, 49153)]+        `shouldBe` uriOfRootless @AlwaysFailPing "127.0.0.1" 49153+    it "uriOfRootlessWith passes 0 to uriOfRootless when the pairs list is empty" $+      uriOfRootlessWith @AlwaysFailPing "127.0.0.1" []+        `shouldBe` uriOfRootless @AlwaysFailPing "127.0.0.1" 0++  describe "Exception handling during startup" $ do+    it "re-throws UserInterrupt during ping and cleans up the container" $ do+      result <- try @SomeAsyncException (startup InterruptOnPing)+      case result of+        Left _ -> pure ()+        Right _ -> expectationFailure "expected UserInterrupt to be re-thrown"+      out <- readProcess "docker" ["ps", "-a", "--filter", "name=interrupt-on-ping", "--format", "{{.Names}}"] ""+      out `shouldNotContain` "interrupt-on-ping"++    it "cleans up the container when ping always fails" $ do+      startup AlwaysFailPing `shouldThrow` anyIOException+      out <- readProcess "docker" ["ps", "-a", "--filter", "name=always-fail-ping", "--format", "{{.Names}}"] ""+      out `shouldNotContain` "always-fail-ping"++  describe "Rootless docker startup" $ do+    it "hUri is host-accessible and startup succeeds in both normal and rootless mode" $ do+      rootless <- isRootless+      withTmpProcs (only RootlessTest) $ \handles -> do+        let h = hHead handles+        if rootless+          then hUri h `shouldSatisfy` ("http://127.0.0.1:" `C8.isPrefixOf`)+          else hUri h `shouldSatisfy` ("http://" `C8.isPrefixOf`)+++-- | A 'Proc' whose 'ping' always throws 'UserInterrupt'.+data InterruptOnPing = InterruptOnPing+++instance Proc InterruptOnPing where+  type Image InterruptOnPing = "alpine"+  type Name InterruptOnPing = "interrupt-on-ping"+  uriOf _ = ""+  reset _ = pure ()+  ping _ = throwIO UserInterrupt+  pingCount = 1+++-- | A 'Proc' whose 'ping' always returns 'NotOK'.+data AlwaysFailPing = AlwaysFailPing+++instance Proc AlwaysFailPing where+  type Image AlwaysFailPing = "alpine"+  type Name AlwaysFailPing = "always-fail-ping"+  uriOf _ = ""+  reset _ = pure ()+  ping _ = pure NotOK+  pingCount = 1+++{- | A 'Proc' for testing rootless docker support.++Its 'ping' uses 'hUri' rather than 'hAddr', and 'uriOfRootlessWith' builds+a @127.0.0.1:<hostPort>@ URI so that startup succeeds in rootless mode.+-}+data RootlessTest = RootlessTest+++instance Proc RootlessTest where+  type Image RootlessTest = "kennethreitz/httpbin"+  type Name RootlessTest = "rootless-test-proc"+  uriOf ip = "http://" <> C8.pack (Text.unpack ip) <> "/"+  runArgs = []+  reset _ = pure ()+  ping h = toPinged @HC.HttpException Proxy $ do+    manager <- HC.newManager HC.defaultManagerSettings+    req <- HC.parseRequest $ C8.unpack (hUri h) <> "status/200"+    HC.httpNoBody req manager+  uriOfRootlessWith addr pairs =+    case lookup 80 pairs of+      Just hp -> "http://127.0.0.1:" <> C8.pack (show hp) <> "/"+      Nothing -> "http://" <> C8.pack (Text.unpack addr) <> "/"+  pingCount = 6+  pingGap = 2000000

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               tmp-proc-version:            0.7.2.7+version:            0.8.0.0 synopsis:           Run 'tmp' processes in integration tests description:   @tmp-proc@ runs services in docker containers for use in integration tests.@@ -76,6 +76,7 @@     Test.NginxGateway     Test.SimpleServer     Test.System.TmpProc.Hspec+    Test.System.TmpProc.DockerSpec     Test.System.TmpProc.HttpBinSpec     Test.System.TmpProc.WarpSpec     Network.Connection.CPP@@ -97,6 +98,7 @@     , test-certs            >=0.1 && <0.2     , text     , tls+    , process     ^>=1.6.3.0     , tmp-proc     , wai     , warp@@ -106,28 +108,6 @@   default-language: Haskell2010   ghc-options:     -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts -Wall--flag use-doc-tests-  description: Include the doctests in the package tests-  default:     False--test-suite doctests-  if flag(use-doc-tests)-    buildable: True--  else-    buildable: False--  type:             exitcode-stdio-1.0-  main-is:          Main.hs-  build-depends:-    , base-    , doctest   >=0.8-    , tmp-proc--  hs-source-dirs:   doctest-  default-language: Haskell2010-  ghc-options:      -threaded  flag build-the-readme   description: Allow the readme to build