{-# LANGUAGE AllowAmbiguousTypes    #-}
{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# 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 #-}

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

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

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

* Basically, @tmp-proc@ helps launch services used in integration test on docker

* While it's possible to write integration tests that use services hosted on
  docker /without/ @tmp-proc@, @tmp-proc@ aims to make writing those kind of
  tests easier, by providing types and combinators that take care of

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

This module does all that via its data types:

* A /'Proc'/ specifies a docker image that provides a service and other details
  related to its use in tests.

* A /'ProcHandle'/ is created whenever a service specifed by a /'Proc'/ is
started, and is used to access and eventually terminate the running service.

* Some @'Proc's@ will also be /'Connectable'/; these specify how access the
service via some /'Conn'-ection/ type.

-}
module System.TmpProc.Docker
  ( -- * @'Proc'@
    Proc(..)
  , Pinged(..)
  , AreProcs
  , SomeProcs(..)
  , nameOf
  , startup
  , toPinged
  , uriOf'
  , runArgs'

    -- * @'ProcHandle'@
  , ProcHandle(..)
  , Proc2Handle
  , HandlesOf
  , startupAll
  , terminateAll
  , withTmpProcs
  , manyNamed
  , handleOf
  , ixReset
  , ixPing
  , ixUriOf
  , HasHandle
  , HasNamedHandle
  , SomeNamedHandles

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

    -- * Docker status
  , hasDocker

    -- * Aliases
  , HostIpAddress
  , SvcURI

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

import           Control.Concurrent       (threadDelay)
import           Control.Exception        (SomeException, bracket, catch,
                                           onException, Exception)
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.Exit              (ExitCode (..))
import           System.Environment       (lookupEnv)
import           System.IO                (stderr, Handle, openBinaryFile, IOMode(..))
import           System.Process           (StdStream (..), proc, readProcess,
                                           std_err, std_out, waitForProcess,
                                           withCreateProcess, readCreateProcess, CreateProcess)

import           System.TmpProc.TypeLevel (Drop, HList (..), HalfOf, IsAbsent,
                                           IsInProof, KV (..), LengthOf,
                                           ManyMemberKV, MemberKV,
                                           ReorderH (..), SortSymbols, Take,
                                           hOf, select, selectMany, (&:))


{-| Determines if the docker daemon is accessible. -}
hasDocker :: IO Bool
hasDocker :: IO Bool
hasDocker = do
  let rawSystemNoStdout :: FilePath -> [FilePath] -> IO ExitCode
rawSystemNoStdout FilePath
cmd [FilePath]
args = 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 :: StdStream
std_out = StdStream
CreatePipe , std_err :: StdStream
std_err = StdStream
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 (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"]


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


{-| Provides access to a 'Proc' that has been started. -}
data ProcHandle a = ProcHandle
  { ProcHandle a -> a
hProc :: !a
  , ProcHandle a -> FilePath
hPid  :: !String
  , ProcHandle a -> SvcURI
hUri  :: !SvcURI
  , ProcHandle a -> HostIpAddress
hAddr :: !HostIpAddress
  }


{-| Start up processes for each 'Proc' type. -}
startupAll :: AreProcs procs => HList procs -> IO (HandlesOf procs)
startupAll :: HList procs -> IO (HandlesOf procs)
startupAll = SomeProcs procs -> HList procs -> IO (HandlesOf procs)
forall (as :: [*]). SomeProcs as -> HList as -> IO (HandlesOf as)
go SomeProcs procs
forall (as :: [*]). AreProcs as => SomeProcs as
procProof
  where
    go :: SomeProcs as -> HList as -> IO (HandlesOf as)
    go :: SomeProcs as -> HList as -> IO (HandlesOf as)
go SomeProcs as
SomeProcsNil HList as
HNil = HList '[] -> IO (HList '[])
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 <- anyTy -> IO (ProcHandle anyTy)
forall a. Proc a => a -> IO (ProcHandle a)
startup anyTy
x
      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 IO (HList (Proc2Handle as)) -> IO () -> IO (HList (Proc2Handle as))
forall a b. IO a -> IO b -> IO a
`onException` ProcHandle anyTy -> IO ()
forall p. ProcHandle p -> IO ()
terminate ProcHandle anyTy
h
      HList (ProcHandle anyTy : Proc2Handle as)
-> IO (HList (ProcHandle anyTy : Proc2Handle as))
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


{-| Terminate all processes owned by some @'ProcHandle's@. -}
terminateAll :: AreProcs procs => HandlesOf procs -> IO ()
terminateAll :: HandlesOf procs -> IO ()
terminateAll = SomeHandles (Proc2Handle procs) -> HandlesOf procs -> IO ()
forall (as :: [*]). SomeHandles as -> HList as -> IO ()
go (SomeHandles (Proc2Handle procs) -> HandlesOf procs -> IO ())
-> SomeHandles (Proc2Handle procs) -> HandlesOf procs -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeProcs procs -> SomeHandles (Proc2Handle procs)
forall (as :: [*]). SomeProcs as -> SomeHandles (Proc2Handle as)
p2h SomeProcs procs
forall (as :: [*]). AreProcs as => SomeProcs as
procProof
  where
    go :: SomeHandles as -> HList as -> IO ()
    go :: SomeHandles as -> HList as -> IO ()
go SomeHandles as
SomeHandlesNil HList as
HNil = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go (SomeHandlesCons SomeHandles as
cons) (anyTy
x `HCons` HList manyTys
y) = do
      ProcHandle a -> IO ()
forall p. ProcHandle p -> IO ()
terminate anyTy
ProcHandle a
x
      SomeHandles as -> HList as -> IO ()
forall (as :: [*]). SomeHandles as -> HList as -> IO ()
go SomeHandles as
cons HList as
HList manyTys
y


{-| Terminate the process owned by a @'ProcHandle's@. -}
terminate :: ProcHandle p -> IO ()
terminate :: 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
""


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

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

  {-| Close a connection to a 'Proc', -}
  closeConn :: Conn a -> IO ()
  closeConn = 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()


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

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

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

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

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

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

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

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


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

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

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

'startupAll' uses 'PingFailed' to report any unexpected exceptions that escape
'ping2'.

-}
data Pinged =
  {-| The service is running OK. -}
  OK

  {-| The service is not running. -}
  | NotOK

  {-| Contact to the service failed unexpectedly. -}
  | PingFailed Text

  deriving (Pinged -> Pinged -> Bool
(Pinged -> Pinged -> Bool)
-> (Pinged -> Pinged -> Bool) -> Eq Pinged
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
(Int -> Pinged -> ShowS)
-> (Pinged -> FilePath) -> ([Pinged] -> ShowS) -> Show Pinged
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Pinged] -> ShowS
$cshowList :: [Pinged] -> ShowS
show :: Pinged -> FilePath
$cshow :: Pinged -> FilePath
showsPrec :: Int -> Pinged -> ShowS
$cshowsPrec :: Int -> Pinged -> ShowS
Show)

