diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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:` + 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 diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -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]: -[hackage-deps]: [hackage-badge]: [hackage]: +[stackage-lts]: +[stackage-lts-badge]: [stackage-nightly-badge]: [stackage-nightly]: + diff --git a/doctest/Main.hs b/doctest/Main.hs deleted file mode 100644 --- a/doctest/Main.hs +++ /dev/null @@ -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" - ] diff --git a/src/System/TmpProc/Docker.hs b/src/System/TmpProc/Docker.hs --- a/src/System/TmpProc/Docker.hs +++ b/src/System/TmpProc/Docker.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" #-} diff --git a/src/System/TmpProc/TypeLevel.hs b/src/System/TmpProc/TypeLevel.hs --- a/src/System/TmpProc/TypeLevel.hs +++ b/src/System/TmpProc/TypeLevel.hs @@ -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 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 @@ -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 '[] = '[] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/test/Test/HttpBin.hs b/test/Test/HttpBin.hs --- a/test/Test/HttpBin.hs +++ b/test/Test/HttpBin.hs @@ -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 diff --git a/test/Test/NginxGateway.hs b/test/Test/NginxGateway.hs --- a/test/Test/NginxGateway.hs +++ b/test/Test/NginxGateway.hs @@ -10,6 +10,8 @@ Copyright : (c) 2022 Tim Emiola Maintainer : Tim Emiola 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:. 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 diff --git a/test/Test/System/TmpProc/DockerSpec.hs b/test/Test/System/TmpProc/DockerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/TmpProc/DockerSpec.hs @@ -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:@ 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 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.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