{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK prune not-home #-}

{- |
Copyright   : (c) 2020-2021 Tim Emiola
SPDX-License-Identifier: BSD3
Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>

Provides the core data types and combinators used to launch temporary /(tmp)/
processes /(procs)/ using docker.

@tmp-proc@ aims to simplify integration tests that use dockerizable services.

* @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
  tests easier, by providing types and combinators that take care of

    * launching services on docker
    * obtaining references to the launched service
    * cleaning up docker once the tests are finished

It does this via its typeclasses and data types:

* 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 arguments in the @docker run@ 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.

    * Some @'Proc's@ are also /'Connectable'/; they implement a typeclass that
      specifies how to 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'@
    Proc (..)
  , Pinged (..)
  , AreProcs
  , nameOf
  , startup
  , toPinged
  , uriOf'
  , runArgs'

    -- * customize proc setup
  , ProcPlus
  , ToRunCmd (..)
  , Preparer (..)

    -- * start/stop many procs
  , startupAll
  , startupAll'
  , terminateAll
  , netwTerminateAll
  , netwStartupAll
  , withTmpProcs

    -- * access a started @'Proc'@
  , ProcHandle (ProcHandle, hUri, hPid, hAddr, hProc)
  , SlimHandle (..)
  , Proc2Handle
  , HasHandle
  , HasNamedHandle
  , slim
  , handleOf
  , ixReset
  , ixPing
  , ixUriOf

    -- * access many started procs
  , HandlesOf
  , NetworkHandlesOf
  , manyNamed
  , mapSlim
  , genNetworkName
  , SomeNamedHandles

    -- * @'Connectable'@
  , Connectable (..)
  , Connectables
  , withTmpConn
  , withConnOf
  , openAll
  , closeAll
  , withConns
  , withKnownConns
  , withNamedConns

    -- * Docker status
  , hasDocker

    -- * Aliases
  , HostIpAddress
  , SvcURI

    -- * Re-exports
  , module System.TmpProc.TypeLevel
  )
where

import Control.Concurrent (threadDelay)
import Control.Exception
  ( Exception
  , SomeException
  , bracket
  , catch
  , onException
  )
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.Proxy (Proxy (..))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Word (Word16)
import Fmt ((+|), (|+))
import GHC.TypeLits
  ( CmpSymbol
  , KnownSymbol
  , Nat
  , Symbol
  , symbolVal
  )
import Numeric.Natural (Natural)
import System.Environment (lookupEnv)
import System.Exit (ExitCode (..))
import System.IO (Handle, IOMode (..), openBinaryFile, stderr)
import System.Process
  ( CreateProcess
  , StdStream (..)
  , proc
  , readCreateProcess
  , readProcess
  , std_err
  , std_out
  , waitForProcess
  , withCreateProcess
  )
import System.Random (randomIO)
import System.TmpProc.TypeLevel
  ( Drop
  , HList (..)
  , HalfOf
  , IsAbsent
  , IsInProof
  , KV (..)
  , LengthOf
  , ManyMemberKV
  , MemberKV
  , ReorderH (..)
  , SortSymbols
  , Take
  , both
  , hHead
  , hOf
  , only
  , select
  , selectMany
  , (&:)
  , (&:&)
  )


-- | Determines if the docker daemon is accessible.
hasDocker :: IO Bool
hasDocker :: IO Bool
hasDocker = do
  let rawSystemNoStdout :: FilePath -> [FilePath] -> IO ExitCode
rawSystemNoStdout FilePath
cmd [FilePath]
args =
        forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess
          (FilePath -> [FilePath] -> CreateProcess
proc FilePath
cmd [FilePath]
args) {std_out :: StdStream
std_out = StdStream
CreatePipe, std_err :: StdStream
std_err = StdStream
CreatePipe}
          (\Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ -> ProcessHandle -> IO ExitCode
waitForProcess)
          forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOError
_ :: IOError) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure Int
127))
      succeeds :: ExitCode -> Bool
succeeds ExitCode
ExitSuccess = Bool
True
      succeeds ExitCode
_ = Bool
False

  ExitCode -> Bool
succeeds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> IO ExitCode
rawSystemNoStdout FilePath
"docker" [FilePath
"ps"]


-- | Set up some @'Proc's@, run an action that uses them, then terminate them.
withTmpProcs ::
  (AreProcs procs) =>
  HList procs ->
  (HandlesOf procs -> IO b) ->
  IO b
withTmpProcs :: forall (procs :: [*]) b.
AreProcs procs =>
HList procs -> (HandlesOf procs -> IO b) -> IO b
withTmpProcs HList procs
procs = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall (procs :: [*]).
AreProcs procs =>
HList procs -> IO (HandlesOf procs)
startupAll HList procs
procs) forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAll


-- | Provides access to a 'Proc' that has been started.
data ProcHandle a = MkProcHandle
  { forall a. ProcHandle a -> a
mphProc :: !a
  , forall a. ProcHandle a -> FilePath
mphPid :: !String
  , forall a. ProcHandle a -> SvcURI
mphUri :: !SvcURI
  , forall a. ProcHandle a -> Text
mphAddr :: !HostIpAddress
  , forall a. ProcHandle a -> Maybe Text
mphNetwork :: !(Maybe Text)
  , forall a. ProcHandle a -> IO ()
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 $mProcHandle :: forall {r} {a}.
ProcHandle a
-> (a -> FilePath -> SvcURI -> Text -> r) -> ((# #) -> r) -> r
ProcHandle {forall a. ProcHandle a -> a
hProc, forall a. ProcHandle a -> FilePath
hPid, forall a. ProcHandle a -> SvcURI
hUri, forall a. ProcHandle a -> Text
hAddr} <- MkProcHandle hProc hPid hUri hAddr _ _


{-# COMPLETE ProcHandle #-}


-- | Provides an untyped view of the data in a 'ProcHandle'
data SlimHandle = SlimHandle
  { SlimHandle -> Text
shName :: Text
  , SlimHandle -> Text
shIpAddress :: HostIpAddress
  , SlimHandle -> FilePath
shPid :: String
  , SlimHandle -> SvcURI
shUri :: SvcURI
  }
  deriving (SlimHandle -> SlimHandle -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SlimHandle -> SlimHandle -> Bool
$c/= :: SlimHandle -> SlimHandle -> Bool
== :: SlimHandle -> SlimHandle -> Bool
$c== :: SlimHandle -> SlimHandle -> Bool
Eq, Int -> SlimHandle -> ShowS
[SlimHandle] -> ShowS
SlimHandle -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [SlimHandle] -> ShowS
$cshowList :: [SlimHandle] -> ShowS
show :: SlimHandle -> FilePath
$cshow :: SlimHandle -> FilePath
showsPrec :: Int -> SlimHandle -> ShowS
$cshowsPrec :: Int -> SlimHandle -> ShowS
Show)


-- | Obtain the 'SlimHandle'.
slim :: (Proc a) => ProcHandle a -> SlimHandle
slim :: forall a. Proc a => ProcHandle a -> SlimHandle
slim ProcHandle a
x =
  SlimHandle
    { shName :: Text
shName = forall a. Proc a => a -> Text
nameOf forall a b. (a -> b) -> a -> b
$ forall a. ProcHandle a -> a
hProc ProcHandle a
x
    , shIpAddress :: Text
shIpAddress = forall a. ProcHandle a -> Text
hAddr ProcHandle a
x
    , shPid :: FilePath
shPid = forall a. ProcHandle a -> FilePath
hPid ProcHandle a
x
    , shUri :: SvcURI
shUri = forall a. ProcHandle a -> SvcURI
hUri ProcHandle a
x
    }


-- | Obtain the 'SlimHandle' of several @'Proc's@
mapSlim :: (AreProcs procs) => HandlesOf procs -> [SlimHandle]
mapSlim :: forall (procs :: [*]).
AreProcs procs =>
HandlesOf procs -> [SlimHandle]
mapSlim =
  let step :: ProcHandle a -> [SlimHandle] -> [SlimHandle]
step ProcHandle a
x [SlimHandle]
acc = forall a. Proc a => ProcHandle a -> SlimHandle
slim ProcHandle a
x forall a. a -> [a] -> [a]
: [SlimHandle]
acc
   in forall (procs :: [*]) b.
AreProcs procs =>
(forall a. Proc a => ProcHandle a -> b -> b)
-> b -> HandlesOf procs -> b
foldProcs forall {a}. Proc a => ProcHandle a -> [SlimHandle] -> [SlimHandle]
step []


{- | 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 :: forall (procs :: [*]).
AreProcs procs =>
HList procs -> IO (HandlesOf procs)
startupAll HList procs
ps = do
  Text
name <- IO Text
genNetworkName
  let
    name' :: FilePath
name' = Text -> FilePath
Text.unpack Text
name
    go :: SomeProcs as -> HList as -> IO (HandlesOf as)
    go :: forall (as :: [*]). SomeProcs as -> HList as -> IO (HandlesOf as)
go SomeProcs as
SomeProcsNil HList as
HNil = forall (f :: * -> *) a. Applicative f => a -> f a
pure HList '[]
HNil
    go (SomeProcsCons SomeProcs as
cons) (anyTy
x `HCons` HList manyTys
y) = do
      HList (Proc2Handle as)
others <- forall (as :: [*]). SomeProcs as -> HList as -> IO (HandlesOf as)
go SomeProcs as
cons HList manyTys
y
      ProcHandle anyTy
h <- forall a prepared.
ProcPlus a prepared =>
Maybe Text -> [SlimHandle] -> a -> IO (ProcHandle a)
startup' (forall a. a -> Maybe a
Just Text
name) (forall (procs :: [*]).
AreProcs procs =>
HandlesOf procs -> [SlimHandle]
mapSlim HList (Proc2Handle as)
others) anyTy
x forall a b. IO a -> IO b -> IO a
`onException` forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAll HList (Proc2Handle as)
others
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ProcHandle anyTy
h forall a (as :: [*]). a -> HList as -> HList (a : as)
`HCons` HList (Proc2Handle as)
others
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"docker" (FilePath -> [FilePath]
createNetworkArgs FilePath
name') FilePath
""
  forall (as :: [*]). SomeProcs as -> HList as -> IO (HandlesOf as)
go forall (as :: [*]). AreProcs as => SomeProcs as
procProof HList procs
ps


{-# 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 :: forall (procs :: [*]).
AreProcs procs =>
HList procs -> IO (NetworkHandlesOf procs)
netwStartupAll HList procs
ps = do
  Text
netwName <- IO Text
genNetworkName
  forall (procs :: [*]).
AreProcs procs =>
Maybe Text -> HList procs -> IO (NetworkHandlesOf procs)
startupAll' (forall a. a -> Maybe a
Just Text
netwName) HList procs
ps


foldProcs ::
  forall procs b.
  (AreProcs procs) =>
  (forall a. (Proc a) => ProcHandle a -> b -> b) ->
  b ->
  HandlesOf procs ->
  b
foldProcs :: forall (procs :: [*]) b.
AreProcs procs =>
(forall a. Proc a => ProcHandle a -> b -> b)
-> b -> HandlesOf procs -> b
foldProcs forall a. Proc a => ProcHandle a -> b -> b
f b
acc = forall (as :: [*]). SomeProcs as -> HandlesOf as -> b
go forall (as :: [*]). AreProcs as => SomeProcs as
procProof
  where
    go :: SomeProcs as -> HandlesOf as -> b
    go :: forall (as :: [*]). SomeProcs as -> HandlesOf as -> b
go SomeProcs as
SomeProcsNil HList (Proc2Handle as)
HNil = b
acc
    go (SomeProcsCons SomeProcs as
cons) (anyTy
x `HCons` HList manyTys
y) = forall a. Proc a => ProcHandle a -> b -> b
f anyTy
x forall a b. (a -> b) -> a -> b
$ forall (as :: [*]). SomeProcs as -> HandlesOf as -> b
go SomeProcs as
cons HList manyTys
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' :: forall (procs :: [*]).
AreProcs procs =>
Maybe Text -> HList procs -> IO (NetworkHandlesOf procs)
startupAll' Maybe Text
ntwkMb HList procs
ps =
  let
    mayCreateNetwork :: IO ()
mayCreateNetwork = case Maybe Text
ntwkMb of
      Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just Text
name -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"docker" (FilePath -> [FilePath]
createNetworkArgs forall a b. (a -> b) -> a -> b
$ Text -> FilePath
Text.unpack Text
name) FilePath
""
    wrap :: HList (Proc2Handle procs) -> (Text, HList (Proc2Handle procs))
wrap HList (Proc2Handle procs)
x = (forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
ntwkMb, HList (Proc2Handle procs)
x)

    go :: SomeProcs as -> HList as -> IO (HandlesOf as)
    go :: forall (as :: [*]). SomeProcs as -> HList as -> IO (HandlesOf as)
go SomeProcs as
SomeProcsNil HList as
HNil = forall (f :: * -> *) a. Applicative f => a -> f a
pure HList '[]
HNil
    go (SomeProcsCons SomeProcs as
cons) (anyTy
x `HCons` HList manyTys
y) = do
      HList (Proc2Handle as)
others <- forall (as :: [*]). SomeProcs as -> HList as -> IO (HandlesOf as)
go SomeProcs as
cons HList manyTys
y
      ProcHandle anyTy
h <- forall a prepared.
ProcPlus a prepared =>
Maybe Text -> [SlimHandle] -> a -> IO (ProcHandle a)
startup' Maybe Text
ntwkMb (forall (procs :: [*]).
AreProcs procs =>
HandlesOf procs -> [SlimHandle]
mapSlim HList (Proc2Handle as)
others) anyTy
x forall a b. IO a -> IO b -> IO a
`onException` forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAll HList (Proc2Handle as)
others
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ProcHandle anyTy
h forall a (as :: [*]). a -> HList as -> HList (a : as)
`HCons` HList (Proc2Handle as)
others
   in
    do
      IO ()
mayCreateNetwork
      HList (Proc2Handle procs) -> (Text, HList (Proc2Handle procs))
wrap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (as :: [*]). SomeProcs as -> HList as -> IO (HandlesOf as)
go forall (as :: [*]). AreProcs as => SomeProcs as
procProof HList procs
ps


-- | Terminate all processes owned by some @'ProcHandle's@.
terminateAll :: (AreProcs procs) => HandlesOf procs -> IO ()
terminateAll :: forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAll HandlesOf procs
procs = forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAllProcs HandlesOf procs
procs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateNetwork HandlesOf procs
procs


terminateAllProcs :: (AreProcs procs) => HandlesOf procs -> IO ()
terminateAllProcs :: forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAllProcs HandlesOf procs
procs =
  let step :: ProcHandle p -> IO b -> IO b
step ProcHandle p
x IO b
acc = forall a. ProcHandle a -> IO ()
terminate ProcHandle p
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
acc
      foldTerminate :: IO b -> HandlesOf procs -> IO b
foldTerminate = forall (procs :: [*]) b.
AreProcs procs =>
(forall a. Proc a => ProcHandle a -> b -> b)
-> b -> HandlesOf procs -> b
foldProcs forall {p} {b}. ProcHandle p -> IO b -> IO b
step
   in forall a b c. (a -> b -> c) -> b -> a -> c
flip forall {b}. IO b -> HandlesOf procs -> IO b
foldTerminate HandlesOf procs
procs forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


terminateNetwork :: (AreProcs procs) => HandlesOf procs -> IO ()
terminateNetwork :: forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateNetwork HandlesOf procs
procs =
  let
    rmNetwork' :: FilePath -> IO ()
rmNetwork' FilePath
name = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"docker" (FilePath -> [FilePath]
removeNetworkArgs FilePath
name) FilePath
""
    rmNetwork :: Maybe Text -> IO ()
rmNetwork = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (FilePath -> IO ()
rmNetwork' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
Text.unpack)
   in
    Maybe Text -> IO ()
rmNetwork forall a b. (a -> b) -> a -> b
$ forall (procs :: [*]).
AreProcs procs =>
HandlesOf procs -> Maybe Text
network HandlesOf procs
procs


network :: (AreProcs procs) => HandlesOf procs -> Maybe Text
network :: forall (procs :: [*]).
AreProcs procs =>
HandlesOf procs -> Maybe Text
network =
  let step :: ProcHandle a -> p -> Maybe Text
step ProcHandle a
x p
_ = forall a. ProcHandle a -> Maybe Text
mphNetwork ProcHandle a
x
   in forall (procs :: [*]) b.
AreProcs procs =>
(forall a. Proc a => ProcHandle a -> b -> b)
-> b -> HandlesOf procs -> b
foldProcs forall {a} {p}. ProcHandle a -> p -> Maybe Text
step forall a. Maybe a
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 :: forall (procs :: [*]).
AreProcs procs =>
NetworkHandlesOf procs -> IO ()
netwTerminateAll (Text
_ntwk, HandlesOf procs
ps) = do
  forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAll HandlesOf procs
ps


-- | Terminate the process owned by a @'ProcHandle's@.
terminate :: ProcHandle p -> IO ()
terminate :: forall a. ProcHandle a -> IO ()
terminate ProcHandle p
handle = do
  let pid :: FilePath
pid = forall a. ProcHandle a -> FilePath
hPid ProcHandle p
handle
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"docker" [FilePath
"stop", FilePath
pid] FilePath
""
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"docker" [FilePath
"rm", FilePath
pid] FilePath
""
  forall a. ProcHandle a -> IO ()
mphTidy ProcHandle p
handle


{- | Prepare resources for use by a  @'Proc'@

 Preparation occurs before the @Proc's @docker container is a launched, and
 resources generated are made accessible via the @prepared@ data type.

 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

 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
  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 :: [SlimHandle] -> a -> IO a'
prepare [SlimHandle]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  tidy :: a -> a' -> IO ()
  tidy :: a -> a' -> IO ()
tidy a
_ a'
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


{- | Allow customization of the docker command that launches a @'Proc'@

 The full launch command is
   `docker run -d /optional-args/ --name $(name a) $(imageText a)`

 Specify a new instance of @ToRunCmd@ to control /optional-args/

 There is an @Overlappable@ fallback instance that works for any @'Proc'@,
 so this typeclass need only be specified when a @'Proc'@ actually needs it
-}
class (Preparer a prepared) => ToRunCmd a prepared where
  -- * Generate docker command args to immeidately an initial ['docker', 'run', '-d']
  toRunCmd :: a -> prepared -> [Text]


instance {-# OVERLAPPABLE #-} (a ~ a', Proc a) => ToRunCmd a a' where
  toRunCmd :: a -> a' -> [Text]
toRunCmd a
_ a'
_ = forall a. Proc a => [Text]
runArgs @a


-- | Specifies how to a get a connection to a 'Proc'.
class (Proc a) => Connectable a where
  -- | The connection type.
  type Conn a = (conn :: Type) | conn -> a


  -- | Get a connection to the Proc via its 'ProcHandle'.
  openConn :: ProcHandle a -> IO (Conn a)


  -- | Close a connection to a 'Proc'.
  closeConn :: Conn a -> IO ()
  closeConn = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | Specifies how to launch a temporary process using Docker.
class (KnownSymbol (Image a), KnownSymbol (Name a)) => Proc a where
  -- | The image name of the docker image, e.g, /postgres:10.6/
  type Image a :: Symbol


  -- | A label used to refer to running process created from this image, e.g,
  --   /a-postgres-db/
  type Name a = (labelName :: Symbol) | labelName -> a


  -- | Additional arguments to the docker command that launches the tmp proc.
  runArgs :: [Text]
  runArgs = forall a. Monoid a => a
mempty


  -- | Determines the service URI of the process, when applicable.
  uriOf :: HostIpAddress -> SvcURI


  -- | Resets some state in a tmp proc service.
  reset :: ProcHandle a -> IO ()


  -- | Checks if the tmp proc started ok.
  ping :: ProcHandle a -> IO Pinged


  -- | Maximum number of pings to perform during startup.
  pingCount :: Natural
  pingCount = Natural
4


  -- | Number of milliseconds between pings.
  pingGap :: Natural
  pingGap = Natural
1000000


{- | Indicates the result of pinging a 'Proc'.

If the ping succeeds, 'ping' should return 'OK'.

'ping' should catch any exceptions that are expected when the @'Proc's@ service
is not available and return 'NotOK'.

'startupAll' uses 'PingFailed' to report any unexpected exceptions that escape
'ping'.
-}
data Pinged
  = -- | The service is running OK.
    OK
  | -- | The service is not running.
    NotOK
  | -- | Contact to the service failed unexpectedly.
    PingFailed Text
  deriving (Pinged -> Pinged -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pinged -> Pinged -> Bool
$c/= :: Pinged -> Pinged -> Bool
== :: Pinged -> Pinged -> Bool
$c== :: Pinged -> Pinged -> Bool
Eq, Int -> Pinged -> ShowS
[Pinged] -> ShowS
Pinged -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Pinged] -> ShowS
$cshowList :: [Pinged] -> ShowS
show :: Pinged -> FilePath
$cshow :: Pinged -> FilePath
showsPrec :: Int -> Pinged -> ShowS
$cshowsPrec :: Int -> Pinged -> ShowS
Show)


-- | Name of a process.
nameOf :: forall a. (Proc a) => a -> Text
nameOf :: forall a. Proc a => a -> Text
nameOf a
_ = FilePath -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> FilePath
symbolVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Name a))


-- | Simplifies use of 'runArgs'.
runArgs' :: forall a. (Proc a) => a -> [Text]
runArgs' :: forall a. Proc a => a -> [Text]
runArgs' a
_ = forall a. Proc a => [Text]
runArgs @a


-- | Simplifies use of 'pingCount'.
pingCount' :: forall a. (Proc a) => a -> Natural
pingCount' :: forall a. Proc a => a -> Natural
pingCount' a
_ = forall a. Proc a => Natural
pingCount @a


-- | Simplifies use of 'pingGap'.
pingGap' :: forall a. (Proc a) => a -> Natural
pingGap' :: forall a. Proc a => a -> Natural
pingGap' a
_ = forall a. Proc a => Natural
pingGap @a


-- | Simplifies use of 'uriOf'.
uriOf' :: forall a. (Proc a) => a -> HostIpAddress -> SvcURI
uriOf' :: forall a. Proc a => a -> Text -> SvcURI
uriOf' a
_ = forall a. Proc a => Text -> SvcURI
uriOf @a


-- | 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 a
x prepared
prep Maybe Text
ntwkMb =
  let toNetworkArgs :: a -> [a]
toNetworkArgs a
n = [a
"--network", a
n]
      networkArg :: [Text]
networkArg = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall {a}. IsString a => a -> [a]
toNetworkArgs Maybe Text
ntwkMb
   in [Text
"run", Text
"-d"] forall a. Semigroup a => a -> a -> a
<> forall a. Proc a => [Text]
nameArg @a forall a. Semigroup a => a -> a -> a
<> [Text]
networkArg forall a. Semigroup a => a -> a -> a
<> forall a prepared. ToRunCmd a prepared => a -> prepared -> [Text]
toRunCmd a
x prepared
prep forall a. Semigroup a => a -> a -> a
<> [forall a. Proc a => Text
imageText' @a]


imageText' :: forall a. (Proc a) => Text
imageText' :: forall a. Proc a => Text
imageText' = FilePath -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> FilePath
symbolVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @(Image a)


nameArg :: forall a. (Proc a) => [Text]
nameArg :: forall a. Proc a => [Text]
nameArg = [Text
"--name", FilePath -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> FilePath
symbolVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @(Name a)]


-- | The IP address of the docker host.
type HostIpAddress = Text


-- | A connection string used to access the service once its running.
type SvcURI = C8.ByteString


{- | Starts a 'Proc'.

It uses 'ping' to determine if the 'Proc' started up ok, and will fail by
throwing an exception if it did not.

Returns the 'ProcHandle' used to control the 'Proc' once a ping has succeeded.
-}
startup :: (ProcPlus a prepared) => a -> IO (ProcHandle a)
startup :: forall a prepared. ProcPlus a prepared => a -> IO (ProcHandle a)
startup a
p = do
  HList '[ProcHandle a]
handles <- forall (procs :: [*]).
AreProcs procs =>
HList procs -> IO (HandlesOf procs)
startupAll forall a b. (a -> b) -> a -> b
$ forall x. x -> HList '[x]
only a
p
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a (as :: [*]). HList (a : as) -> a
hHead HList '[ProcHandle a]
handles


-- | A @Constraint@ that combines @'Proc'@  and its supporting typeclasses
type ProcPlus a prepared = (Proc a, ToRunCmd a prepared, Preparer a prepared)


startup' ::
  (ProcPlus a prepared) =>
  Maybe Text ->
  [SlimHandle] ->
  a ->
  IO (ProcHandle a)
startup' :: forall a prepared.
ProcPlus a prepared =>
Maybe Text -> [SlimHandle] -> a -> IO (ProcHandle a)
startup' Maybe Text
mphNetwork [SlimHandle]
addrs a
x = do
  prepared
x' <- forall a prepared.
Preparer a prepared =>
[SlimHandle] -> a -> IO prepared
prepare [SlimHandle]
addrs a
x
  let fullArgs :: [FilePath]
fullArgs = forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
Text.unpack forall a b. (a -> b) -> a -> b
$ forall a prepared.
(Proc a, ToRunCmd a prepared) =>
a -> prepared -> Maybe Text -> [Text]
dockerCmdArgs a
x prepared
x' Maybe Text
mphNetwork
      isGarbage :: Char -> Bool
isGarbage = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char
'\'', Char
'\n']
      trim :: ShowS
trim = forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isGarbage forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isGarbage
  Text -> IO ()
printDebug forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show [FilePath]
fullArgs
  CreateProcess
runCmd <- [FilePath] -> IO CreateProcess
createDockerCmdProcess [FilePath]
fullArgs
  FilePath
mphPid <- ShowS
trim forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CreateProcess -> FilePath -> IO FilePath
readCreateProcess CreateProcess
runCmd FilePath
""
  Text
mphAddr <-
    FilePath -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
trim
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess
        FilePath
"docker"
        [ FilePath
"inspect"
        , FilePath
mphPid
        , FilePath
"--format"
        , FilePath
"'{{range .NetworkSettings.Networks}}{{.IPAddress}}{{end}}'"
        ]
        FilePath
""
  let h :: ProcHandle a
h =
        MkProcHandle
          { mphProc :: a
mphProc = a
x
          , FilePath
mphPid :: FilePath
mphPid :: FilePath
mphPid
          , mphUri :: SvcURI
mphUri = forall a. Proc a => a -> Text -> SvcURI
uriOf' a
x Text
mphAddr
          , Text
mphAddr :: Text
mphAddr :: Text
mphAddr
          , Maybe Text
mphNetwork :: Maybe Text
mphNetwork :: Maybe Text
mphNetwork
          , mphTidy :: IO ()
mphTidy = forall a prepared. Preparer a prepared => a -> prepared -> IO ()
tidy a
x prepared
x'
          }
  (forall a. Proc a => ProcHandle a -> IO Pinged
nPings ProcHandle a
h forall a b. IO a -> IO b -> IO a
`onException` forall a. ProcHandle a -> IO ()
terminate ProcHandle a
h) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Pinged
OK -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcHandle a
h
    Pinged
pinged -> do
      forall a. ProcHandle a -> IO ()
terminate ProcHandle a
h
      forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Proc a => a -> Pinged -> FilePath
pingedMsg a
x Pinged
pinged


pingedMsg :: (Proc a) => a -> Pinged -> String
pingedMsg :: forall a. Proc a => a -> Pinged -> FilePath
pingedMsg a
_ Pinged
OK = FilePath
""
pingedMsg a
p Pinged
NotOK = FilePath
"tmp proc:" forall a. [a] -> [a] -> [a]
++ Text -> FilePath
Text.unpack (forall a. Proc a => a -> Text
nameOf a
p) forall a. [a] -> [a] -> [a]
++ FilePath
":could not be pinged"
pingedMsg a
p (PingFailed Text
err) =
  FilePath
"tmp proc:"
    forall a. [a] -> [a] -> [a]
++ Text -> FilePath
Text.unpack (forall a. Proc a => a -> Text
nameOf a
p)
    forall a. [a] -> [a] -> [a]
++ FilePath
":ping failed:"
    forall a. [a] -> [a] -> [a]
++ Text -> FilePath
Text.unpack Text
err


-- | Use an action that might throw an exception as a ping.
toPinged :: forall e a. (Exception e) => Proxy e -> IO a -> IO Pinged
toPinged :: forall e a. Exception e => Proxy e -> IO a -> IO Pinged
toPinged Proxy e
_ IO a
action =
  let handler :: e -> IO Pinged
handler (e
ex :: e) = do
        Text -> IO ()
printDebug forall a b. (a -> b) -> a -> b
$ Text
"toPinged:" forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (forall a. Show a => a -> FilePath
show e
ex)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
NotOK
   in (IO a
action forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
OK) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` e -> IO Pinged
handler


-- | Ping a 'ProcHandle' several times.
nPings :: (Proc a) => ProcHandle a -> IO Pinged
nPings :: forall a. Proc a => ProcHandle a -> IO Pinged
nPings ProcHandle a
h =
  let
    p :: a
p = forall a. ProcHandle a -> a
hProc ProcHandle a
h
    count :: Int
count = forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ forall a. Proc a => a -> Natural
pingCount' a
p
    gap :: Int
gap = forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ forall a. Proc a => a -> Natural
pingGap' a
p

    badMsg :: Text -> Text
badMsg Text
x = Text
"tmp.proc: could not start " forall a. Semigroup a => a -> a -> a
<> forall a. Proc a => a -> Text
nameOf a
p forall a. Semigroup a => a -> a -> a
<> Text
"; uncaught exception :" forall a. Semigroup a => a -> a -> a
<> Text
x
    badErr :: Text -> IO ()
badErr Text
x = Text -> IO ()
printDebug forall a b. (a -> b) -> a -> b
$ Text -> Text
badMsg Text
x

    lastMsg :: Text
lastMsg = Text
"tmp.proc: could not start " forall a. Semigroup a => a -> a -> a
<> forall a. Proc a => a -> Text
nameOf a
p forall a. Semigroup a => a -> a -> a
<> Text
"; all pings failed"
    lastErr :: IO ()
lastErr = Text -> IO ()
printDebug Text
lastMsg

    pingMsg :: a -> Text
pingMsg a
i = Text
"tmp.proc: ping #" forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (forall a. Show a => a -> FilePath
show a
i) forall a. Semigroup a => a -> a -> a
<> Text
" failed; will retry"
    nthErr :: Int -> IO ()
nthErr Int
n = Text -> IO ()
printDebug forall a b. (a -> b) -> a -> b
$ forall {a}. Show a => a -> Text
pingMsg forall a b. (a -> b) -> a -> b
$ Int
count forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
- Int
n

    ping' :: ProcHandle a -> IO Pinged
ping' ProcHandle a
x =
      forall a. Proc a => ProcHandle a -> IO Pinged
ping ProcHandle a
x
        forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` ( \(SomeException
e :: SomeException) -> do
                    let errMsg :: Text
errMsg = FilePath -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show SomeException
e
                    Text -> IO ()
badErr Text
errMsg
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Pinged
PingFailed Text
errMsg
                )

    go :: Int -> IO Pinged
go Int
n =
      ProcHandle a -> IO Pinged
ping' ProcHandle a
h forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Pinged
OK -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
OK
        Pinged
NotOK | Int
n forall a. Eq a => a -> a -> Bool
== Int
0 -> IO ()
lastErr forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
NotOK
        Pinged
NotOK -> Int -> IO ()
threadDelay Int
gap forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
nthErr Int
n forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO Pinged
go (Int
n forall a. Num a => a -> a -> a
- Int
1)
        Pinged
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
err
   in
    Int -> IO Pinged
go Int
count


{- | Constraint alias used to constrain types where proxy of a 'Proc' type looks up
  a value in an 'HList' of 'ProcHandle'.
-}
type HasHandle aProc procs =
  ( Proc aProc
  , AreProcs procs
  , IsInProof (ProcHandle aProc) (Proc2Handle procs)
  )


{- | Constraint alias used to constrain types where a 'Name' looks up
  a type in an 'HList' of 'ProcHandle'.
-}
type HasNamedHandle name a procs =
  ( name ~ Name a
  , Proc a
  , AreProcs procs
  , MemberKV name (ProcHandle a) (Handle2KV (Proc2Handle procs))
  )


-- | Run an action on a 'Connectable' handle as a callback on its 'Conn'
withTmpConn :: (Connectable a) => ProcHandle a -> (Conn a -> IO b) -> IO b
withTmpConn :: forall a b.
Connectable a =>
ProcHandle a -> (Conn a -> IO b) -> IO b
withTmpConn ProcHandle a
handle = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall a. Connectable a => ProcHandle a -> IO (Conn a)
openConn ProcHandle a
handle) forall a. Connectable a => Conn a -> IO ()
closeConn


{- | Constraint alias when several @'Name's@ are used to find matching
 types in an 'HList' of 'ProcHandle'.
-}
type SomeNamedHandles names procs someProcs sortedProcs =
  ( names ~ Proc2Name procs
  , ManyMemberKV
      (SortSymbols names)
      (SortHandles (Proc2Handle procs))
      (Handle2KV (Proc2Handle sortedProcs))
  , ReorderH (SortHandles (Proc2Handle procs)) (Proc2Handle procs)
  , ReorderH (Proc2Handle someProcs) (Proc2Handle sortedProcs)
  , AreProcs sortedProcs
  , SortHandles (Proc2Handle someProcs) ~ Proc2Handle sortedProcs
  )


-- | Select the named @'ProcHandle's@ from an 'HList' of @'ProcHandle'@.
manyNamed ::
  (SomeNamedHandles names namedProcs someProcs sortedProcs) =>
  Proxy names ->
  HandlesOf someProcs ->
  HandlesOf namedProcs
manyNamed :: forall (names :: [Symbol]) (namedProcs :: [*]) (someProcs :: [*])
       (sortedProcs :: [*]).
SomeNamedHandles names namedProcs someProcs sortedProcs =>
Proxy names -> HandlesOf someProcs -> HandlesOf namedProcs
manyNamed Proxy names
proxy HandlesOf someProcs
xs = forall (names :: [Symbol]) (sortedNames :: [Symbol]) (procs :: [*])
       (ordered :: [*]) (someProcs :: [*]).
(names ~ Proc2Name procs, sortedNames ~ SortSymbols names,
 ordered ~ SortHandles (Proc2Handle procs),
 ManyMemberKV sortedNames ordered (Handle2KV someProcs),
 ReorderH ordered (Proc2Handle procs)) =>
Proxy names -> HList (Handle2KV someProcs) -> HandlesOf procs
manyNamed' Proxy names
proxy forall a b. (a -> b) -> a -> b
$ forall (handles :: [*]) (someProcs :: [*]) (sorted :: [*])
       (sortedProcs :: [*]).
(handles ~ Proc2Handle someProcs, sorted ~ SortHandles handles,
 ReorderH handles sorted, AreProcs sortedProcs,
 Proc2Handle sortedProcs ~ sorted) =>
HList handles -> HList (Handle2KV sorted)
toSortedKVs HandlesOf someProcs
xs


manyNamed' ::
  forall (names :: [Symbol]) sortedNames (procs :: [Type]) (ordered :: [Type]) someProcs.
  ( names ~ Proc2Name procs
  , sortedNames ~ SortSymbols names
  , ordered ~ SortHandles (Proc2Handle procs)
  , ManyMemberKV sortedNames ordered (Handle2KV someProcs)
  , ReorderH ordered (Proc2Handle procs)
  ) =>
  Proxy names ->
  HList (Handle2KV someProcs) ->
  HandlesOf procs
manyNamed' :: forall (names :: [Symbol]) (sortedNames :: [Symbol]) (procs :: [*])
       (ordered :: [*]) (someProcs :: [*]).
(names ~ Proc2Name procs, sortedNames ~ SortSymbols names,
 ordered ~ SortHandles (Proc2Handle procs),
 ManyMemberKV sortedNames ordered (Handle2KV someProcs),
 ReorderH ordered (Proc2Handle procs)) =>
Proxy names -> HList (Handle2KV someProcs) -> HandlesOf procs
manyNamed' Proxy names
_ HList (Handle2KV someProcs)
kvs = forall (sorted :: [*]) (handles :: [*]) (ps :: [*]).
(sorted ~ SortHandles handles, handles ~ Proc2Handle ps,
 ReorderH sorted handles) =>
HList sorted -> HList handles
unsortHandles forall a b. (a -> b) -> a -> b
$ forall (ks :: [Symbol]) (ts :: [*]) (xs :: [*]).
ManyMemberKV ks ts xs =>
HList xs -> HList ts
selectMany @sortedNames @ordered HList (Handle2KV someProcs)
kvs


-- | Specifies how to obtain a 'ProcHandle' that is present in an HList.
class HandleOf a procs b where
  -- | Obtain the handle matching the given type from a @'HList'@ of @'ProcHandle'@.
  handleOf :: Proxy a -> HandlesOf procs -> ProcHandle b


instance (HasHandle p procs) => HandleOf p procs p where
  handleOf :: Proxy p -> HandlesOf procs -> ProcHandle p
handleOf Proxy p
_ = forall y (xs :: [*]). IsInProof y xs => Proxy y -> HList xs -> y
hOf @(ProcHandle p) forall {k} (t :: k). Proxy t
Proxy


instance (HasNamedHandle name p procs) => HandleOf name procs p where
  handleOf :: Proxy name -> HandlesOf procs -> ProcHandle p
handleOf Proxy name
_ HandlesOf procs
xs = forall (k :: Symbol) t (xs :: [*]).
MemberKV k t xs =>
HList xs -> t
select @name @(ProcHandle p) forall a b. (a -> b) -> a -> b
$ forall (handles :: [*]) (xs :: [*]).
(handles ~ Proc2Handle xs, AreProcs xs) =>
HList handles -> HList (Handle2KV handles)
toKVs HandlesOf procs
xs


-- | Builds on 'handleOf'; gives the 'Conn' of the 'ProcHandle' to a callback.
withConnOf ::
  (HandleOf idx procs namedConn, Connectable namedConn) =>
  Proxy idx ->
  HandlesOf procs ->
  (Conn namedConn -> IO b) ->
  IO b
withConnOf :: forall {k} (idx :: k) (procs :: [*]) namedConn b.
(HandleOf idx procs namedConn, Connectable namedConn) =>
Proxy idx -> HandlesOf procs -> (Conn namedConn -> IO b) -> IO b
withConnOf Proxy idx
proxy HandlesOf procs
xs Conn namedConn -> IO b
action = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b.
Connectable a =>
ProcHandle a -> (Conn a -> IO b) -> IO b
withTmpConn Conn namedConn -> IO b
action forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k) (procs :: [*]) b.
HandleOf a procs b =>
Proxy a -> HandlesOf procs -> ProcHandle b
handleOf Proxy idx
proxy HandlesOf procs
xs


-- | Specifies how to reset a 'ProcHandle' at an index in a list.
class IxReset a procs where
  -- | Resets the handle whose index is specified by the proxy type.
  ixReset :: Proxy a -> HandlesOf procs -> IO ()


instance (HasNamedHandle name a procs) => IxReset name procs where
  ixReset :: Proxy name -> HandlesOf procs -> IO ()
ixReset Proxy name
_ HandlesOf procs
xs = forall a. Proc a => ProcHandle a -> IO ()
reset forall a b. (a -> b) -> a -> b
$ forall (k :: Symbol) t (xs :: [*]).
MemberKV k t xs =>
HList xs -> t
select @name @(ProcHandle a) forall a b. (a -> b) -> a -> b
$ forall (handles :: [*]) (xs :: [*]).
(handles ~ Proc2Handle xs, AreProcs xs) =>
HList handles -> HList (Handle2KV handles)
toKVs HandlesOf procs
xs


instance (HasHandle p procs) => IxReset p procs where
  ixReset :: Proxy p -> HandlesOf procs -> IO ()
ixReset Proxy p
_ HandlesOf procs
xs = forall a. Proc a => ProcHandle a -> IO ()
reset forall a b. (a -> b) -> a -> b
$ forall y (xs :: [*]). IsInProof y xs => Proxy y -> HList xs -> y
hOf @(ProcHandle p) forall {k} (t :: k). Proxy t
Proxy HandlesOf procs
xs


-- | Specifies how to ping a 'ProcHandle' at an index in a list.
class IxPing a procs where
  -- | Pings the handle whose index is specified by the proxy type.
  ixPing :: Proxy a -> HandlesOf procs -> IO Pinged


instance (HasNamedHandle name a procs) => IxPing name procs where
  ixPing :: Proxy name -> HandlesOf procs -> IO Pinged
ixPing Proxy name
_ HandlesOf procs
xs = forall a. Proc a => ProcHandle a -> IO Pinged
ping forall a b. (a -> b) -> a -> b
$ forall (k :: Symbol) t (xs :: [*]).
MemberKV k t xs =>
HList xs -> t
select @name @(ProcHandle a) forall a b. (a -> b) -> a -> b
$ forall (handles :: [*]) (xs :: [*]).
(handles ~ Proc2Handle xs, AreProcs xs) =>
HList handles -> HList (Handle2KV handles)
toKVs HandlesOf procs
xs


instance (HasHandle p procs) => IxPing p procs where
  ixPing :: Proxy p -> HandlesOf procs -> IO Pinged
ixPing Proxy p
_ HandlesOf procs
xs = forall a. Proc a => ProcHandle a -> IO Pinged
ping forall a b. (a -> b) -> a -> b
$ forall y (xs :: [*]). IsInProof y xs => Proxy y -> HList xs -> y
hOf @(ProcHandle p) forall {k} (t :: k). Proxy t
Proxy HandlesOf procs
xs


-- | Specifies how to obtain the service URI a 'ProcHandle' at an index in a list.
class IxUriOf a procs where
  -- | Obtains the service URI of the handle whose index is specified by the proxy type.
  ixUriOf :: Proxy a -> HandlesOf procs -> SvcURI


instance (HasNamedHandle name a procs) => IxUriOf name procs where
  ixUriOf :: Proxy name -> HandlesOf procs -> SvcURI
ixUriOf Proxy name
_ HandlesOf procs
xs = forall a. ProcHandle a -> SvcURI
hUri forall a b. (a -> b) -> a -> b
$ forall (k :: Symbol) t (xs :: [*]).
MemberKV k t xs =>
HList xs -> t
select @name @(ProcHandle a) forall a b. (a -> b) -> a -> b
$ forall (handles :: [*]) (xs :: [*]).
(handles ~ Proc2Handle xs, AreProcs xs) =>
HList handles -> HList (Handle2KV handles)
toKVs HandlesOf procs
xs


instance (HasHandle p procs) => IxUriOf p procs where
  ixUriOf :: Proxy p -> HandlesOf procs -> SvcURI
ixUriOf Proxy p
_ HandlesOf procs
xs = forall a. ProcHandle a -> SvcURI
hUri forall a b. (a -> b) -> a -> b
$ forall y (xs :: [*]). IsInProof y xs => Proxy y -> HList xs -> y
hOf @(ProcHandle p) forall {k} (t :: k). Proxy t
Proxy HandlesOf procs
xs


-- | Create a 'HList' of @'KV's@ from a 'HList' of @'ProcHandle's@.
toKVs :: (handles ~ Proc2Handle xs, AreProcs xs) => HList handles -> HList (Handle2KV handles)
toKVs :: forall (handles :: [*]) (xs :: [*]).
(handles ~ Proc2Handle xs, AreProcs xs) =>
HList handles -> HList (Handle2KV handles)
toKVs = forall (as :: [*]).
SomeHandles as -> HList as -> HList (Handle2KV as)
go forall a b. (a -> b) -> a -> b
$ forall (as :: [*]). SomeProcs as -> SomeHandles (Proc2Handle as)
p2h forall (as :: [*]). AreProcs as => SomeProcs as
procProof
  where
    go :: SomeHandles as -> HList as -> HList (Handle2KV as)
    go :: forall (as :: [*]).
SomeHandles as -> HList as -> HList (Handle2KV as)
go SomeHandles as
SomeHandlesNil HList as
HNil = HList '[]
HNil
    go (SomeHandlesCons SomeHandles as
cons) (anyTy
x `HCons` HList manyTys
y) = forall a. Proc a => ProcHandle a -> KV (Name a) (ProcHandle a)
toKV anyTy
x forall a (as :: [*]). a -> HList as -> HList (a : as)
`HCons` forall (as :: [*]).
SomeHandles as -> HList as -> HList (Handle2KV as)
go SomeHandles as
cons HList manyTys
y


toSortedKVs ::
  ( handles ~ Proc2Handle someProcs
  , sorted ~ SortHandles handles
  , ReorderH handles sorted
  , AreProcs sortedProcs
  , Proc2Handle sortedProcs ~ sorted
  ) =>
  HList handles ->
  HList (Handle2KV sorted)
toSortedKVs :: forall (handles :: [*]) (someProcs :: [*]) (sorted :: [*])
       (sortedProcs :: [*]).
(handles ~ Proc2Handle someProcs, sorted ~ SortHandles handles,
 ReorderH handles sorted, AreProcs sortedProcs,
 Proc2Handle sortedProcs ~ sorted) =>
HList handles -> HList (Handle2KV sorted)
toSortedKVs HList handles
procHandles = forall (handles :: [*]) (xs :: [*]).
(handles ~ Proc2Handle xs, AreProcs xs) =>
HList handles -> HList (Handle2KV handles)
toKVs forall a b. (a -> b) -> a -> b
$ forall (handles :: [*]) (ps :: [*]) (sorted :: [*]).
(handles ~ Proc2Handle ps, sorted ~ SortHandles handles,
 ReorderH handles sorted) =>
HList handles -> HList sorted
sortHandles HList handles
procHandles


-- | Convert a 'ProcHandle' to a 'KV'.
toKV :: (Proc a) => ProcHandle a -> KV (Name a) (ProcHandle a)
toKV :: forall a. Proc a => ProcHandle a -> KV (Name a) (ProcHandle a)
toKV = forall a (s :: Symbol). a -> KV s a
V


-- | Converts list of types to the corresponding @'ProcHandle'@ types.
type family Proc2Handle (as :: [Type]) = (handleTys :: [Type]) | handleTys -> as where
  Proc2Handle '[] = '[]
  Proc2Handle (a ': as) = ProcHandle a ': Proc2Handle as


-- | A list of @'ProcHandle'@ values.
type HandlesOf procs = HList (Proc2Handle procs)


{-# 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)


-- | Converts list of 'Proc' the corresponding @'Name'@ symbols.
type family Proc2Name (as :: [Type]) = (nameTys :: [Symbol]) | nameTys -> as where
  Proc2Name '[] = '[]
  Proc2Name (a ': as) = Name a ': Proc2Name as


-- | Convert list of 'ProcHandle' types to corresponding @'KV'@ types.
type family Handle2KV (ts :: [Type]) = (kvTys :: [Type]) | kvTys -> ts where
  Handle2KV '[] = '[]
  Handle2KV (ProcHandle t ': ts) = KV (Name t) (ProcHandle t) ': Handle2KV ts


-- | Declares a proof that a list of types only contains @'Proc's@.
class AreProcs as where
  procProof :: SomeProcs as


instance AreProcs '[] where
  procProof :: SomeProcs '[]
procProof = SomeProcs '[]
SomeProcsNil


instance
  ( ProcPlus a prepared
  , AreProcs as
  , IsAbsent a as
  ) =>
  AreProcs (a ': as)
  where
  procProof :: SomeProcs (a : as)
procProof = forall a as (as :: [*]).
(ProcPlus a as, AreProcs as, IsAbsent a as) =>
SomeProcs as -> SomeProcs (a : as)
SomeProcsCons forall (as :: [*]). AreProcs as => SomeProcs as
procProof


-- | Used to prove a list of types just contains @'ProcHandle's@.
data SomeHandles (as :: [Type]) where
  SomeHandlesNil :: SomeHandles '[]
  SomeHandlesCons :: (ProcPlus a prepared) => SomeHandles as -> SomeHandles (ProcHandle a ': as)


p2h :: SomeProcs as -> SomeHandles (Proc2Handle as)
p2h :: forall (as :: [*]). SomeProcs as -> SomeHandles (Proc2Handle as)
p2h SomeProcs as
SomeProcsNil = SomeHandles '[]
SomeHandlesNil
p2h (SomeProcsCons SomeProcs as
cons) = forall a as (as :: [*]).
ProcPlus a as =>
SomeHandles as -> SomeHandles (ProcHandle a : as)
SomeHandlesCons (forall (as :: [*]). SomeProcs as -> SomeHandles (Proc2Handle as)
p2h SomeProcs as
cons)


-- | Used to prove a list of types just contains @'Proc's@.
data SomeProcs (as :: [Type]) where
  SomeProcsNil :: SomeProcs '[]
  SomeProcsCons :: (ProcPlus a prepared, AreProcs as, IsAbsent a as) => SomeProcs as -> SomeProcs (a ': as)


-- | Declares a proof that a list of types only contains @'Connectable's@.
class Connectables as where
  connProof :: Uniquely Connectable Connectables as


instance Connectables '[] where
  connProof :: Uniquely Connectable Connectables '[]
connProof = forall (f :: * -> Constraint) (fs :: [*] -> Constraint).
Uniquely f fs '[]
UniquelyNil


instance (Connectable a, Connectables as, IsAbsent a as) => Connectables (a ': as) where
  connProof :: Uniquely Connectable Connectables (a : as)
connProof = forall a (as :: [*]) (f :: * -> Constraint)
       (fs :: [*] -> Constraint).
(IsAbsent a as, f a, fs as) =>
Uniquely f fs as -> Uniquely f fs (a : as)
UniquelyCons forall (as :: [*]).
Connectables as =>
Uniquely Connectable Connectables as
connProof


-- | Convert list of 'Connectable' types to corresponding 'Conn' types.
type family ConnsOf (cs :: [Type]) = (conns :: [Type]) | conns -> cs where
  ConnsOf '[] = '[]
  ConnsOf (c ': cs) = Conn c ': ConnsOf cs


-- | Open all the 'Connectable' types to corresponding 'Conn' types.
openAll :: (Connectables xs) => HandlesOf xs -> IO (HList (ConnsOf xs))
openAll :: forall (xs :: [*]).
Connectables xs =>
HandlesOf xs -> IO (HList (ConnsOf xs))
openAll = forall (as :: [*]).
Uniquely Connectable Connectables as
-> HandlesOf as -> IO (HList (ConnsOf as))
go forall (as :: [*]).
Connectables as =>
Uniquely Connectable Connectables as
connProof
  where
    go :: Uniquely Connectable Connectables as -> HandlesOf as -> IO (HList (ConnsOf as))
    go :: forall (as :: [*]).
Uniquely Connectable Connectables as
-> HandlesOf as -> IO (HList (ConnsOf as))
go Uniquely Connectable Connectables as
UniquelyNil HList (Proc2Handle as)
HNil = forall (f :: * -> *) a. Applicative f => a -> f a
pure HList '[]
HNil
    go (UniquelyCons Uniquely Connectable Connectables as
cons) (anyTy
x `HCons` HList manyTys
y) = do
      Conn a
c <- forall a. Connectable a => ProcHandle a -> IO (Conn a)
openConn anyTy
x
      HList (ConnsOf as)
others <- forall (as :: [*]).
Uniquely Connectable Connectables as
-> HandlesOf as -> IO (HList (ConnsOf as))
go Uniquely Connectable Connectables as
cons HList manyTys
y forall a b. IO a -> IO b -> IO a
`onException` forall a. Connectable a => Conn a -> IO ()
closeConn Conn a
c
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Conn a
c forall a (as :: [*]). a -> HList as -> HList (a : as)
`HCons` HList (ConnsOf as)
others


-- | Close some 'Connectable' types.
closeAll :: (Connectables procs) => HList (ConnsOf procs) -> IO ()
closeAll :: forall (procs :: [*]).
Connectables procs =>
HList (ConnsOf procs) -> IO ()
closeAll = forall (as :: [*]).
Uniquely Connectable Connectables as -> HList (ConnsOf as) -> IO ()
go forall (as :: [*]).
Connectables as =>
Uniquely Connectable Connectables as
connProof
  where
    go :: Uniquely Connectable Connectables as -> HList (ConnsOf as) -> IO ()
    go :: forall (as :: [*]).
Uniquely Connectable Connectables as -> HList (ConnsOf as) -> IO ()
go Uniquely Connectable Connectables as
UniquelyNil HList (ConnsOf as)
HNil = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go (UniquelyCons Uniquely Connectable Connectables as
cons) (anyTy
x `HCons` HList manyTys
y) = forall a. Connectable a => Conn a -> IO ()
closeConn anyTy
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (as :: [*]).
Uniquely Connectable Connectables as -> HList (ConnsOf as) -> IO ()
go Uniquely Connectable Connectables as
cons HList manyTys
y


-- | Open some connections, use them in an action; close them.
withConns ::
  (Connectables procs) =>
  HandlesOf procs ->
  (HList (ConnsOf procs) -> IO b) ->
  IO b
withConns :: forall (procs :: [*]) b.
Connectables procs =>
HandlesOf procs -> (HList (ConnsOf procs) -> IO b) -> IO b
withConns HandlesOf procs
handles = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall (xs :: [*]).
Connectables xs =>
HandlesOf xs -> IO (HList (ConnsOf xs))
openAll HandlesOf procs
handles) forall (procs :: [*]).
Connectables procs =>
HList (ConnsOf procs) -> IO ()
closeAll


-- | Open all known connections; use them in an action; close them.
withKnownConns ::
  ( AreProcs someProcs
  , Connectables conns
  , ReorderH (Proc2Handle someProcs) (Proc2Handle conns)
  ) =>
  HandlesOf someProcs ->
  (HList (ConnsOf conns) -> IO b) ->
  IO b
withKnownConns :: forall (someProcs :: [*]) (conns :: [*]) b.
(AreProcs someProcs, Connectables conns,
 ReorderH (Proc2Handle someProcs) (Proc2Handle conns)) =>
HandlesOf someProcs -> (HList (ConnsOf conns) -> IO b) -> IO b
withKnownConns = forall (procs :: [*]) b.
Connectables procs =>
HandlesOf procs -> (HList (ConnsOf procs) -> IO b) -> IO b
withConns forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (xs :: [*]) (ys :: [*]).
ReorderH xs ys =>
HList xs -> HList ys
hReorder


-- | Open the named connections; use them in an action; close them.
withNamedConns ::
  ( SomeNamedHandles names namedConns someProcs sortedProcs
  , Connectables namedConns
  ) =>
  Proxy names ->
  HandlesOf someProcs ->
  (HList (ConnsOf namedConns) -> IO b) ->
  IO b
withNamedConns :: forall (names :: [Symbol]) (namedConns :: [*]) (someProcs :: [*])
       (sortedProcs :: [*]) b.
(SomeNamedHandles names namedConns someProcs sortedProcs,
 Connectables namedConns) =>
Proxy names
-> HandlesOf someProcs
-> (HList (ConnsOf namedConns) -> IO b)
-> IO b
withNamedConns Proxy names
proxy = forall (procs :: [*]) b.
Connectables procs =>
HandlesOf procs -> (HList (ConnsOf procs) -> IO b) -> IO b
withConns forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (names :: [Symbol]) (namedProcs :: [*]) (someProcs :: [*])
       (sortedProcs :: [*]).
SomeNamedHandles names namedProcs someProcs sortedProcs =>
Proxy names -> HandlesOf someProcs -> HandlesOf namedProcs
manyNamed Proxy names
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
  , ReorderH handles sorted
  ) =>
  HList handles ->
  HList sorted
sortHandles :: forall (handles :: [*]) (ps :: [*]) (sorted :: [*]).
(handles ~ Proc2Handle ps, sorted ~ SortHandles handles,
 ReorderH handles sorted) =>
HList handles -> HList sorted
sortHandles = forall (xs :: [*]) (ys :: [*]).
ReorderH xs ys =>
HList xs -> HList ys
hReorder


unsortHandles ::
  ( sorted ~ SortHandles handles
  , handles ~ Proc2Handle ps
  , ReorderH sorted handles
  ) =>
  HList sorted ->
  HList handles
unsortHandles :: forall (sorted :: [*]) (handles :: [*]) (ps :: [*]).
(sorted ~ SortHandles handles, handles ~ Proc2Handle ps,
 ReorderH sorted handles) =>
HList sorted -> HList handles
unsortHandles = forall (xs :: [*]) (ys :: [*]).
ReorderH xs ys =>
HList xs -> HList ys
hReorder


-- | Sort lists of @'ProcHandle'@ types.
type family SortHandles (xs :: [Type]) :: [Type] where
  SortHandles '[] = '[]
  SortHandles '[x] = '[x]
  SortHandles '[x, y] = MergeHandles '[x] '[y] -- just an optimization, not required
  SortHandles xs = SortHandlesStep xs (HalfOf (LengthOf xs))


type family SortHandlesStep (xs :: [Type]) (halfLen :: Nat) :: [Type] where
  SortHandlesStep xs halfLen = MergeHandles (SortHandles (Take xs halfLen)) (SortHandles (Drop xs halfLen))


type family MergeHandles (xs :: [Type]) (ys :: [Type]) :: [Type] where
  MergeHandles xs '[] = xs
  MergeHandles '[] ys = ys
  MergeHandles (ProcHandle x ': xs) (ProcHandle y ': ys) =
    MergeHandlesImpl (ProcHandle x ': xs) (ProcHandle y ': ys) (CmpSymbol (Name x) (Name y))


type family MergeHandlesImpl (xs :: [Type]) (ys :: [Type]) (o :: Ordering) :: [Type] where
  MergeHandlesImpl (ProcHandle x ': xs) (ProcHandle y ': ys) 'GT =
    ProcHandle y ': MergeHandles (ProcHandle x ': xs) ys
  MergeHandlesImpl (ProcHandle x ': xs) (ProcHandle y ': ys) leq =
    ProcHandle x ': MergeHandles xs (ProcHandle y ': ys)


devNull :: IO Handle
devNull :: IO Handle
devNull = FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
"/dev/null" IOMode
WriteMode


createDockerCmdProcess :: [String] -> IO CreateProcess
createDockerCmdProcess :: [FilePath] -> IO CreateProcess
createDockerCmdProcess [FilePath]
args = do
  Handle
devNull' <- IO Handle
devNull
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (FilePath -> [FilePath] -> CreateProcess
proc FilePath
"docker" [FilePath]
args) {std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
devNull'}


showDebug :: IO Bool
showDebug :: IO Bool
showDebug = forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
debugEnv


debugEnv :: String
debugEnv :: FilePath
debugEnv = FilePath
"TMP_PROC_DEBUG"


printDebug :: Text -> IO ()
printDebug :: Text -> IO ()
printDebug Text
t = do
  Bool
canPrint <- IO Bool
showDebug
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
canPrint forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
Text.hPutStrLn Handle
stderr Text
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
genNetworkName :: IO Text
genNetworkName :: IO Text
genNetworkName = Word16 -> Text
networkNameOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO


networkNameOf :: Word16 -> Text
networkNameOf :: Word16 -> Text
networkNameOf Word16
suffix = Builder
"tmp-proc-" forall b. FromBuilder b => Builder -> Builder -> b
+| Word16
suffix forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""


createNetworkArgs :: String -> [String]
createNetworkArgs :: FilePath -> [FilePath]
createNetworkArgs FilePath
name = [FilePath
"network", FilePath
"create", FilePath
"-d", FilePath
"bridge", FilePath
name]


removeNetworkArgs :: String -> [String]
removeNetworkArgs :: FilePath -> [FilePath]
removeNetworkArgs FilePath
name = [FilePath
"network", FilePath
"remove", FilePath
"-f", FilePath
name]