{-| Name of a process. -}
nameOf :: forall a . (Proc a) => a -> Text
nameOf :: a -> HostIpAddress
nameOf a
_  = FilePath -> HostIpAddress
Text.pack (FilePath -> HostIpAddress) -> FilePath -> HostIpAddress
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))


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


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


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


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


{-| The full args of a @docker run@ command for starting up a 'Proc'. -}
dockerCmdArgs :: forall a . (Proc a) => [Text]
dockerCmdArgs :: [HostIpAddress]
dockerCmdArgs = [
  HostIpAddress
"run"
  , HostIpAddress
"-d"
  ]
  [HostIpAddress] -> [HostIpAddress] -> [HostIpAddress]
forall a. Semigroup a => a -> a -> a
<> Proc a => [HostIpAddress]
forall a. Proc a => [HostIpAddress]
runArgs @a
  [HostIpAddress] -> [HostIpAddress] -> [HostIpAddress]
forall a. Semigroup a => a -> a -> a
<> [Proc a => HostIpAddress
forall a. Proc a => HostIpAddress
imageText' @a]


imageText' :: forall a . (Proc a) => Text
imageText' :: HostIpAddress
imageText' = FilePath -> HostIpAddress
Text.pack (FilePath -> HostIpAddress) -> FilePath -> HostIpAddress
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)
forall k (t :: k). Proxy t
Proxy :: Proxy (Image a))


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


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


{-| Starts a 'Proc'.

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

Returns the 'ProcHandle' used to control the 'Proc' once a ping has succeeded.

-}
startup :: forall a . Proc a => a -> IO (ProcHandle a)
startup :: a -> IO (ProcHandle a)
startup a
x = do
  let fullArgs :: [HostIpAddress]
