{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK prune not-home #-}
module System.TmpProc.Docker
(
Proc (..)
, Pinged (..)
, AreProcs
, nameOf
, startup
, toPinged
, uriOf'
, runArgs'
, ToRunCmd (..)
, Preparer (..)
, startupAll
, startupAll'
, terminateAll
, netwTerminateAll
, netwStartupAll
, withTmpProcs
, ProcHandle (..)
, SlimHandle (..)
, Proc2Handle
, HasHandle
, HasNamedHandle
, slim
, handleOf
, ixReset
, ixPing
, ixUriOf
, HandlesOf
, NetworkHandlesOf
, manyNamed
, genNetworkName
, SomeNamedHandles
, Connectable (..)
, Connectables
, withTmpConn
, withConnOf
, openAll
, closeAll
, withConns
, withKnownConns
, withNamedConns
, hasDocker
, HostIpAddress
, SvcURI
, 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
, (&:)
, (&:&)
)
hasDocker :: IO Bool
hasDocker :: IO Bool
hasDocker = do
let rawSystemNoStdout :: FilePath -> [FilePath] -> IO ExitCode
rawSystemNoStdout FilePath
cmd [FilePath]
args =
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ExitCode)
-> IO ExitCode
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 = CreatePipe, std_err = CreatePipe}
(\Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ -> ProcessHandle -> IO ExitCode
waitForProcess)
IO ExitCode -> (IOError -> IO ExitCode) -> IO ExitCode
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOError
_ :: IOError) -> ExitCode -> IO ExitCode
forall a. a -> IO a
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 (ExitCode -> Bool) -> IO ExitCode -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> IO ExitCode
rawSystemNoStdout FilePath
"docker" [FilePath
"ps"]
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 HandlesOf procs -> IO b
action =
let wrapAction :: (t -> t) -> (a, t) -> t
wrapAction t -> t
f (a
_, t
ps) = t -> t
f t
ps
in IO (Text, HandlesOf procs)
-> ((Text, HandlesOf procs) -> IO ())
-> ((Text, HandlesOf procs) -> IO b)
-> IO b
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (HList procs -> IO (Text, HandlesOf procs)
forall (procs :: [*]).
AreProcs procs =>
HList procs -> IO (NetworkHandlesOf procs)
netwStartupAll HList procs
procs) (Text, HandlesOf procs) -> IO ()
forall (procs :: [*]).
AreProcs procs =>
NetworkHandlesOf procs -> IO ()
netwTerminateAll (((Text, HandlesOf procs) -> IO b) -> IO b)
-> ((Text, HandlesOf procs) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ (HandlesOf procs -> IO b) -> (Text, HandlesOf procs) -> IO b
forall {t} {t} {a}. (t -> t) -> (a, t) -> t
wrapAction HandlesOf procs -> IO b
action
data ProcHandle a = ProcHandle
{ forall a. ProcHandle a -> a
hProc :: !a
, forall a. ProcHandle a -> FilePath
hPid :: !String
, forall a. ProcHandle a -> SvcURI
hUri :: !SvcURI
, forall a. ProcHandle a -> Text
hAddr :: !HostIpAddress
}
data SlimHandle = SlimHandle
{ SlimHandle -> Text
shName :: !Text
, SlimHandle -> Text
shIpAddress :: !HostIpAddress
, SlimHandle -> FilePath
shPid :: !String
, SlimHandle -> SvcURI
shUri :: !SvcURI
}
deriving (SlimHandle -> SlimHandle -> Bool
(SlimHandle -> SlimHandle -> Bool)
-> (SlimHandle -> SlimHandle -> Bool) -> Eq SlimHandle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SlimHandle -> SlimHandle -> Bool
== :: SlimHandle -> SlimHandle -> Bool
$c/= :: SlimHandle -> SlimHandle -> Bool
/= :: SlimHandle -> SlimHandle -> Bool
Eq, Int -> SlimHandle -> ShowS
[SlimHandle] -> ShowS
SlimHandle -> FilePath
(Int -> SlimHandle -> ShowS)
-> (SlimHandle -> FilePath)
-> ([SlimHandle] -> ShowS)
-> Show SlimHandle
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SlimHandle -> ShowS
showsPrec :: Int -> SlimHandle -> ShowS
$cshow :: SlimHandle -> FilePath
show :: SlimHandle -> FilePath
$cshowList :: [SlimHandle] -> ShowS
showList :: [SlimHandle] -> ShowS
Show)
slim :: (Proc a) => ProcHandle a -> SlimHandle
slim :: forall a. Proc a => ProcHandle a -> SlimHandle
slim ProcHandle a
x =
SlimHandle
{ shName :: Text
shName = a -> Text
forall a. Proc a => a -> Text
nameOf (a -> Text) -> a -> Text
forall a b. (a -> b) -> a -> b
$ ProcHandle a -> a
forall a. ProcHandle a -> a
hProc ProcHandle a
x
, shIpAddress :: Text
shIpAddress = ProcHandle a -> Text
forall a. ProcHandle a -> Text
hAddr ProcHandle a
x
, shPid :: FilePath
shPid = ProcHandle a -> FilePath
forall a. ProcHandle a -> FilePath
hPid ProcHandle a
x
, shUri :: SvcURI
shUri = ProcHandle a -> SvcURI
forall a. ProcHandle a -> SvcURI
hUri ProcHandle a
x
}
slimMany :: (AreProcs procs) => HandlesOf procs -> [SlimHandle]
slimMany :: forall (procs :: [*]).
AreProcs procs =>
HandlesOf procs -> [SlimHandle]
slimMany =
let step :: ProcHandle a -> [SlimHandle] -> [SlimHandle]
step ProcHandle a
x [SlimHandle]
acc = ProcHandle a -> SlimHandle
forall a. Proc a => ProcHandle a -> SlimHandle
slim ProcHandle a
x SlimHandle -> [SlimHandle] -> [SlimHandle]
forall a. a -> [a] -> [a]
: [SlimHandle]
acc
in (forall a. Proc a => ProcHandle a -> [SlimHandle] -> [SlimHandle])
-> [SlimHandle] -> HList (Proc2Handle procs) -> [SlimHandle]
forall (procs :: [*]) b.
AreProcs procs =>
(forall a. Proc a => ProcHandle a -> b -> b)
-> b -> HandlesOf procs -> b
foldProcs ProcHandle a -> [SlimHandle] -> [SlimHandle]
forall a. Proc a => ProcHandle a -> [SlimHandle] -> [SlimHandle]
step []
startupAll :: (AreProcs procs) => HList procs -> IO (HandlesOf procs)
startupAll :: forall (procs :: [*]).
AreProcs procs =>
HList procs -> IO (HandlesOf procs)
startupAll HList procs
ps = (Text, HList (Proc2Handle procs)) -> HList (Proc2Handle procs)
forall a b. (a, b) -> b
snd ((Text, HList (Proc2Handle procs)) -> HList (Proc2Handle procs))
-> IO (Text, HList (Proc2Handle procs))
-> IO (HList (Proc2Handle procs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> HList procs -> IO (Text, HList (Proc2Handle procs))
forall (procs :: [*]).
AreProcs procs =>
Maybe Text -> HList procs -> IO (NetworkHandlesOf procs)
startupAll' Maybe Text
forall a. Maybe a
Nothing HList procs
ps
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
Maybe Text -> HList procs -> IO (NetworkHandlesOf procs)
forall (procs :: [*]).
AreProcs procs =>
Maybe Text -> HList procs -> IO (NetworkHandlesOf procs)
startupAll' (Text -> Maybe Text
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 = SomeProcs procs -> HList (Proc2Handle procs) -> b
forall (as :: [*]). SomeProcs as -> HandlesOf as -> b
go SomeProcs procs
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) = ProcHandle a -> b -> b
forall a. Proc a => ProcHandle a -> b -> b
f anyTy
ProcHandle a
x (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$ SomeProcs as -> HandlesOf as -> b
forall (as :: [*]). SomeProcs as -> HandlesOf as -> b
go SomeProcs as
cons HList manyTys
HandlesOf as
y
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 -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just Text
name -> IO FilePath -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO FilePath -> IO ()) -> IO FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"docker" (FilePath -> [FilePath]
createNetworkArgs (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
Text.unpack Text
name) FilePath
""
wrap :: HList (Proc2Handle procs) -> NetworkHandlesOf procs
wrap HList (Proc2Handle procs)
x = (Text -> Maybe Text -> Text
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 = HList '[] -> IO (HList '[])
forall a. a -> IO a
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 <- SomeProcs as -> HList as -> IO (HList (Proc2Handle as))
forall (as :: [*]). SomeProcs as -> HList as -> IO (HandlesOf as)
go SomeProcs as
cons HList as
HList manyTys
y
ProcHandle anyTy
h <- Maybe Text -> [SlimHandle] -> anyTy -> IO (ProcHandle anyTy)
forall a prepared.
ProcPlus a prepared =>
Maybe Text -> [SlimHandle] -> a -> IO (ProcHandle a)
startup' Maybe Text
ntwkMb (HList (Proc2Handle as) -> [SlimHandle]
forall (procs :: [*]).
AreProcs procs =>
HandlesOf procs -> [SlimHandle]
slimMany HList (Proc2Handle as)
others) anyTy
x IO (ProcHandle anyTy) -> IO () -> IO (ProcHandle anyTy)
forall a b. IO a -> IO b -> IO a
`onException` HList (Proc2Handle as) -> IO ()
forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAll HList (Proc2Handle as)
others
HList (ProcHandle anyTy : Proc2Handle as)
-> IO (HList (ProcHandle anyTy : Proc2Handle as))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HList (ProcHandle anyTy : Proc2Handle as)
-> IO (HList (ProcHandle anyTy : Proc2Handle as)))
-> HList (ProcHandle anyTy : Proc2Handle as)
-> IO (HList (ProcHandle anyTy : Proc2Handle as))
forall a b. (a -> b) -> a -> b
$ ProcHandle anyTy
h ProcHandle anyTy
-> HList (Proc2Handle as)
-> HList (ProcHandle anyTy : Proc2Handle as)
forall anyTy (manyTys :: [*]).
anyTy -> HList manyTys -> HList (anyTy : manyTys)
`HCons` HList (Proc2Handle as)
others
in
do
IO ()
mayCreateNetwork
HList (Proc2Handle procs) -> NetworkHandlesOf procs
wrap (HList (Proc2Handle procs) -> NetworkHandlesOf procs)
-> IO (HList (Proc2Handle procs)) -> IO (NetworkHandlesOf procs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeProcs procs -> HList procs -> IO (HList (Proc2Handle procs))
forall (as :: [*]). SomeProcs as -> HList as -> IO (HandlesOf as)
go SomeProcs procs
forall (as :: [*]). AreProcs as => SomeProcs as
procProof HList procs
ps
terminateAll :: (AreProcs procs) => HandlesOf procs -> IO ()
terminateAll :: forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAll =
let step :: ProcHandle p -> IO b -> IO b
step ProcHandle p
x IO b
acc = ProcHandle p -> IO ()
forall p. ProcHandle p -> IO ()
terminate ProcHandle p
x IO () -> IO b -> IO b
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
acc
in (forall a. Proc a => ProcHandle a -> IO () -> IO ())
-> IO () -> HList (Proc2Handle procs) -> IO ()
forall (procs :: [*]) b.
AreProcs procs =>
(forall a. Proc a => ProcHandle a -> b -> b)
-> b -> HandlesOf procs -> b
foldProcs ProcHandle a -> IO () -> IO ()
forall a. Proc a => ProcHandle a -> IO () -> IO ()
forall {p} {b}. ProcHandle p -> IO b -> IO b
step (IO () -> HList (Proc2Handle procs) -> IO ())
-> IO () -> HList (Proc2Handle procs) -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
netwTerminateAll :: (AreProcs procs) => NetworkHandlesOf procs -> IO ()
netwTerminateAll :: forall (procs :: [*]).
AreProcs procs =>
NetworkHandlesOf procs -> IO ()
netwTerminateAll (Text
ntwk, HandlesOf procs
ps) = do
let name' :: FilePath
name' = Text -> FilePath
Text.unpack Text
ntwk
HandlesOf procs -> IO ()
forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAll HandlesOf procs
ps
IO FilePath -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO FilePath -> IO ()) -> IO FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"docker" (FilePath -> [FilePath]
removeNetworkArgs FilePath
name') FilePath
""
terminate :: ProcHandle p -> IO ()
terminate :: forall p. ProcHandle p -> IO ()
terminate ProcHandle p
handle = do
let pid :: FilePath
pid = ProcHandle p -> FilePath
forall a. ProcHandle a -> FilePath
hPid ProcHandle p
handle
IO FilePath -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO FilePath -> IO ()) -> IO FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"docker" [FilePath
"stop", FilePath
pid] FilePath
""
IO FilePath -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO FilePath -> IO ()) -> IO FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"docker" [FilePath
"rm", FilePath
pid] FilePath
""
class Preparer a prepared | a -> prepared where
prepare :: [SlimHandle] -> a -> IO prepared
instance {-# OVERLAPPABLE #-} (a ~ a', Proc a) => Preparer a a' where
prepare :: [SlimHandle] -> a -> IO a'
prepare :: [SlimHandle] -> a -> IO a'
prepare [SlimHandle]
_ = a -> IO a
a -> IO a'
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
class (Preparer a prepared) => ToRunCmd a prepared where
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
class (Proc a) => Connectable a where
type Conn a = (conn :: Type) | conn -> a
openConn :: ProcHandle a -> IO (Conn a)
closeConn :: Conn a -> IO ()
closeConn = IO () -> Conn a -> IO ()
forall a b. a -> b -> a
const (IO () -> Conn a -> IO ()) -> IO () -> Conn a -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
class (KnownSymbol (Image a), KnownSymbol (Name a)) => Proc a where
type Image a :: Symbol
type Name a = (labelName :: Symbol) | labelName -> a
runArgs :: [Text]
runArgs = [Text]
forall a. Monoid a => a
mempty
uriOf :: HostIpAddress -> SvcURI
reset :: ProcHandle a -> IO ()
ping :: ProcHandle a -> IO Pinged
pingCount :: Natural
pingCount = Natural
4
pingGap :: Natural
pingGap = Natural
1000000
data Pinged
=
OK
|
NotOK
|
PingFailed Text
deriving (Pinged -> Pinged -> Bool
(Pinged -> Pinged -> Bool)
-> (Pinged -> Pinged -> Bool) -> Eq Pinged
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Pinged -> Pinged -> Bool
== :: Pinged -> Pinged -> Bool
$c/= :: Pinged -> Pinged -> Bool
/= :: Pinged -> Pinged -> Bool
Eq, Int -> Pinged -> ShowS
[Pinged] -> ShowS
Pinged -> FilePath
(Int -> Pinged -> ShowS)
-> (Pinged -> FilePath) -> ([Pinged] -> ShowS) -> Show Pinged
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pinged -> ShowS
showsPrec :: Int -> Pinged -> ShowS
$cshow :: Pinged -> FilePath
show :: Pinged -> FilePath
$cshowList :: [Pinged] -> ShowS
showList :: [Pinged] -> ShowS
Show)
nameOf :: forall a. (Proc a) => a -> Text
nameOf :: forall a. Proc a => a -> Text
nameOf a
_ = FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Proxy (Name a) -> FilePath
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> FilePath
symbolVal (Proxy (Name a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Name a))
runArgs' :: forall a. (Proc a) => a -> [Text]
runArgs' :: forall a. Proc a => a -> [Text]
runArgs' a
_ = forall a. Proc a => [Text]
runArgs @a
pingCount' :: forall a. (Proc a) => a -> Natural
pingCount' :: forall a. Proc a => a -> Natural
pingCount' a
_ = forall a. Proc a => Natural
pingCount @a
pingGap' :: forall a. (Proc a) => a -> Natural
pingGap' :: forall a. Proc a => a -> Natural
pingGap' a
_ = forall a. Proc a => Natural
pingGap @a
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
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 = [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Text]
forall a. Monoid a => a
mempty Text -> [Text]
forall {a}. IsString a => a -> [a]
toNetworkArgs Maybe Text
ntwkMb
in [Text
"run", Text
"-d"] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> forall a. Proc a => [Text]
nameArg @a [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
networkArg [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> a -> prepared -> [Text]
forall a prepared. ToRunCmd a prepared => a -> prepared -> [Text]
toRunCmd a
x prepared
prep [Text] -> [Text] -> [Text]
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 (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Proxy (Image a) -> FilePath
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> FilePath
symbolVal (Proxy (Image a) -> FilePath) -> Proxy (Image a) -> FilePath
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @(Image a)
nameArg :: forall a. (Proc a) => [Text]
nameArg :: forall a. Proc a => [Text]
nameArg = [Text
"--name", FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Proxy (Name a) -> FilePath
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> FilePath
symbolVal (Proxy (Name a) -> FilePath) -> Proxy (Name a) -> FilePath
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @(Name a)]
type HostIpAddress = Text
type SvcURI = C8.ByteString
startup :: (ProcPlus a prepared) => a -> IO (ProcHandle a)
startup :: forall a prepared. ProcPlus a prepared => a -> IO (ProcHandle a)
startup = Maybe Text -> [SlimHandle] -> a -> IO (ProcHandle a)
forall a prepared.
ProcPlus a prepared =>
Maybe Text -> [SlimHandle] -> a -> IO (ProcHandle a)
startup' Maybe Text
forall a. Maybe a
Nothing [SlimHandle]
forall a. Monoid a => a
mempty
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
ntwkMb [SlimHandle]
addrs a
x = do
prepared
x' <- [SlimHandle] -> a -> IO prepared
forall a prepared.
Preparer a prepared =>
[SlimHandle] -> a -> IO prepared
prepare [SlimHandle]
addrs a
x
let fullArgs :: [FilePath]
fullArgs = (Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
Text.unpack ([Text] -> [FilePath]) -> [Text] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ a -> prepared -> Maybe Text -> [Text]
forall a prepared.
(Proc a, ToRunCmd a prepared) =>
a -> prepared -> Maybe Text -> [Text]
dockerCmdArgs a
x prepared
x' Maybe Text
ntwkMb
isGarbage :: Char -> Bool
isGarbage = (Char -> FilePath -> Bool) -> FilePath -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> FilePath -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char
'\'', Char
'\n']
trim :: ShowS
trim = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isGarbage ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isGarbage
Text -> IO ()
printDebug (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
fullArgs
CreateProcess
runCmd <- [FilePath] -> IO CreateProcess
createDockerCmdProcess [FilePath]
fullArgs
FilePath
hPid <- ShowS
trim ShowS -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CreateProcess -> FilePath -> IO FilePath
readCreateProcess CreateProcess
runCmd FilePath
""
Text
hAddr <-
FilePath -> Text
Text.pack (FilePath -> Text) -> ShowS -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
trim
(FilePath -> Text) -> IO FilePath -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess
FilePath
"docker"
[ FilePath
"inspect"
, FilePath
hPid
, FilePath
"--format"
, FilePath
"'{{range .NetworkSettings.Networks}}{{.IPAddress}}{{end}}'"
]
FilePath
""
let h :: ProcHandle a
h = ProcHandle {hProc :: a
hProc = a
x, FilePath
hPid :: FilePath
hPid :: FilePath
hPid, hUri :: SvcURI
hUri = a -> Text -> SvcURI
forall a. Proc a => a -> Text -> SvcURI
uriOf' a
x Text
hAddr, Text
hAddr :: Text
hAddr :: Text
hAddr}
(ProcHandle a -> IO Pinged
forall a. Proc a => ProcHandle a -> IO Pinged
nPings ProcHandle a
h IO Pinged -> IO () -> IO Pinged
forall a b. IO a -> IO b -> IO a
`onException` ProcHandle a -> IO ()
forall p. ProcHandle p -> IO ()
terminate ProcHandle a
h) IO Pinged -> (Pinged -> IO (ProcHandle a)) -> IO (ProcHandle a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Pinged
OK -> ProcHandle a -> IO (ProcHandle a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcHandle a
h
Pinged
pinged -> do
ProcHandle a -> IO ()
forall p. ProcHandle p -> IO ()
terminate ProcHandle a
h
FilePath -> IO (ProcHandle a)
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO (ProcHandle a)) -> FilePath -> IO (ProcHandle a)
forall a b. (a -> b) -> a -> b
$ a -> Pinged -> FilePath
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:" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
Text.unpack (a -> Text
forall a. Proc a => a -> Text
nameOf a
p) FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
":could not be pinged"
pingedMsg a
p (PingFailed Text
err) =
FilePath
"tmp proc:"
FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
Text.unpack (a -> Text
forall a. Proc a => a -> Text
nameOf a
p)
FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
":ping failed:"
FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
Text.unpack Text
err
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 (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"toPinged:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (e -> FilePath
forall a. Show a => a -> FilePath
show e
ex)
Pinged -> IO Pinged
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
NotOK
in (IO a
action IO a -> IO Pinged -> IO Pinged
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pinged -> IO Pinged
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
OK) IO Pinged -> (e -> IO Pinged) -> IO Pinged
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` e -> IO Pinged
handler
nPings :: (Proc a) => ProcHandle a -> IO Pinged
nPings :: forall a. Proc a => ProcHandle a -> IO Pinged
nPings h :: ProcHandle a
h@ProcHandle {hProc :: forall a. ProcHandle a -> a
hProc = a
p} =
let
count :: Int
count = Natural -> Int
forall a. Enum a => a -> Int
fromEnum (Natural -> Int) -> Natural -> Int
forall a b. (a -> b) -> a -> b
$ a -> Natural
forall a. Proc a => a -> Natural
pingCount' a
p
gap :: Int
gap = Natural -> Int
forall a. Enum a => a -> Int
fromEnum (Natural -> Int) -> Natural -> Int
forall a b. (a -> b) -> a -> b
$ a -> Natural
forall a. Proc a => a -> Natural
pingGap' a
p
badMsg :: Text -> Text
badMsg Text
x = Text
"tmp.proc: could not start " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Proc a => a -> Text
nameOf a
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; uncaught exception :" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x
badErr :: Text -> IO ()
badErr Text
x = Text -> IO ()
printDebug (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
badMsg Text
x
lastMsg :: Text
lastMsg = Text
"tmp.proc: could not start " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Proc a => a -> Text
nameOf a
p Text -> Text -> Text
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 #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (a -> FilePath
forall a. Show a => a -> FilePath
show a
i) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed; will retry"
nthErr :: Int -> IO ()
nthErr Int
n = Text -> IO ()
printDebug (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Text
forall {a}. Show a => a -> Text
pingMsg (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n
ping' :: ProcHandle a -> IO Pinged
ping' ProcHandle a
x =
ProcHandle a -> IO Pinged
forall a. Proc a => ProcHandle a -> IO Pinged
ping ProcHandle a
x
IO Pinged -> (SomeException -> IO Pinged) -> IO Pinged
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 (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
Text -> IO ()
badErr Text
errMsg
Pinged -> IO Pinged
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pinged -> IO Pinged) -> Pinged -> IO Pinged
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 IO Pinged -> (Pinged -> IO Pinged) -> IO Pinged
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Pinged
OK -> Pinged -> IO Pinged
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
OK
Pinged
NotOK | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> IO ()
lastErr IO () -> IO Pinged -> IO Pinged
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pinged -> IO Pinged
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
NotOK
Pinged
NotOK -> Int -> IO ()
threadDelay Int
gap IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
nthErr Int
n IO () -> IO Pinged -> IO Pinged
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO Pinged
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
Pinged
err -> Pinged -> IO Pinged
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
err
in
Int -> IO Pinged
go Int
count
type HasHandle aProc procs =
( Proc aProc
, AreProcs procs
, IsInProof (ProcHandle aProc) (Proc2Handle procs)
)
type HasNamedHandle name a procs =
( name ~ Name a
, Proc a
, AreProcs procs
, MemberKV name (ProcHandle a) (Handle2KV (Proc2Handle procs))
)
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 = IO (Conn a) -> (Conn a -> IO ()) -> (Conn a -> IO b) -> IO b
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (ProcHandle a -> IO (Conn a)
forall a. Connectable a => ProcHandle a -> IO (Conn a)
openConn ProcHandle a
handle) Conn a -> IO ()
forall a. Connectable a => Conn a -> IO ()
closeConn
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
)
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 = Proxy names
-> HList (Handle2KV (SortHandles (Proc2Handle someProcs)))
-> HList (Proc2Handle namedProcs)
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 (HList (Handle2KV (SortHandles (Proc2Handle someProcs)))
-> HList (Proc2Handle namedProcs))
-> HList (Handle2KV (SortHandles (Proc2Handle someProcs)))
-> HList (Proc2Handle namedProcs)
forall a b. (a -> b) -> a -> b
$ HandlesOf someProcs
-> HList (Handle2KV (SortHandles (Proc2Handle someProcs)))
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 = HList ordered -> HList (Proc2Handle procs)
forall (sorted :: [*]) (handles :: [*]) (ps :: [*]).
(sorted ~ SortHandles handles, handles ~ Proc2Handle ps,
ReorderH sorted handles) =>
HList sorted -> HList handles
unsortHandles (HList ordered -> HList (Proc2Handle procs))
-> HList ordered -> HList (Proc2Handle procs)
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
class HandleOf a procs b where
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) Proxy (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) (HList (Handle2KV (Proc2Handle procs)) -> ProcHandle p)
-> HList (Handle2KV (Proc2Handle procs)) -> ProcHandle p
forall a b. (a -> b) -> a -> b
$ HandlesOf procs -> HList (Handle2KV (Proc2Handle procs))
forall (handles :: [*]) (xs :: [*]).
(handles ~ Proc2Handle xs, AreProcs xs) =>
HList handles -> HList (Handle2KV handles)
toKVs HandlesOf procs
xs
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 = (ProcHandle namedConn -> (Conn namedConn -> IO b) -> IO b)
-> (Conn namedConn -> IO b) -> ProcHandle namedConn -> IO b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ProcHandle namedConn -> (Conn namedConn -> IO b) -> IO b
forall a b.
Connectable a =>
ProcHandle a -> (Conn a -> IO b) -> IO b
withTmpConn Conn namedConn -> IO b
action (ProcHandle namedConn -> IO b) -> ProcHandle namedConn -> IO b
forall a b. (a -> b) -> a -> b
$ Proxy idx -> HandlesOf procs -> ProcHandle namedConn
forall {k} (a :: k) (procs :: [*]) b.
HandleOf a procs b =>
Proxy a -> HandlesOf procs -> ProcHandle b
handleOf Proxy idx
proxy HandlesOf procs
xs
class IxReset a procs where
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 = ProcHandle a -> IO ()
forall a. Proc a => ProcHandle a -> IO ()
reset (ProcHandle a -> IO ()) -> ProcHandle a -> IO ()
forall a b. (a -> b) -> a -> b
$ forall (k :: Symbol) t (xs :: [*]).
MemberKV k t xs =>
HList xs -> t
select @name @(ProcHandle a) (HList (Handle2KV (Proc2Handle procs)) -> ProcHandle a)
-> HList (Handle2KV (Proc2Handle procs)) -> ProcHandle a
forall a b. (a -> b) -> a -> b
$ HandlesOf procs -> HList (Handle2KV (Proc2Handle procs))
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 = ProcHandle p -> IO ()
forall a. Proc a => ProcHandle a -> IO ()
reset (ProcHandle p -> IO ()) -> ProcHandle p -> IO ()
forall a b. (a -> b) -> a -> b
$ forall y (xs :: [*]). IsInProof y xs => Proxy y -> HList xs -> y
hOf @(ProcHandle p) Proxy (ProcHandle p)
forall {k} (t :: k). Proxy t
Proxy HandlesOf procs
xs
class IxPing a procs where
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 = ProcHandle a -> IO Pinged
forall a. Proc a => ProcHandle a -> IO Pinged
ping (ProcHandle a -> IO Pinged) -> ProcHandle a -> IO Pinged
forall a b. (a -> b) -> a -> b
$ forall (k :: Symbol) t (xs :: [*]).
MemberKV k t xs =>
HList xs -> t
select @name @(ProcHandle a) (HList (Handle2KV (Proc2Handle procs)) -> ProcHandle a)
-> HList (Handle2KV (Proc2Handle procs)) -> ProcHandle a
forall a b. (a -> b) -> a -> b
$ HandlesOf procs -> HList (Handle2KV (Proc2Handle procs))
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 = ProcHandle p -> IO Pinged
forall a. Proc a => ProcHandle a -> IO Pinged
ping (ProcHandle p -> IO Pinged) -> ProcHandle p -> IO Pinged
forall a b. (a -> b) -> a -> b
$ forall y (xs :: [*]). IsInProof y xs => Proxy y -> HList xs -> y
hOf @(ProcHandle p) Proxy (ProcHandle p)
forall {k} (t :: k). Proxy t
Proxy HandlesOf procs
xs
class IxUriOf a procs where
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 = ProcHandle a -> SvcURI
forall a. ProcHandle a -> SvcURI
hUri (ProcHandle a -> SvcURI) -> ProcHandle a -> SvcURI
forall a b. (a -> b) -> a -> b
$ forall (k :: Symbol) t (xs :: [*]).
MemberKV k t xs =>
HList xs -> t
select @name @(ProcHandle a) (HList (Handle2KV (Proc2Handle procs)) -> ProcHandle a)
-> HList (Handle2KV (Proc2Handle procs)) -> ProcHandle a
forall a b. (a -> b) -> a -> b
$ HandlesOf procs -> HList (Handle2KV (Proc2Handle procs))
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 = ProcHandle p -> SvcURI
forall a. ProcHandle a -> SvcURI
hUri (ProcHandle p -> SvcURI) -> ProcHandle p -> SvcURI
forall a b. (a -> b) -> a -> b
$ forall y (xs :: [*]). IsInProof y xs => Proxy y -> HList xs -> y
hOf @(ProcHandle p) Proxy (ProcHandle p)
forall {k} (t :: k). Proxy t
Proxy HandlesOf procs
xs
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 = SomeHandles handles -> HList handles -> HList (Handle2KV handles)
forall (as :: [*]).
SomeHandles as -> HList as -> HList (Handle2KV as)
go (SomeHandles handles -> HList handles -> HList (Handle2KV handles))
-> SomeHandles handles
-> HList handles
-> HList (Handle2KV handles)
forall a b. (a -> b) -> a -> b
$ SomeProcs xs -> SomeHandles (Proc2Handle xs)
forall (as :: [*]). SomeProcs as -> SomeHandles (Proc2Handle as)
p2h SomeProcs xs
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 '[]
HList (Handle2KV as)
HNil
go (SomeHandlesCons SomeHandles as
cons) (anyTy
x `HCons` HList manyTys
y) = ProcHandle a -> KV (Name a) (ProcHandle a)
forall a. Proc a => ProcHandle a -> KV (Name a) (ProcHandle a)
toKV anyTy
ProcHandle a
x KV (Name a) (ProcHandle a)
-> HList (Handle2KV as)
-> HList (KV (Name a) (ProcHandle a) : Handle2KV as)
forall anyTy (manyTys :: [*]).
anyTy -> HList manyTys -> HList (anyTy : manyTys)
`HCons` SomeHandles as -> HList as -> HList (Handle2KV as)
forall (as :: [*]).
SomeHandles as -> HList as -> HList (Handle2KV as)
go SomeHandles as
cons HList as
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 = HList (Proc2Handle sortedProcs)
-> HList (Handle2KV (Proc2Handle sortedProcs))
forall (handles :: [*]) (xs :: [*]).
(handles ~ Proc2Handle xs, AreProcs xs) =>
HList handles -> HList (Handle2KV handles)
toKVs (HList (Proc2Handle sortedProcs)
-> HList (Handle2KV (Proc2Handle sortedProcs)))
-> HList (Proc2Handle sortedProcs)
-> HList (Handle2KV (Proc2Handle sortedProcs))
forall a b. (a -> b) -> a -> b
$ HList handles -> HList (Proc2Handle sortedProcs)
forall (handles :: [*]) (ps :: [*]) (sorted :: [*]).
(handles ~ Proc2Handle ps, sorted ~ SortHandles handles,
ReorderH handles sorted) =>
HList handles -> HList sorted
sortHandles HList handles
procHandles
toKV :: (Proc a) => ProcHandle a -> KV (Name a) (ProcHandle a)
toKV :: forall a. Proc a => ProcHandle a -> KV (Name a) (ProcHandle a)
toKV = ProcHandle a -> KV (Name a) (ProcHandle a)
forall b (a :: Symbol). b -> KV a b
V
type family Proc2Handle (as :: [Type]) = (handleTys :: [Type]) | handleTys -> as where
Proc2Handle '[] = '[]
Proc2Handle (a ': as) = ProcHandle a ': Proc2Handle as
type HandlesOf procs = HList (Proc2Handle procs)
type NetworkHandlesOf procs = (Text, HandlesOf procs)
type family Proc2Name (as :: [Type]) = (nameTys :: [Symbol]) | nameTys -> as where
Proc2Name '[] = '[]
Proc2Name (a ': as) = Name a ': Proc2Name as
type family Handle2KV (ts :: [Type]) = (kvTys :: [Type]) | kvTys -> ts where
Handle2KV '[] = '[]
Handle2KV (ProcHandle t ': ts) = KV (Name t) (ProcHandle t) ': Handle2KV ts
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 = SomeProcs as -> SomeProcs (a : as)
forall a as (as :: [*]).
(ProcPlus a as, AreProcs as, IsAbsent a as) =>
SomeProcs as -> SomeProcs (a : as)
SomeProcsCons SomeProcs as
forall (as :: [*]). AreProcs as => SomeProcs as
procProof
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 '[]
SomeHandles (Proc2Handle as)
SomeHandlesNil
p2h (SomeProcsCons SomeProcs as
cons) = SomeHandles (Proc2Handle as)
-> SomeHandles (ProcHandle a : Proc2Handle as)
forall a as (as :: [*]).
ProcPlus a as =>
SomeHandles as -> SomeHandles (ProcHandle a : as)
SomeHandlesCons (SomeProcs as -> SomeHandles (Proc2Handle as)
forall (as :: [*]). SomeProcs as -> SomeHandles (Proc2Handle as)
p2h SomeProcs as
cons)
data SomeProcs (as :: [Type]) where
SomeProcsNil :: SomeProcs '[]
SomeProcsCons :: (ProcPlus a prepared, AreProcs as, IsAbsent a as) => SomeProcs as -> SomeProcs (a ': as)
class Connectables as where
connProof :: Uniquely Connectable Connectables as
instance Connectables '[] where
connProof :: Uniquely Connectable Connectables '[]
connProof = Uniquely Connectable Connectables '[]
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 = Uniquely Connectable Connectables as
-> Uniquely Connectable Connectables (a : as)
forall a (as :: [*]) (f :: * -> Constraint)
(fs :: [*] -> Constraint).
(IsAbsent a as, f a, fs as) =>
Uniquely f fs as -> Uniquely f fs (a : as)
UniquelyCons Uniquely Connectable Connectables as
forall (as :: [*]).
Connectables as =>
Uniquely Connectable Connectables as
connProof
type family ConnsOf (cs :: [Type]) = (conns :: [Type]) | conns -> cs where
ConnsOf '[] = '[]
ConnsOf (c ': cs) = Conn c ': ConnsOf cs
openAll :: (Connectables xs) => HandlesOf xs -> IO (HList (ConnsOf xs))
openAll :: forall (xs :: [*]).
Connectables xs =>
HandlesOf xs -> IO (HList (ConnsOf xs))
openAll = Uniquely Connectable Connectables xs
-> HList (Proc2Handle xs) -> IO (HList (ConnsOf xs))
forall (as :: [*]).
Uniquely Connectable Connectables as
-> HandlesOf as -> IO (HList (ConnsOf as))
go Uniquely Connectable Connectables xs
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 = HList '[] -> IO (HList '[])
forall a. a -> IO a
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 <- ProcHandle a -> IO (Conn a)
forall a. Connectable a => ProcHandle a -> IO (Conn a)
openConn anyTy
ProcHandle a
x
HList (ConnsOf as)
others <- Uniquely Connectable Connectables as
-> HandlesOf as -> IO (HList (ConnsOf as))
forall (as :: [*]).
Uniquely Connectable Connectables as
-> HandlesOf as -> IO (HList (ConnsOf as))
go Uniquely Connectable Connectables as
cons HList manyTys
HandlesOf as
y IO (HList (ConnsOf as)) -> IO () -> IO (HList (ConnsOf as))
forall a b. IO a -> IO b -> IO a
`onException` Conn a -> IO ()
forall a. Connectable a => Conn a -> IO ()
closeConn Conn a
c
HList (Conn a : ConnsOf as) -> IO (HList (Conn a : ConnsOf as))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HList (Conn a : ConnsOf as) -> IO (HList (Conn a : ConnsOf as)))
-> HList (Conn a : ConnsOf as) -> IO (HList (Conn a : ConnsOf as))
forall a b. (a -> b) -> a -> b
$ Conn a
c Conn a -> HList (ConnsOf as) -> HList (Conn a : ConnsOf as)
forall anyTy (manyTys :: [*]).
anyTy -> HList manyTys -> HList (anyTy : manyTys)
`HCons` HList (ConnsOf as)
others
closeAll :: (Connectables procs) => HList (ConnsOf procs) -> IO ()
closeAll :: forall (procs :: [*]).
Connectables procs =>
HList (ConnsOf procs) -> IO ()
closeAll = Uniquely Connectable Connectables procs
-> HList (ConnsOf procs) -> IO ()
forall (as :: [*]).
Uniquely Connectable Connectables as -> HList (ConnsOf as) -> IO ()
go Uniquely Connectable Connectables procs
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 = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
go (UniquelyCons Uniquely Connectable Connectables as
cons) (anyTy
x `HCons` HList manyTys
y) = Conn a -> IO ()
forall a. Connectable a => Conn a -> IO ()
closeConn anyTy
Conn a
x IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Uniquely Connectable Connectables as -> HList (ConnsOf as) -> IO ()
forall (as :: [*]).
Uniquely Connectable Connectables as -> HList (ConnsOf as) -> IO ()
go Uniquely Connectable Connectables as
cons HList manyTys
HList (ConnsOf as)
y
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 = IO (HList (ConnsOf procs))
-> (HList (ConnsOf procs) -> IO ())
-> (HList (ConnsOf procs) -> IO b)
-> IO b
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (HandlesOf procs -> IO (HList (ConnsOf procs))
forall (xs :: [*]).
Connectables xs =>
HandlesOf xs -> IO (HList (ConnsOf xs))
openAll HandlesOf procs
handles) HList (ConnsOf procs) -> IO ()
forall (procs :: [*]).
Connectables procs =>
HList (ConnsOf procs) -> IO ()
closeAll
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 = HandlesOf conns -> (HList (ConnsOf conns) -> IO b) -> IO b
forall (procs :: [*]) b.
Connectables procs =>
HandlesOf procs -> (HList (ConnsOf procs) -> IO b) -> IO b
withConns (HandlesOf conns -> (HList (ConnsOf conns) -> IO b) -> IO b)
-> (HList (Proc2Handle someProcs) -> HandlesOf conns)
-> HList (Proc2Handle someProcs)
-> (HList (ConnsOf conns) -> IO b)
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HList (Proc2Handle someProcs) -> HandlesOf conns
forall (xs :: [*]) (ys :: [*]).
ReorderH xs ys =>
HList xs -> HList ys
hReorder
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 = HandlesOf namedConns
-> (HList (ConnsOf namedConns) -> IO b) -> IO b
forall (procs :: [*]) b.
Connectables procs =>
HandlesOf procs -> (HList (ConnsOf procs) -> IO b) -> IO b
withConns (HandlesOf namedConns
-> (HList (ConnsOf namedConns) -> IO b) -> IO b)
-> (HList (Proc2Handle someProcs) -> HandlesOf namedConns)
-> HList (Proc2Handle someProcs)
-> (HList (ConnsOf namedConns) -> IO b)
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy names
-> HList (Proc2Handle someProcs) -> HandlesOf namedConns
forall (names :: [Symbol]) (namedProcs :: [*]) (someProcs :: [*])
(sortedProcs :: [*]).
SomeNamedHandles names namedProcs someProcs sortedProcs =>
Proxy names -> HandlesOf someProcs -> HandlesOf namedProcs
manyNamed Proxy names
proxy
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 = HList handles -> HList sorted
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 = HList sorted -> HList handles
forall (xs :: [*]) (ys :: [*]).
ReorderH xs ys =>
HList xs -> HList ys
hReorder
type family SortHandles (xs :: [Type]) :: [Type] where
SortHandles '[] = '[]
SortHandles '[x] = '[x]
SortHandles '[x, y] = MergeHandles '[x] '[y]
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
CreateProcess -> IO CreateProcess
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CreateProcess -> IO CreateProcess)
-> CreateProcess -> IO CreateProcess
forall a b. (a -> b) -> a -> b
$ (FilePath -> [FilePath] -> CreateProcess
proc FilePath
"docker" [FilePath]
args) {std_err = UseHandle devNull'}
showDebug :: IO Bool
showDebug :: IO Bool
showDebug = Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust (Maybe FilePath -> Bool) -> IO (Maybe FilePath) -> IO Bool
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
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
canPrint (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
Text.hPutStrLn Handle
stderr Text
t
genNetworkName :: IO Text
genNetworkName :: IO Text
genNetworkName = Word16 -> Text
networkNameOf (Word16 -> Text) -> IO Word16 -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Word16
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
networkNameOf :: Word16 -> Text
networkNameOf :: Word16 -> Text
networkNameOf Word16
suffix = Builder
"tmp-proc-" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Word16
suffix Word16 -> Builder -> Builder
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]