tmp-proc 0.5.3.0 → 0.6.0.0
raw patch · 4 files changed
+75/−48 lines, 4 files
Files
- ChangeLog.md +4/−0
- src/System/TmpProc/Docker.hs +65/−47
- test/Test/HttpBin.hs +5/−0
- tmp-proc.cabal +1/−1
ChangeLog.md view
@@ -2,6 +2,10 @@ `tmp-proc` uses [PVP Versioning][1]. +## 0.6.0.0 -- 2024-01-09++* Removed SomeProcs+ ## 0.5.3.0 -- 2023-08-11 * Add HList constructors `only` and `both` (alias: `&:&`)
src/System/TmpProc/Docker.hs view
@@ -52,13 +52,15 @@ Proc (..) , Pinged (..) , AreProcs- , SomeProcs (..) , nameOf , startup , toPinged , uriOf' , runArgs' + -- * @'ToRunCmd'@+ , ToRunCmd (..)+ -- * @'ProcHandle'@ , ProcHandle (..) , Proc2Handle@@ -110,6 +112,7 @@ import qualified Data.ByteString.Char8 as C8 import Data.Kind (Type) import Data.List (dropWhileEnd)+import Data.Maybe (isJust) import Data.Proxy (Proxy (..)) import Data.Text (Text) import qualified Data.Text as Text@@ -196,11 +199,12 @@ startupAll :: AreProcs procs => HList procs -> IO (HandlesOf procs) startupAll = go procProof where- go :: SomeProcs as -> HList as -> IO (HandlesOf as)- go SomeProcsNil HNil = pure HNil- go (SomeProcsCons cons) (x `HCons` y) = do- h <- startup x- others <- go cons y `onException` terminate h+ go :: Uniquely Proc AreProcs as -> HList as -> IO (HandlesOf as)+ go UniquelyNil HNil = pure HNil+ go (UniquelyCons cons) (x `HCons` y) = do+ others <- go cons y+ h <- startup x `onException` terminateAll others+ -- others <- go cons y `onException` terminate h pure $ h `HCons` others @@ -223,6 +227,23 @@ void $ readProcess "docker" ["rm", pid] "" +{- | Allow customization of the docker command that launches a @'Proc'@+|+| The full command is+| `docker run -d <optional-args> $(imageText a)`+|+| A fallback instance is provided that works for any instance of @Proc a@+| Specify a new instance of @ToRunCmd@ to control <optional-args>+-}+class ToRunCmd a where+ -- * Generate args that follow the initial ['docker', 'run', '-d']+ toRunCmd :: a -> [Text]+++instance {-# OVERLAPPABLE #-} (Proc a) => ToRunCmd a where+ toRunCmd _ = runArgs @a++ -- | Specifies how to a get a connection to a 'Proc'. class Proc a => Connectable a where -- | The connection type.@@ -322,13 +343,8 @@ -- | The full args of a @docker run@ command for starting up a 'Proc'.-dockerCmdArgs :: forall a. (Proc a) => [Text]-dockerCmdArgs =- [ "run"- , "-d"- ]- <> runArgs @a- <> [imageText' @a]+dockerCmdArgs :: forall a. (Proc a, ToRunCmd a) => a -> [Text]+dockerCmdArgs x = ["run", "-d"] <> toRunCmd x <> [imageText' @a] imageText' :: forall a. (Proc a) => Text@@ -350,12 +366,12 @@ Returns the 'ProcHandle' used to control the 'Proc' once a ping has succeeded. -}-startup :: forall a. Proc a => a -> IO (ProcHandle a)+startup :: (Proc a, ToRunCmd a) => a -> IO (ProcHandle a) startup x = do- let fullArgs = dockerCmdArgs @a+ let fullArgs = map Text.unpack $ dockerCmdArgs x isGarbage = flip elem ['\'', '\n'] trim = dropWhileEnd isGarbage . dropWhile isGarbage- runCmd <- dockerRun (map Text.unpack fullArgs)+ runCmd <- dockerRun fullArgs hPid <- trim <$> readCreateProcess runCmd "" hAddr <- Text.pack . trim@@ -367,8 +383,7 @@ , "'{{range .NetworkSettings.Networks}}{{.IPAddress}}{{end}}'" ] ""- let hUri = uriOf @a hAddr- h = ProcHandle {hProc = x, hPid, hUri, hAddr}+ let h = ProcHandle {hProc = x, hPid, hUri = uriOf' x hAddr, hAddr} (nPings h `onException` terminate h) >>= \case OK -> pure h pinged -> do@@ -604,23 +619,24 @@ Handle2KV (ProcHandle t ': ts) = KV (Name t) (ProcHandle t) ': Handle2KV ts --- | Used by @'AreProcs'@ to prove a list of types just contains @'Proc's@.-data SomeProcs (as :: [Type]) where- SomeProcsNil :: SomeProcs '[]- SomeProcsCons :: (Proc a, IsAbsent a as) => SomeProcs as -> SomeProcs (a ': as)-- -- | Declares a proof that a list of types only contains @'Proc's@. class AreProcs as where- procProof :: SomeProcs as+ procProof :: Uniquely Proc AreProcs as instance AreProcs '[] where- procProof = SomeProcsNil+ procProof = UniquelyNil -instance (Proc a, AreProcs as, IsAbsent a as) => AreProcs (a ': as) where- procProof = SomeProcsCons procProof+instance+ ( Proc a+ , ToRunCmd a+ , AreProcs as+ , IsAbsent a as+ ) =>+ AreProcs (a ': as)+ where+ procProof = UniquelyCons procProof -- | Used to prove a list of types just contains @'ProcHandle's@.@@ -629,28 +645,22 @@ SomeHandlesCons :: Proc a => SomeHandles as -> SomeHandles (ProcHandle a ': as) -p2h :: SomeProcs as -> SomeHandles (Proc2Handle as)-p2h SomeProcsNil = SomeHandlesNil-p2h (SomeProcsCons cons) = SomeHandlesCons (p2h cons)----- | Used by @'Connectables'@ to prove a list of types just contains @'Connectable's@.-data SomeConns (as :: [Type]) where- SomeConnsNil :: SomeConns '[]- SomeConnsCons :: (Connectable a, IsAbsent a as) => SomeConns as -> SomeConns (a ': as)+p2h :: Uniquely Proc AreProcs as -> SomeHandles (Proc2Handle as)+p2h UniquelyNil = SomeHandlesNil+p2h (UniquelyCons cons) = SomeHandlesCons (p2h cons) -- | Declares a proof that a list of types only contains @'Connectable's@. class Connectables as where- connProof :: SomeConns as+ connProof :: Uniquely Connectable Connectables as instance Connectables '[] where- connProof = SomeConnsNil+ connProof = UniquelyNil instance (Connectable a, Connectables as, IsAbsent a as) => Connectables (a ': as) where- connProof = SomeConnsCons connProof+ connProof = UniquelyCons connProof -- | Convert list of 'Connectable' types to corresponding 'Conn' types.@@ -663,9 +673,9 @@ openAll :: Connectables xs => HandlesOf xs -> IO (HList (ConnsOf xs)) openAll = go connProof where- go :: SomeConns as -> HandlesOf as -> IO (HList (ConnsOf as))- go SomeConnsNil HNil = pure HNil- go (SomeConnsCons cons) (x `HCons` y) = do+ go :: Uniquely Connectable Connectables as -> HandlesOf as -> IO (HList (ConnsOf as))+ go UniquelyNil HNil = pure HNil+ go (UniquelyCons cons) (x `HCons` y) = do c <- openConn x others <- go cons y `onException` closeConn c pure $ c `HCons` others@@ -675,9 +685,9 @@ closeAll :: Connectables procs => HList (ConnsOf procs) -> IO () closeAll = go connProof where- go :: SomeConns as -> HList (ConnsOf as) -> IO ()- go SomeConnsNil HNil = pure ()- go (SomeConnsCons cons) (x `HCons` y) = closeConn x >> go cons y+ go :: Uniquely Connectable Connectables as -> HList (ConnsOf as) -> IO ()+ go UniquelyNil HNil = pure ()+ go (UniquelyCons cons) (x `HCons` y) = closeConn x >> go cons y -- | Open some connections, use them in an action; close them.@@ -713,6 +723,14 @@ withNamedConns proxy = withConns . manyNamed proxy +{- | Used to support type classes that prove a list of types is constrained to+unique instances of another type class.+-}+data Uniquely f fs (as :: [Type]) where+ UniquelyNil :: Uniquely f fs '[]+ UniquelyCons :: (IsAbsent a as, f a, fs as) => Uniquely f fs as -> Uniquely f fs (a ': as)++ sortHandles :: ( handles ~ Proc2Handle ps , sorted ~ SortHandles handles@@ -770,7 +788,7 @@ showDebug :: IO Bool-showDebug = fmap (maybe False (const True)) $ lookupEnv debugEnv+showDebug = isJust <$> lookupEnv debugEnv debugEnv :: String
test/Test/HttpBin.hs view
@@ -19,6 +19,7 @@ , Proc (..) , ProcHandle (..) , SvcURI+ , ToRunCmd (..) , manyNamed , startupAll , toPinged@@ -43,6 +44,10 @@ runArgs = [] reset _ = pure () ping = ping'+++instance ToRunCmd NginxTest where+ toRunCmd _ = [] -- | A data type representing a connection to a HttpBin server.
tmp-proc.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: tmp-proc-version: 0.5.3.0+version: 0.6.0.0 synopsis: Run 'tmp' processes in integration tests description: @tmp-proc@ runs services in docker containers for use in integration tests.