fullArgs = Proc a => [HostIpAddress]
forall a. Proc a => [HostIpAddress]
dockerCmdArgs @a
      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 (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
  CreateProcess
runCmd <- [FilePath] -> IO CreateProcess
dockerRun ((HostIpAddress -> FilePath) -> [HostIpAddress] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map HostIpAddress -> FilePath
Text.unpack [HostIpAddress]
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
""
  HostIpAddress
hAddr <- (FilePath -> HostIpAddress
Text.pack (FilePath -> HostIpAddress) -> ShowS -> FilePath -> HostIpAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
trim) (FilePath -> HostIpAddress) -> IO FilePath -> IO HostIpAddress
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 = HostIpAddress -> SvcURI
forall a. Proc a => HostIpAddress -> SvcURI
uriOf @a HostIpAddress
hAddr
      h :: ProcHandle a
h = ProcHandle :: forall a. a -> FilePath -> SvcURI -> HostIpAddress -> ProcHandle a
ProcHandle {hProc :: a
hProc=a
x, FilePath
hPid :: FilePath
hPid :: FilePath
hPid, SvcURI
hUri :: SvcURI
hUri :: SvcURI
hUri, HostIpAddress
hAddr :: HostIpAddress
hAddr :: HostIpAddress
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Pinged
OK     -> ProcHandle a -> IO (ProcHandle 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 (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 :: a -> Pinged -> FilePath
pingedMsg a
_ Pinged
OK = FilePath
""
pingedMsg a
p Pinged
NotOK = FilePath
"tmp proc:" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ (HostIpAddress -> FilePath
Text.unpack (HostIpAddress -> FilePath) -> HostIpAddress -> FilePath
forall a b. (a -> b) -> a -> b
$ a -> HostIpAddress
forall a. Proc a => a -> HostIpAddress
nameOf a
p) FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
":could not be pinged"
pingedMsg a
p (PingFailed HostIpAddress
err) = FilePath
"tmp proc:"
  FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ (HostIpAddress -> FilePath
Text.unpack (HostIpAddress -> FilePath) -> HostIpAddress -> FilePath
forall a b. (a -> b) -> a -> b
$ a -> HostIpAddress
forall a. Proc a => a -> HostIpAddress
nameOf a
p)
  FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
":ping failed:"
  FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ (HostIpAddress -> FilePath
Text.unpack HostIpAddress
err)


{-| Use an action that might throw an exception as a ping. -}
toPinged :: forall e a . Exception e => Proxy e -> IO a -> IO Pinged
toPinged :: Proxy e -> IO a -> IO Pinged
toPinged Proxy e
_ IO a
action = (IO a
action IO a -> IO Pinged -> IO Pinged
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pinged -> IO Pinged
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
_ :: e) -> Pinged -> IO Pinged
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
NotOK)


{-| Ping a 'ProcHandle' several times. -}
nPings :: Proc a => ProcHandle a -> IO Pinged
nPings :: 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 :: HostIpAddress -> HostIpAddress
badMsg HostIpAddress
x = HostIpAddress
"tmp.proc: could not start " HostIpAddress -> HostIpAddress -> HostIpAddress
forall a. Semigroup a => a -> a -> a
<> a -> HostIpAddress
forall a. Proc a => a -> HostIpAddress
nameOf a
p HostIpAddress -> HostIpAddress -> HostIpAddress
forall a. Semigroup a => a -> a -> a
<> HostIpAddress
"; uncaught exception :" HostIpAddress -> HostIpAddress -> HostIpAddress
forall a. Semigroup a => a -> a -> a
<> HostIpAddress
x
    badErr :: HostIpAddress -> IO ()
badErr HostIpAddress
x = HostIpAddress -> IO ()
printDebug (HostIpAddress -> IO ()) -> HostIpAddress -> IO ()
forall a b. (a -> b) -> a -> b
$ HostIpAddress -> HostIpAddress
badMsg HostIpAddress
x

    lastMsg :: HostIpAddress
lastMsg = HostIpAddress
"tmp.proc: could not start " HostIpAddress -> HostIpAddress -> HostIpAddress
forall a. Semigroup a => a -> a -> a
<> a -> HostIpAddress
forall a. Proc a => a -> HostIpAddress
nameOf a
p HostIpAddress -> HostIpAddress -> HostIpAddress
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 #" HostIpAddress -> HostIpAddress -> HostIpAddress
forall a. Semigroup a => a -> a -> a
<> (FilePath -> HostIpAddress
Text.pack (FilePath -> HostIpAddress) -> FilePath -> HostIpAddress
forall a b. (a -> b) -> a -> b
$ a -> FilePath
forall a. Show a => a -> FilePath
show a
i) HostIpAddress -> HostIpAddress -> HostIpAddress
forall a. Semigroup a => a -> a -> a
<> HostIpAddress
" failed; will retry"
    nthErr :: Int -> IO ()
nthErr Int
n  = HostIpAddress -> IO ()
printDebug (HostIpAddress -> IO ()) -> HostIpAddress -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> HostIpAddress
forall a. Show a => a -> HostIpAddress
pingMsg (Int -> HostIpAddress) -> Int -> HostIpAddress
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 :: HostIpAddress
errMsg = FilePath -> HostIpAddress
Text.pack (FilePath -> HostIpAddress) -> FilePath -> HostIpAddress
forall a b. (a -> b) -> a -> b
$ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
                                    HostIpAddress -> IO ()
badErr HostIpAddress
errMsg
                                    Pinged -> IO Pinged
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pinged -> IO Pinged) -> Pinged -> IO Pinged
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 IO Pinged -> (Pinged -> IO Pinged) -> IO Pinged
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Pinged
OK             -> Pinged -> IO Pinged
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pinged -> IO Pinged
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
NotOK
      Pinged
NotOK          -> Int -> IO ()
threadDelay Int
gap IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
nthErr Int
n IO () -> IO Pinged -> IO Pinged
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 (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
err

  in
    Int -> IO Pinged
go Int
count


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


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


{-| Run an action on a 'Connectable' handle as a callback on its 'Conn' -}
withTmpConn :: Connectable a => ProcHandle a -> (Conn a -> IO b) -> IO b
withTmpConn :: ProcHandle a -> (Conn a -> IO b) -> IO b
withTmpConn ProcHandle a
handle Conn a -> IO b
action = 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 Conn a -> IO b
action


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

  , ReorderH (SortHandles (Proc2Handle procs)) (Proc2Handle procs)
  , ReorderH (Proc2Handle someProcs) (Proc2Handle sortedProcs)

  , AreProcs sortedProcs
  , SortHandles (Proc2Handle someProcs) ~ Proc2Handle sortedProcs
  )


{-| Select the named @'ProcHandle's@ from an 'HList' of @'ProcHandle'@. -}
manyNamed
  :: SomeNamedHandles names namedProcs someProcs sortedProcs
  => Proxy names -> HandlesOf someProcs -> HandlesOf namedProcs
manyNamed :: Proxy names -> HandlesOf someProcs -> HandlesOf namedProcs
manyNamed Proxy names
proxy HandlesOf someProcs
xs = Proxy names
-> HList (Handle2KV (Proc2Handle sortedProcs))
-> HandlesOf 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 (Proc2Handle sortedProcs))
 -> HandlesOf namedProcs)
-> HList (Handle2KV (Proc2Handle sortedProcs))
-> HandlesOf namedProcs
forall a b. (a -> b) -> a -> b
$ HandlesOf someProcs -> HList (Handle2KV (Proc2Handle sortedProcs))
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 :: [*]) (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) -> HandlesOf procs
manyNamed' Proxy names
_ HList (Handle2KV someProcs)
kvs = HList ordered -> HandlesOf procs
forall (sorted :: [*]) (handles :: [*]) (ps :: [*]).
(sorted ~ SortHandles handles, handles ~ Proc2Handle ps,
 ReorderH sorted handles) =>
