packages feed

tmp-proc 0.6.2.1 → 0.7.0.0

raw patch · 5 files changed

+195/−75 lines, 5 files

Files

ChangeLog.md view
@@ -1,6 +1,17 @@ # Revision history for tmp-proc  `tmp-proc` uses [PVP Versioning][1].+ +## 0.7.0.0 -- 2024-05-12++* Convert ProcHandle constructor into a unidirectional PatternSynonym++* Always run tmp procs in a docker network with a custom generated network name++* Deprecate netwTerminateAll, netwStartupAll, startupAll', genNetworkName,+  NetworkHandlesOf+  +* Add the 'tidy' function to the 'Preparer' typeclass to allow cleanup  ## 0.6.2.1 -- 2024-04-21
src/System/TmpProc/Docker.hs view
@@ -5,10 +5,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -28,7 +28,7 @@  @tmp-proc@ aims to simplify integration tests that use dockerizable services. -* Basically, @tmp-proc@ helps launch services used in integration test on docker+* @tmp-proc@ helps launch services used by integration tests on docker  * While it's possible to write integration tests that use services hosted on   docker /without/ @tmp-proc@, @tmp-proc@ aims to make writing those kind of@@ -38,23 +38,30 @@     * obtaining references to the launched service     * cleaning up docker once the tests are finished -This module does all that via its data types:+It does this via its typeclasses and data types: -* A /'Proc'/ specifies a docker image that provides a service and other details-  related to its use in tests.+* The /'Proc'/ typeclass specifies a docker image that provides a service and+  other details related to its use in tests. -* @'Proc's@ may need additional setup before the docker command runs, this can-  be done using by providing a specific /'Preparer'/ instance for it+    * @'Proc's@ may need additional arguments in the @docker run@ command that+      launches it; this can be done using by providing a specific /'ToRunCmd'/+      instance for it -* @'Proc's@ may need additional arguments in the docker command that launches-  it; this can be done using by providing a specific /'ToRunCmd'/ instance for-  it+* A /'ProcHandle'/ type is created whenever a service specifed by a /'Proc'/ is+launched, and is used to access and eventually terminate the service. -* A /'ProcHandle'/ is created whenever a service specifed by a /'Proc'/ is-started, and is used to access and eventually terminate the service.+    * Some @'Proc's@ are also /'Connectable'/; they implement a typeclass that+      specifies how to access the service via some /'Conn'-ection/ type. -* Some @'Proc's@ will also be /'Connectable'/; these specify how access the-service via some /'Conn'-ection/ type.+* Custom setup of the docker container is supported++    * A @'Proc'@ type may also implement @'Preparer'@++        * @'Preparer'@ allows resources to before prepared before the docker+          start command is invoked, and cleaned up afterwards++        * @'ToRunCmd'@ may then be used to update the @docker run@ command line+          to refer to prepared resources -} module System.TmpProc.Docker   ( -- * @'Proc'@@@ -67,11 +74,12 @@   , uriOf'   , runArgs' -    -- * customize docker startup+    -- * customize proc setup+  , ProcPlus   , ToRunCmd (..)   , Preparer (..) -    -- * start/stop multiple procs+    -- * start/stop many procs   , startupAll   , startupAll'   , terminateAll@@ -80,7 +88,7 @@   , withTmpProcs      -- * access a started @'Proc'@-  , ProcHandle (..)+  , ProcHandle (ProcHandle, hUri, hPid, hAddr, hProc)   , SlimHandle (..)   , Proc2Handle   , HasHandle@@ -91,10 +99,11 @@   , ixPing   , ixUriOf -    -- * access multiple procs+    -- * access many started procs   , HandlesOf   , NetworkHandlesOf   , manyNamed+  , mapSlim   , genNetworkName   , SomeNamedHandles @@ -207,26 +216,48 @@   HList procs ->   (HandlesOf procs -> IO b) ->   IO b-withTmpProcs procs action =-  let wrapAction f (_, ps) = f ps-   in bracket (netwStartupAll procs) netwTerminateAll $ wrapAction action+withTmpProcs procs = bracket (startupAll procs) terminateAll   -- | Provides access to a 'Proc' that has been started.-data ProcHandle a = ProcHandle-  { hProc :: !a-  , hPid :: !String-  , hUri :: !SvcURI-  , hAddr :: !HostIpAddress+data ProcHandle a = MkProcHandle+  { mphProc :: !a+  , mphPid :: !String+  , mphUri :: !SvcURI+  , mphAddr :: !HostIpAddress+  , mphNetwork :: !(Maybe Text)+  , mphTidy :: !(IO ())   }  +{- | A @pattern@ constructor the provides selectors for the @ProcHandle@ fields++The selectors are readonly, i.e they only match in pattern context since+@ProcHandle@s cannot be constructed directly; they are obtained@ through+'startupAll' or 'startup'+-}+pattern ProcHandle ::+  -- | the 'Proc' that led to this @ProcHandle@+  a ->+  -- | the docker process ID corresponding to the started container+  String ->+  -- | the URI to the test service instance+  SvcURI ->+  -- | the IP address of the test service instance+  HostIpAddress ->+  ProcHandle a+pattern ProcHandle {hProc, hPid, hUri, hAddr} <- MkProcHandle hProc hPid hUri hAddr _ _+++{-# COMPLETE ProcHandle #-}++ -- | Provides an untyped view of the data in a 'ProcHandle' data SlimHandle = SlimHandle-  { shName :: !Text-  , shIpAddress :: !HostIpAddress-  , shPid :: !String-  , shUri :: !SvcURI+  { shName :: Text+  , shIpAddress :: HostIpAddress+  , shPid :: String+  , shUri :: SvcURI   }   deriving (Eq, Show) @@ -242,18 +273,39 @@     }  -slimMany :: (AreProcs procs) => HandlesOf procs -> [SlimHandle]-slimMany =+-- | Obtain the 'SlimHandle' of several @'Proc's@+mapSlim :: (AreProcs procs) => HandlesOf procs -> [SlimHandle]+mapSlim =   let step x acc = slim x : acc    in foldProcs step []  --- | Start up processes for each 'Proc' type.+{- | Start up processes for each 'Proc' type++the processes' are able to communicate via a docker network with a unique+generated name+-} startupAll :: (AreProcs procs) => HList procs -> IO (HandlesOf procs)-startupAll ps = snd <$> startupAll' Nothing ps+startupAll ps = do+  name <- genNetworkName+  let+    name' = Text.unpack 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+      pure $ h `HCons` others+  void $ readProcess "docker" (createNetworkArgs name') ""+  go procProof ps  --- | Like 'startupAll' but creates a new docker network and that the processes use+{-# DEPRECATED netwStartupAll "since v0.7 this is no longer needed and will be removed, use startupAll instead" #-}+++{- | Like 'startupAll', but reveals the generated network name via the+deprecated 'NetworkHandlesOf'+-} netwStartupAll :: (AreProcs procs) => HList procs -> IO (NetworkHandlesOf procs) netwStartupAll ps = do   netwName <- genNetworkName@@ -274,6 +326,9 @@     go (SomeProcsCons cons) (x `HCons` y) = f x $ go cons y  +{-# DEPRECATED startupAll' "since v0.7 this is no longer needed and will be removed, use startupAll instead; it always generates a named docker network" #-}++ -- | Start up processes for each 'Proc' type. startupAll' :: (AreProcs procs) => Maybe Text -> HList procs -> IO (NetworkHandlesOf procs) startupAll' ntwkMb ps =@@ -287,7 +342,7 @@     go SomeProcsNil HNil = pure HNil     go (SomeProcsCons cons) (x `HCons` y) = do       others <- go cons y-      h <- startup' ntwkMb (slimMany others) x `onException` terminateAll others+      h <- startup' ntwkMb (mapSlim others) x `onException` terminateAll others       pure $ h `HCons` others    in     do@@ -297,19 +352,40 @@  -- | Terminate all processes owned by some @'ProcHandle's@. terminateAll :: (AreProcs procs) => HandlesOf procs -> IO ()-terminateAll =+terminateAll procs = terminateAllProcs procs >> terminateNetwork procs+++terminateAllProcs :: (AreProcs procs) => HandlesOf procs -> IO ()+terminateAllProcs procs =   let step x acc = terminate x >> acc-   in foldProcs step $ pure ()+      foldTerminate = foldProcs step+   in flip foldTerminate procs $ pure ()  +terminateNetwork :: (AreProcs procs) => HandlesOf procs -> IO ()+terminateNetwork procs =+  let+    rmNetwork' name = void $ readProcess "docker" (removeNetworkArgs name) ""+    rmNetwork = maybe (pure ()) (rmNetwork' . Text.unpack)+   in+    rmNetwork $ network procs+++network :: (AreProcs procs) => HandlesOf procs -> Maybe Text+network =+  let step x _ = mphNetwork x+   in foldProcs step Nothing+++{-# DEPRECATED netwTerminateAll "since v0.7 this is no longer needed and will be removed, use terminateAll instead" #-}++ {- | Like 'terminateAll', but also removes the docker network connecting the processes. -} netwTerminateAll :: (AreProcs procs) => NetworkHandlesOf procs -> IO ()-netwTerminateAll (ntwk, ps) = do-  let name' = Text.unpack ntwk+netwTerminateAll (_ntwk, ps) = do   terminateAll ps-  void $ readProcess "docker" (removeNetworkArgs name') ""   -- | Terminate the process owned by a @'ProcHandle's@.@@ -318,6 +394,7 @@   let pid = hPid handle   void $ readProcess "docker" ["stop", pid] ""   void $ readProcess "docker" ["rm", pid] ""+  mphTidy handle   {- | Prepare resources for use by a  @'Proc'@@@ -328,33 +405,37 @@  Usually, it will be used by @'toRunCmd'@ to provide additional arguments to the  docker command - There is an @Overlappable@ fallback instance that works for any @'Proc'@,- so this typeclass need only be specified for @'Proc'@ that require some- setup+ There is an @Overlappable@ fallback instance that matches all @'Proc'@, so this+ typeclass need only be specified for @'Proc'@ that require some setup - The 'prepare' method is given a list of 'SlimHandle' that represent preceding- @tmp-proc@ managed containers, to allow preparation to establish links to these- containers when necessary+ The 'prepare' method's first argument is a list of 'SlimHandle' that represent+ preceding @tmp-proc@ managed containers, to allow 'prepare' to setup links+ to these containers when required -} class Preparer a prepared | a -> prepared where-  -- * Generate a @prepared@ before the docker container is started+  -- | Generate a @prepared@ before the docker container is started   prepare :: [SlimHandle] -> a -> IO prepared  +  -- | Tidy any resources associated with @prepared@+  tidy :: a -> prepared -> IO ()++ instance {-# OVERLAPPABLE #-} (a ~ a', Proc a) => Preparer a a' where-  prepare :: [SlimHandle] -> a -> IO a'   prepare _ = pure+  tidy _ _ = pure ()   {- | Allow customization of the docker command that launches a @'Proc'@ - The full command is-   `docker run -d <optional-args> --name $(name a) $(imageText a)`- Specify a new instance of @ToRunCmd@ to control <optional-args>+ The full launch command is+   `docker run -d /optional-args/ --name $(name a) $(imageText a)` - There is an @Overlappable@ fallback instance that works for any @'Proc'@,- so this typeclass need only be specified for @'Proc'@ that need extra- args in the docker command+ Specify a new instance of @ToRunCmd@ to control /optional-args/++ There is an @Overlappable@ fallback instance with default behaviour that+ matches all @'Proc'@, so this typeclass need only be implemented for @'Proc'@+ types that actually need additional arguments -} class (Preparer a prepared) => ToRunCmd a prepared where   -- * Generate docker command args to immeidately an initial ['docker', 'run', '-d']@@ -464,7 +545,13 @@   -- | The full args of a @docker run@ command for starting up a 'Proc'.-dockerCmdArgs :: forall a prepared. (Proc a, ToRunCmd a prepared) => a -> prepared -> Maybe Text -> [Text]+dockerCmdArgs ::+  forall a prepared.+  (Proc a, ToRunCmd a prepared) =>+  a ->+  prepared ->+  Maybe Text ->+  [Text] dockerCmdArgs x prep ntwkMb =   let toNetworkArgs n = ["--network", n]       networkArg = maybe mempty toNetworkArgs ntwkMb@@ -495,7 +582,9 @@ Returns the 'ProcHandle' used to control the 'Proc' once a ping has succeeded. -} startup :: (ProcPlus a prepared) => a -> IO (ProcHandle a)-startup = startup' Nothing mempty+startup p = do+  handles <- startupAll $ only p+  pure $ hHead handles   -- | A @Constraint@ that combines @'Proc'@  and its supporting typeclasses@@ -508,25 +597,33 @@   [SlimHandle] ->   a ->   IO (ProcHandle a)-startup' ntwkMb addrs x = do+startup' mphNetwork addrs x = do   x' <- prepare addrs x-  let fullArgs = map Text.unpack $ dockerCmdArgs x x' ntwkMb+  let fullArgs = map Text.unpack $ dockerCmdArgs x x' mphNetwork       isGarbage = flip elem ['\'', '\n']       trim = dropWhileEnd isGarbage . dropWhile isGarbage   printDebug $ Text.pack $ show fullArgs   runCmd <- createDockerCmdProcess fullArgs-  hPid <- trim <$> readCreateProcess runCmd ""-  hAddr <-+  mphPid <- trim <$> readCreateProcess runCmd ""+  mphAddr <-     Text.pack . trim       <$> readProcess         "docker"         [ "inspect"-        , hPid+        , mphPid         , "--format"         , "'{{range .NetworkSettings.Networks}}{{.IPAddress}}{{end}}'"         ]         ""-  let h = ProcHandle {hProc = x, hPid, hUri = uriOf' x hAddr, hAddr}+  let h =+        MkProcHandle+          { mphProc = x+          , mphPid+          , mphUri = uriOf' x mphAddr+          , mphAddr+          , mphNetwork+          , mphTidy = tidy x x'+          }   (nPings h `onException` terminate h) >>= \case     OK -> pure h     pinged -> do@@ -555,8 +652,9 @@  -- | Ping a 'ProcHandle' several times. nPings :: (Proc a) => ProcHandle a -> IO Pinged-nPings h@ProcHandle {hProc = p} =+nPings h =   let+    p = hProc h     count = fromEnum $ pingCount' p     gap = fromEnum $ pingGap' p @@ -754,7 +852,12 @@ type HandlesOf procs = HList (Proc2Handle procs)  --- | A list of @'ProcHandle'@ values with the docker network of their processes+{-# DEPRECATED NetworkHandlesOf "since v0.7 this is no longer necessary and will be removed" #-}+++{- | A list of @'ProcHandle'@ values of different types with the name of the+docker network connecting their processes+-} type NetworkHandlesOf procs = (Text, HandlesOf procs)  @@ -955,6 +1058,9 @@ printDebug t = do   canPrint <- showDebug   when canPrint $ Text.hPutStrLn stderr t+++{-# DEPRECATED genNetworkName "since v0.7 this is no longer needs to be exported and will be hidden in later releases" #-}   -- | generate a random network name
src/System/TmpProc/Warp.hs view
@@ -45,7 +45,6 @@ import Control.Exception (ErrorCall (..)) import Control.Monad (void, when) import Control.Monad.Cont (cont, runCont)-import Data.Text (Text) import Network.Socket (Socket, close) import Network.Wai (Application) import qualified Network.Wai.Handler.Warp as Warp@@ -54,8 +53,8 @@   ( AreProcs   , HList (..)   , HandlesOf-  , netwStartupAll-  , netwTerminateAll+  , startupAll+  , terminateAll   , withTmpProcs   ) import UnliftIO@@ -77,7 +76,6 @@   , shPort :: !Warp.Port   , shSocket :: !Socket   , shHandles :: !(HandlesOf procs)-  , shNetwork :: !Text   }  @@ -131,7 +129,7 @@   IO (ServerHandle procs) runReadyServer' runApp check procs mkApp = do   callingThread <- myThreadId-  (netw, h) <- netwStartupAll procs+  h <- startupAll procs   (p, sock) <- Warp.openFreePort   signal <- newEmptyMVar   let settings = readySettings (putMVar signal ())@@ -144,7 +142,7 @@           throwIO e   s <- async $ runApp settings sock wrappedApp   aConfirm <- async (takeMVar signal)-  let result = ServerHandle s p sock h netw+  let result = ServerHandle s p sock h   waitEither s aConfirm >>= \case     Left _ -> do       shutdown result@@ -157,8 +155,8 @@ -- | Shuts down the 'ServerHandle' server and its @tmp proc@ dependencies. shutdown :: (AreProcs procs) => ServerHandle procs -> IO () shutdown h = do-  let ServerHandle {shServer, shSocket, shHandles, shNetwork} = h-  netwTerminateAll (shNetwork, shHandles)+  let ServerHandle {shServer, shSocket, shHandles} = h+  terminateAll shHandles   cancel shServer   close shSocket
test/Test/NginxGateway.hs view
@@ -36,7 +36,7 @@ import Network.TLS (ClientParams (..), HostName, Shared (..), Supported (..), defaultParamsClient) import Network.TLS.Extra (ciphersuite_default) import Paths_tmp_proc (getDataDir)-import System.Directory (createDirectory)+import System.Directory (createDirectory, removeDirectoryRecursive) import System.FilePath ((</>)) import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory) import System.Posix.ByteString (getEffectiveGroupID, getEffectiveUserID)@@ -81,6 +81,7 @@  instance Preparer NginxGateway NginxPrep where   prepare = prepare'+  tidy = tidy'   {- | Configures launch of a container thats uses nginx as a gateway (a.k.a@@ -143,6 +144,10 @@   createDirectory confDir   createDirectory certsDir   pure topDir+++tidy' :: NginxGateway -> NginxPrep -> IO ()+tidy' _ np = removeDirectoryRecursive $ npVolumeRoot np   toRunCmd' :: NginxGateway -> NginxPrep -> [Text]
tmp-proc.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               tmp-proc-version:            0.6.2.1+version:            0.7.0.0 synopsis:           Run 'tmp' processes in integration tests description:   @tmp-proc@ runs services in docker containers for use in integration tests.