{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK prune not-home #-}
module System.TmpProc.Docker
(
Proc (..)
, Pinged (..)
, AreProcs
, SomeProcs (..)
, nameOf
, startup
, toPinged
, uriOf'
, runArgs'
, ProcHandle (..)
, Proc2Handle
, HandlesOf
, startupAll
, terminateAll
, withTmpProcs
, manyNamed
, handleOf
, ixReset
, ixPing
, ixUriOf
, HasHandle
, HasNamedHandle
, 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.Proxy (Proxy (..))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
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.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 =
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"]
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
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 -> HostIpAddress
hAddr :: !HostIpAddress
}
startupAll :: AreProcs procs => HList procs -> IO (HandlesOf procs)
startupAll :: forall (procs :: [*]).
AreProcs procs =>
HList procs -> IO (HandlesOf procs)
startupAll = forall (as :: [*]). SomeProcs as -> HList as -> IO (HandlesOf as)
go forall (as :: [*]). AreProcs as => SomeProcs as
procProof
where
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
ProcHandle anyTy
h <- forall a. Proc a => a -> IO (ProcHandle a)
startup anyTy
x
HList (Proc2Handle as)
others <- forall (as :: [*]). SomeProcs as -> HList as -> IO (HandlesOf as)
go SomeProcs as
cons HList manyTys
y forall a b. IO a -> IO b -> IO a
`onException` forall p. ProcHandle p -> IO ()
terminate ProcHandle anyTy
h
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
terminateAll :: AreProcs procs => HandlesOf procs -> IO ()
terminateAll :: forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAll = forall (as :: [*]). SomeHandles as -> HList as -> IO ()
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 -> IO ()
go :: forall (as :: [*]). SomeHandles as -> HList as -> IO ()
go SomeHandles as
SomeHandlesNil HList as
HNil = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
go (SomeHandlesCons SomeHandles as
cons) (anyTy
x `HCons` HList manyTys
y) = do
forall p. ProcHandle p -> IO ()
terminate anyTy
x
forall (as :: [*]). SomeHandles as -> HList as -> IO ()
go SomeHandles as
cons HList manyTys
y
terminate :: ProcHandle p -> IO ()
terminate :: forall p. ProcHandle p -> 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
""
class Proc a => Connectable a where
type Conn a = (conn :: Type) | conn -> a
openConn :: ProcHandle a -> IO (Conn a)
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 ()
class (KnownSymbol (Image a), KnownSymbol (Name a)) => Proc a where
type Image a :: Symbol
type Name a = (labelName :: Symbol) | labelName -> a
runArgs :: [Text]
runArgs = 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
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)
nameOf :: forall a. (Proc a) => a -> Text
nameOf :: forall a. Proc a => a -> HostIpAddress
nameOf a
_ = FilePath -> HostIpAddress
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))
runArgs' :: forall a. (Proc a) => a -> [Text]
runArgs' :: forall a. Proc a => a -> [HostIpAddress]
runArgs' a
_ = forall a. Proc a => [HostIpAddress]
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 -> HostIpAddress -> SvcURI
uriOf' a
_ = forall a. Proc a => HostIpAddress -> SvcURI
uriOf @a
dockerCmdArgs :: forall a. (Proc a) => [Text]
dockerCmdArgs :: forall a. Proc a => [HostIpAddress]
dockerCmdArgs =
[ HostIpAddress
"run"
, HostIpAddress
"-d"
]
forall a. Semigroup a => a -> a -> a
<> forall a. Proc a => [HostIpAddress]
runArgs @a
forall a. Semigroup a => a -> a -> a
<> [forall a. Proc a => HostIpAddress
imageText' @a]
imageText' :: forall a. (Proc a) => Text
imageText' :: forall a. Proc a => HostIpAddress
imageText' = FilePath -> HostIpAddress
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 (Image a))
type HostIpAddress = Text
type SvcURI = C8.ByteString
startup :: forall a. Proc a => a -> IO (ProcHandle a)
startup :: forall a. Proc a => a -> IO (ProcHandle a)
startup a
x = do
let fullArgs :: [HostIpAddress]
fullArgs = forall a. Proc a => [HostIpAddress]
dockerCmdArgs @a
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
CreateProcess
runCmd <- [FilePath] -> IO CreateProcess
dockerRun (forall a b. (a -> b) -> [a] -> [b]
map HostIpAddress -> FilePath
Text.unpack [HostIpAddress]
fullArgs)
FilePath
hPid <- ShowS
trim forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CreateProcess -> FilePath -> IO FilePath
readCreateProcess CreateProcess
runCmd FilePath
""
HostIpAddress
hAddr <-
FilePath -> HostIpAddress
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
hPid
, FilePath
"--format"
, FilePath
"'{{range .NetworkSettings.Networks}}{{.IPAddress}}{{end}}'"
]
FilePath
""
let hUri :: SvcURI
hUri = forall a. Proc a => HostIpAddress -> SvcURI
uriOf @a HostIpAddress
hAddr
h :: ProcHandle a
h = ProcHandle {hProc :: a
hProc = a
x, FilePath
hPid :: FilePath
hPid :: FilePath
hPid, SvcURI
hUri :: SvcURI
hUri :: SvcURI
hUri, HostIpAddress
hAddr :: HostIpAddress
hAddr :: HostIpAddress
hAddr}
(forall a. Proc a => ProcHandle a -> IO Pinged
nPings ProcHandle a
h forall a b. IO a -> IO b -> IO a
`onException` forall p. ProcHandle p -> 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 p. ProcHandle p -> 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]
++ HostIpAddress -> FilePath
Text.unpack (forall a. Proc a => a -> HostIpAddress
nameOf a
p) forall a. [a] -> [a] -> [a]
++ FilePath
":could not be pinged"
pingedMsg a
p (PingFailed HostIpAddress
err) =
FilePath
"tmp proc:"
forall a. [a] -> [a] -> [a]
++ HostIpAddress -> FilePath
Text.unpack (forall a. Proc a => a -> HostIpAddress
nameOf a
p)
forall a. [a] -> [a] -> [a]
++ FilePath
":ping failed:"
forall a. [a] -> [a] -> [a]
++ HostIpAddress -> FilePath
Text.unpack HostIpAddress
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 = (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
_ :: e) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
NotOK)
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 = 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 :: HostIpAddress -> HostIpAddress
badMsg HostIpAddress
x = HostIpAddress
"tmp.proc: could not start " forall a. Semigroup a => a -> a -> a
<> forall a. Proc a => a -> HostIpAddress
nameOf a
p forall a. Semigroup a => a -> a -> a
<> HostIpAddress
"; uncaught exception :" forall a. Semigroup a => a -> a -> a
<> HostIpAddress
x
badErr :: HostIpAddress -> IO ()
badErr HostIpAddress
x = HostIpAddress -> IO ()
printDebug forall a b. (a -> b) -> a -> b
$ HostIpAddress -> HostIpAddress
badMsg HostIpAddress
x
lastMsg :: HostIpAddress
lastMsg = HostIpAddress
"tmp.proc: could not start " forall a. Semigroup a => a -> a -> a
<> forall a. Proc a => a -> HostIpAddress
nameOf a
p forall a. Semigroup a => a -> a -> a
<> HostIpAddress
"; all pings failed"
lastErr :: IO ()
lastErr = HostIpAddress -> IO ()
printDebug HostIpAddress
lastMsg
pingMsg :: a -> HostIpAddress
pingMsg a
i = HostIpAddress
"tmp.proc: ping #" forall a. Semigroup a => a -> a -> a
<> FilePath -> HostIpAddress
Text.pack (forall a. Show a => a -> FilePath
show a
i) forall a. Semigroup a => a -> a -> a
<> HostIpAddress
" failed; will retry"
nthErr :: Int -> IO ()
nthErr Int
n = HostIpAddress -> IO ()
printDebug forall a b. (a -> b) -> a -> b
$ forall {a}. Show a => a -> HostIpAddress
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 :: HostIpAddress
errMsg = FilePath -> HostIpAddress
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show SomeException
e
HostIpAddress -> IO ()
badErr HostIpAddress
errMsg
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ HostIpAddress -> Pinged
PingFailed HostIpAddress
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
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 = 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
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 = 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
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) 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
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
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 = 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
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 = 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
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 = 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
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
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
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 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
data SomeProcs (as :: [Type]) where
SomeProcsNil :: SomeProcs '[]
SomeProcsCons :: (Proc a, IsAbsent a as) => SomeProcs as -> SomeProcs (a ': as)
class AreProcs as where
procProof :: SomeProcs as
instance AreProcs '[] where
procProof :: SomeProcs '[]
procProof = SomeProcs '[]
SomeProcsNil
instance (Proc a, AreProcs as, IsAbsent a as) => AreProcs (a ': as) where
procProof :: SomeProcs (a : as)
procProof = forall a (as :: [*]).
(Proc a, IsAbsent a as) =>
SomeProcs as -> SomeProcs (a : as)
SomeProcsCons forall (as :: [*]). AreProcs as => SomeProcs as
procProof
data SomeHandles (as :: [Type]) where
SomeHandlesNil :: SomeHandles '[]
SomeHandlesCons :: Proc a => 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 :: [*]).
Proc a =>
SomeHandles as -> SomeHandles (ProcHandle a : as)
SomeHandlesCons (forall (as :: [*]). SomeProcs as -> SomeHandles (Proc2Handle as)
p2h SomeProcs as
cons)
data SomeConns (as :: [Type]) where
SomeConnsNil :: SomeConns '[]
SomeConnsCons :: (Connectable a, IsAbsent a as) => SomeConns as -> SomeConns (a ': as)
class Connectables as where
connProof :: SomeConns as
instance Connectables '[] where
connProof :: SomeConns '[]
connProof = SomeConns '[]
SomeConnsNil
instance (Connectable a, Connectables as, IsAbsent a as) => Connectables (a ': as) where
connProof :: SomeConns (a : as)
connProof = forall a (as :: [*]).
(Connectable a, IsAbsent a as) =>
SomeConns as -> SomeConns (a : as)
SomeConnsCons forall (as :: [*]). Connectables as => SomeConns 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 = forall (as :: [*]).
SomeConns as -> HandlesOf as -> IO (HList (ConnsOf as))
go forall (as :: [*]). Connectables as => SomeConns as
connProof
where
go :: SomeConns as -> HandlesOf as -> IO (HList (ConnsOf as))
go :: forall (as :: [*]).
SomeConns as -> HandlesOf as -> IO (HList (ConnsOf as))
go SomeConns as
SomeConnsNil HList (Proc2Handle as)
HNil = forall (f :: * -> *) a. Applicative f => a -> f a
pure HList '[]
HNil
go (SomeConnsCons SomeConns 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 :: [*]).
SomeConns as -> HandlesOf as -> IO (HList (ConnsOf as))
go SomeConns 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
closeAll :: Connectables procs => HList (ConnsOf procs) -> IO ()
closeAll :: forall (procs :: [*]).
Connectables procs =>
HList (ConnsOf procs) -> IO ()
closeAll = forall (as :: [*]). SomeConns as -> HList (ConnsOf as) -> IO ()
go forall (as :: [*]). Connectables as => SomeConns as
connProof
where
go :: SomeConns as -> HList (ConnsOf as) -> IO ()
go :: forall (as :: [*]). SomeConns as -> HList (ConnsOf as) -> IO ()
go SomeConns as
SomeConnsNil HList (ConnsOf as)
HNil = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
go (SomeConnsCons SomeConns 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 :: [*]). SomeConns as -> HList (ConnsOf as) -> IO ()
go SomeConns as
cons HList manyTys
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 = 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
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
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
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
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
dockerRun :: [String] -> IO CreateProcess
dockerRun :: [FilePath] -> IO CreateProcess
dockerRun [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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a b. a -> b -> a
const Bool
True)) forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
debugEnv
debugEnv :: String
debugEnv :: FilePath
debugEnv = FilePath
"TMP_PROC_DEBUG"
printDebug :: Text -> IO ()
printDebug :: HostIpAddress -> IO ()
printDebug HostIpAddress
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 -> HostIpAddress -> IO ()
Text.hPutStrLn Handle
stderr HostIpAddress
t