HList sorted -> HList handles
unsortHandles (HList ordered -> HandlesOf procs)
-> HList ordered -> HandlesOf procs
forall a b. (a -> b) -> a -> b
$ HList (Handle2KV someProcs) -> HList ordered
forall (ks :: [Symbol]) (ts :: [*]) (xs :: [*]).
ManyMemberKV ks ts xs =>
HList xs -> HList ts
selectMany @sortedNames @ordered HList (Handle2KV someProcs)
kvs


{-| Specifies how to obtain a 'ProcHandle' that is present in an HList.  -}
class HandleOf a procs b where

  {-| Obtain the handle matching the given type from a @'HList'@ of @'ProcHandle'@. -}
  handleOf :: Proxy a -> HandlesOf procs -> ProcHandle b

instance (HasHandle p procs) => HandleOf p procs p where
  handleOf :: Proxy p -> HandlesOf procs -> ProcHandle p
handleOf Proxy p
_ HandlesOf procs
procs = Proxy (ProcHandle p) -> HandlesOf procs -> ProcHandle 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 HandlesOf procs
procs

instance (HasNamedHandle name p procs) => HandleOf name procs p where
  handleOf :: Proxy name -> HandlesOf procs -> ProcHandle p
handleOf Proxy name
_ HandlesOf procs
xs = forall (xs :: [*]).
MemberKV name (ProcHandle p) xs =>
HList xs -> ProcHandle p
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


{-| Builds on 'handleOf'; gives the 'Conn' of the 'ProcHandle' to a callback. -}
withConnOf
  :: (HandleOf idx procs namedConn, Connectable namedConn)
  => Proxy idx -> HandlesOf procs -> (Conn namedConn -> IO b) -> IO b
withConnOf :: 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


{-| Specifies how to reset a 'ProcHandle' at an index in a list.  -}
class IxReset a procs where

  {-| Resets the handle whose index is specified by the proxy type. -}
  ixReset :: Proxy a -> HandlesOf procs -> IO ()

instance (HasNamedHandle name a procs) => IxReset name procs where
  ixReset :: Proxy name -> HandlesOf procs -> IO ()
ixReset Proxy name
_  HandlesOf procs
xs = 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 (xs :: [*]).
MemberKV name (ProcHandle a) xs =>
HList xs -> ProcHandle a
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
$ Proxy (ProcHandle p) -> HandlesOf procs -> ProcHandle 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 HandlesOf procs
xs


{-| Specifies how to ping a 'ProcHandle' at an index in a list.  -}
class IxPing a procs where

  {-| Pings the handle whose index is specified by the proxy type. -}
  ixPing :: Proxy a -> HandlesOf procs -> IO Pinged

instance (HasNamedHandle name a procs) => IxPing name procs where
  ixPing :: Proxy name -> HandlesOf procs -> IO Pinged
ixPing Proxy name
_  HandlesOf procs
xs = 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 (xs :: [*]).
MemberKV name (ProcHandle a) xs =>
HList xs -> ProcHandle a
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
$ Proxy (ProcHandle p) -> HandlesOf procs -> ProcHandle 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 HandlesOf procs
xs


{-| Specifies how to obtain the service URI a 'ProcHandle' at an index in a list.  -}
class IxUriOf a procs where

  {-| Obtains the service URI of the handle whose index is specified by the proxy type. -}
  ixUriOf :: Proxy a -> HandlesOf procs -> SvcURI

instance (HasNamedHandle name a procs) => IxUriOf name procs where
  ixUriOf :: Proxy name -> HandlesOf procs -> SvcURI
ixUriOf Proxy name
_  HandlesOf procs
xs = ProcHandle a -> SvcURI
forall a. ProcHandle a -> SvcURI
hUri (ProcHandle a -> SvcURI) -> ProcHandle a -> SvcURI
forall a b. (a -> b) -> a -> b
$ forall (xs :: [*]).
MemberKV name (ProcHandle a) xs =>
HList xs -> ProcHandle a
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
$ Proxy (ProcHandle p) -> HandlesOf procs -> ProcHandle 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 HandlesOf procs
xs


{-| Create a 'HList' of @'KV's@ from a 'HList' of @'ProcHandle's@. -}
toKVs :: (handles ~ Proc2Handle xs, AreProcs xs) => HList handles -> HList (Handle2KV handles)
toKVs :: 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 :: 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 :: HList handles -> HList (Handle2KV sorted)
toSortedKVs HList handles
procHandles = HList sorted -> HList (Handle2KV sorted)
forall (handles :: [*]) (xs :: [*]).
(handles ~ Proc2Handle xs, AreProcs xs) =>
HList handles -> HList (Handle2KV handles)
toKVs (HList sorted -> HList (Handle2KV sorted))
-> HList sorted -> HList (Handle2KV sorted)
forall a b. (a -> b) -> a -> b
$ HList handles -> HList sorted
forall (handles :: [*]) (ps :: [*]) (sorted :: [*]).
(handles ~ Proc2Handle ps, sorted ~ SortHandles handles,
 ReorderH handles sorted) =>
HList handles -> HList sorted
sortHandles HList handles
procHandles


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


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


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


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


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


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


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

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 = SomeProcs as -> SomeProcs (a : as)
forall a (as :: [*]).
(Proc a, IsAbsent a as) =>
SomeProcs as -> SomeProcs (a : as)
SomeProcsCons SomeProcs as
forall (as :: [*]). AreProcs as => SomeProcs as
procProof


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


p2h :: SomeProcs as -> SomeHandles (Proc2Handle as)
p2h :: 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 :: [*]).
Proc a =>
SomeHandles as -> SomeHandles (ProcHandle a : as)
SomeHandlesCons (SomeProcs as -> SomeHandles (Proc2Handle as)
forall (as :: [*]). SomeProcs as -> SomeHandles (Proc2Handle as)
p2h SomeProcs as
cons)


{-| Used by @'Connectables'@ to prove a list of types just contains @'Connectable's@. -}
data SomeConns (as :: [*]) where
  SomeConnsNil  :: SomeConns '[]
  SomeConnsCons :: (Connectable a, IsAbsent a as) => SomeConns as -> SomeConns (a ': as)


{-| Declares a proof that a list of types only contains @'Connectable's@. -}
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 = SomeConns as -> SomeConns (a : as)
forall a (as :: [*]).
(Connectable a, IsAbsent a as) =>
SomeConns as -> SomeConns (a : as)
SomeConnsCons SomeConns as
forall (as :: [*]). Connectables as => SomeConns as
connProof


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


{-| Open all the 'Connectable' types to corresponding 'Conn' types. -}
openAll :: Connectables xs => HandlesOf xs -> IO (HList (ConnsOf xs))
openAll :: HandlesOf xs -> IO (HList (ConnsOf xs))
openAll =  SomeConns xs -> HandlesOf xs -> IO (HList (ConnsOf xs))
forall (as :: [*]).
SomeConns as -> HandlesOf as -> IO (HList (ConnsOf as))
go SomeConns xs
forall (as :: [*]). Connectables as => SomeConns as
connProof
  where
    go :: SomeConns as -> HandlesOf as -> IO (HList (ConnsOf as))
    go :: SomeConns as -> HandlesOf as -> IO (HList (ConnsOf as))
go SomeConns as
SomeConnsNil HandlesOf as
HNil = HList '[] -> IO (HList '[])
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 <- ProcHandle a -> IO (Conn a)
forall a. Connectable a => ProcHandle a -> IO (Conn a)
openConn anyTy
ProcHandle a
x
      HList (ConnsOf as)
others <- SomeConns as -> HandlesOf as -> IO (HList (ConnsOf as))
forall (as :: [*]).
SomeConns as -> HandlesOf as -> IO (HList (ConnsOf as))
go SomeConns 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 (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


{-| Close some 'Connectable' types. -}
closeAll :: Connectables procs => HList (ConnsOf procs) -> IO ()
closeAll :: HList (ConnsOf procs) -> IO ()
closeAll = SomeConns procs -> HList (ConnsOf procs) -> IO ()
forall (as :: [*]). SomeConns as -> HList (ConnsOf as) -> IO ()
go SomeConns procs
forall (as :: [*]). Connectables as => SomeConns as
connProof
  where
    go :: SomeConns as -> HList (ConnsOf as) -> IO ()
    go :: SomeConns as -> HList (ConnsOf as) -> IO ()
go SomeConns as
SomeConnsNil HList (ConnsOf as)
HNil                  = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go (SomeConnsCons SomeConns 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeConns as -> HList (ConnsOf as) -> IO ()
forall (as :: [*]). SomeConns as -> HList (ConnsOf as) -> IO ()
go SomeConns as
cons HList manyTys
HList (ConnsOf as)
y


{-| Open some connections, use them in an action; close them. -}
withConns
  :: Connectables procs
  => HandlesOf procs
  -> (HList (ConnsOf procs) -> IO b)
  -> IO b
withConns :: 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


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


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


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

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

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

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

    MergeHandlesImpl (ProcHandle x ': xs) (ProcHandle y ': ys) leq =
        ProcHandle x ': MergeHandles xs (ProcHandle y ': ys)


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


dockerRun :: [String] -> IO CreateProcess
dockerRun :: [FilePath] -> IO CreateProcess
dockerRun [FilePath]
args = do
  Handle
devNull' <- IO Handle
devNull
  CreateProcess -> IO CreateProcess
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 :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
devNull' }


showDebug :: IO Bool
showDebug :: IO Bool
showDebug = (Maybe FilePath -> Bool) -> IO (Maybe FilePath) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> (FilePath -> Bool) -> Maybe FilePath -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> FilePath -> Bool
forall a b. a -> b -> a
const Bool
True)) (IO (Maybe FilePath) -> IO Bool) -> IO (Maybe FilePath) -> IO Bool
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
  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 -> HostIpAddress -> IO ()
Text.hPutStrLn Handle
stderr HostIpAddress
t