packages feed

tmp-proc 0.5.2.1 → 0.5.3.0

raw patch · 8 files changed

+581/−466 lines, 8 files

Files

ChangeLog.md view
@@ -2,6 +2,10 @@  `tmp-proc` uses [PVP Versioning][1]. +## 0.5.3.0 -- 2023-08-11++* Add HList constructors `only` and `both` (alias: `&:&`)+ ## 0.5.2.1 -- 2023-07-17  * Avoid non-building dependencies in the testable README
README.lhs view
@@ -48,7 +48,7 @@ import           System.TmpProc        (HList (..), HandlesOf, HostIpAddress,                                         Pinged (..), Proc (..), ProcHandle (..),                                         SvcURI, manyNamed, startupAll, toPinged,-                                        (&:), ixPing, nameOf, terminateAll)+                                        only, ixPing, nameOf, terminateAll)  ``` @@ -116,7 +116,7 @@  spec :: Spec spec = describe ("Tmp.Proc: " ++ Text.unpack (nameOf HttpBinLhs)) $ do-  beforeAll (startupAll $ HttpBinLhs &: HNil) $ afterAll terminateAll $ do+  beforeAll (startupAll $ only HttpBinLhs) $ afterAll terminateAll $ do     context "When accessing the services in the list of test tmp procs" $ do        context "ixPing" $ do@@ -136,7 +136,7 @@    ```ignore   ...-  beforeAll (startupAll $ HttpBinLhs &: HNil) $ afterAll terminateAll $ do+  beforeAll (startupAll $ only HttpBinLhs) $ afterAll terminateAll $ do   ```     - this results in an `HList` of [ProcHandle][9] types being passed to each test.
src/System/TmpProc/Docker.hs view
@@ -1,23 +1,22 @@-{-# 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 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   #-}+{-# 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>@@ -47,14 +46,13 @@  * 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(..)+    Proc (..)+  , Pinged (..)   , AreProcs-  , SomeProcs(..)+  , SomeProcs (..)   , nameOf   , startup   , toPinged@@ -62,7 +60,7 @@   , runArgs'      -- * @'ProcHandle'@-  , ProcHandle(..)+  , ProcHandle (..)   , Proc2Handle   , HandlesOf   , startupAll@@ -78,7 +76,7 @@   , SomeNamedHandles      -- * @'Connectable'@-  , Connectable(..)+  , Connectable (..)   , Connectables   , withTmpConn   , withConnOf@@ -100,67 +98,101 @@   ) 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, (&:))+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+  , (&:)+  , (&:&)+  )  -{-| Determines if the docker daemon is accessible. -}+-- | Determines if the docker daemon is accessible. hasDocker :: IO Bool hasDocker = do-  let rawSystemNoStdout cmd args = withCreateProcess-        (proc cmd args) { std_out = CreatePipe , std_err = CreatePipe }-        (\_ _ _ -> waitForProcess)-        `catch`-        (\(_ :: IOError) -> return (ExitFailure 127))+  let rawSystemNoStdout cmd args =+        withCreateProcess+          (proc cmd args) {std_out = CreatePipe, std_err = CreatePipe}+          (\_ _ _ -> waitForProcess)+          `catch` (\(_ :: IOError) -> return (ExitFailure 127))       succeeds ExitSuccess = True-      succeeds _           = False+      succeeds _ = False    succeeds <$> rawSystemNoStdout "docker" ["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+-- | 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 procs = bracket (startupAll procs) terminateAll  -{-| Provides access to a 'Proc' that has been started. -}+-- | Provides access to a 'Proc' that has been started. data ProcHandle a = ProcHandle   { hProc :: !a-  , hPid  :: !String-  , hUri  :: !SvcURI+  , hPid :: !String+  , hUri :: !SvcURI   , hAddr :: !HostIpAddress   }  -{-| Start up processes for each 'Proc' type. -}+-- | Start up processes for each 'Proc' type. startupAll :: AreProcs procs => HList procs -> IO (HandlesOf procs) startupAll = go procProof   where@@ -172,7 +204,7 @@       pure $ h `HCons` others  -{-| Terminate all processes owned by some @'ProcHandle's@. -}+-- | Terminate all processes owned by some @'ProcHandle's@. terminateAll :: AreProcs procs => HandlesOf procs -> IO () terminateAll = go $ p2h procProof   where@@ -183,59 +215,68 @@       go cons y  -{-| Terminate the process owned by a @'ProcHandle's@. -}+-- | Terminate the process owned by a @'ProcHandle's@. terminate :: ProcHandle p -> IO () terminate handle = do   let pid = hPid handle-  void $ readProcess "docker" [ "stop", pid ] ""-  void $ readProcess "docker" [ "rm", pid ] ""+  void $ readProcess "docker" ["stop", pid] ""+  void $ readProcess "docker" ["rm", pid] ""  -{-| Specifies how to a get a connection to a 'Proc'. -}+-- | 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+  -- | The connection type.+  type Conn a = (conn :: Type) | conn -> a -  {-| Get a connection to the Proc via its 'ProcHandle'. -}++  -- | Get a connection to the Proc via its 'ProcHandle'.   openConn :: ProcHandle a -> IO (Conn a) -  {-| Close a connection to a 'Proc'. -}++  -- | Close a connection to a 'Proc'.   closeConn :: Conn a -> IO ()   closeConn = const $ pure ()  -{-| Specifies how to launch a temporary process using Docker. -}+-- | 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/ -}+  -- | 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/ -}++  -- | 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. -}++  -- | Additional arguments to the docker command that launches the tmp proc.   runArgs :: [Text]   runArgs = mempty -  {-| Determines the service URI of the process, when applicable. -}++  -- | Determines the service URI of the process, when applicable.   uriOf :: HostIpAddress -> SvcURI -  {-| Resets some state in a tmp proc service. -}++  -- | Resets some state in a tmp proc service.   reset :: ProcHandle a -> IO () -  {-| Checks if the tmp proc started ok.  -}++  -- | Checks if the tmp proc started ok.   ping :: ProcHandle a -> IO Pinged -  {-| Maximum number of pings to perform during startup. -}++  -- | Maximum number of pings to perform during startup.   pingCount :: Natural   pingCount = 4 -  {-| Number of milliseconds between pings. -}++  -- | Number of milliseconds between pings.   pingGap :: Natural   pingGap = 1000000  -{-| Indicates the result of pinging a 'Proc'.+{- | Indicates the result of pinging a 'Proc'.  If the ping succeeds, 'ping' should return 'OK'. @@ -244,56 +285,53 @@  'startupAll' uses 'PingFailed' to report any unexpected exceptions that escape 'ping'.- -}-data Pinged =-  {-| The service is running OK. -}-  OK--  {-| The service is not running. -}-  | NotOK--  {-| Contact to the service failed unexpectedly. -}-  | PingFailed Text-+data Pinged+  = -- | The service is running OK.+    OK+  | -- | The service is not running.+    NotOK+  | -- | Contact to the service failed unexpectedly.+    PingFailed Text   deriving (Eq, Show) -{-| Name of a process. -}-nameOf :: forall a . (Proc a) => a -> Text-nameOf _  = Text.pack $ symbolVal (Proxy :: Proxy (Name a)) +-- | Name of a process.+nameOf :: forall a. (Proc a) => a -> Text+nameOf _ = Text.pack $ symbolVal (Proxy :: Proxy (Name a)) -{-| Simplifies use of 'runArgs'. -}-runArgs' :: forall a . (Proc a) => a -> [Text]-runArgs' _  = runArgs @a +-- | Simplifies use of 'runArgs'.+runArgs' :: forall a. (Proc a) => a -> [Text]+runArgs' _ = runArgs @a -{-| Simplifies use of 'pingCount'. -}-pingCount' :: forall a . (Proc a) => a -> Natural-pingCount' _  = pingCount @a +-- | Simplifies use of 'pingCount'.+pingCount' :: forall a. (Proc a) => a -> Natural+pingCount' _ = pingCount @a -{-| Simplifies use of 'pingGap'. -}-pingGap' :: forall a . (Proc a) => a -> Natural-pingGap' _  = pingGap @a +-- | Simplifies use of 'pingGap'.+pingGap' :: forall a. (Proc a) => a -> Natural+pingGap' _ = pingGap @a -{-| Simplifies use of 'uriOf'. -}-uriOf' :: forall a . (Proc a) => a -> HostIpAddress -> SvcURI-uriOf' _ addr  = uriOf @a addr +-- | Simplifies use of 'uriOf'.+uriOf' :: forall a. (Proc a) => a -> HostIpAddress -> SvcURI+uriOf' _ = uriOf @a -{-| The full args of a @docker run@ command for starting up a 'Proc'. -}-dockerCmdArgs :: forall a . (Proc a) => [Text]-dockerCmdArgs = [-  "run"++-- | The full args of a @docker run@ command for starting up a 'Proc'.+dockerCmdArgs :: forall a. (Proc a) => [Text]+dockerCmdArgs =+  [ "run"   , "-d"   ]-  <> runArgs @a-  <> [imageText' @a]+    <> runArgs @a+    <> [imageText' @a]  -imageText' :: forall a . (Proc a) => Text+imageText' :: forall a. (Proc a) => Text imageText' = Text.pack $ symbolVal (Proxy :: Proxy (Image a))  @@ -305,31 +343,34 @@ type SvcURI = C8.ByteString  -{-| Starts a 'Proc'.+{- | 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 :: forall a. Proc a => a -> IO (ProcHandle a) startup x = do   let fullArgs = dockerCmdArgs @a       isGarbage = flip elem ['\'', '\n']       trim = dropWhileEnd isGarbage . dropWhile isGarbage   runCmd <- dockerRun (map Text.unpack fullArgs)   hPid <- trim <$> readCreateProcess runCmd ""-  hAddr <- (Text.pack . trim) <$> readProcess "docker"-    [ "inspect"-    , hPid-    , "--format"-    , "'{{range .NetworkSettings.Networks}}{{.IPAddress}}{{end}}'"-    ] ""+  hAddr <-+    Text.pack . trim+      <$> readProcess+        "docker"+        [ "inspect"+        , hPid+        , "--format"+        , "'{{range .NetworkSettings.Networks}}{{.IPAddress}}{{end}}'"+        ]+        ""   let hUri = uriOf @a hAddr-      h = ProcHandle {hProc=x, hPid, hUri, hAddr }+      h = ProcHandle {hProc = x, hPid, hUri, hAddr}   (nPings h `onException` terminate h) >>= \case-    OK     -> pure h+    OK -> pure h     pinged -> do       terminate h       fail $ pingedMsg x pinged@@ -337,50 +378,54 @@  pingedMsg :: Proc a => a -> Pinged -> String pingedMsg _ OK = ""-pingedMsg p NotOK = "tmp proc:" ++ (Text.unpack $ nameOf p) ++ ":could not be pinged"-pingedMsg p (PingFailed err) = "tmp proc:"-  ++ (Text.unpack $ nameOf p)-  ++ ":ping failed:"-  ++ (Text.unpack err)+pingedMsg p NotOK = "tmp proc:" ++ Text.unpack (nameOf p) ++ ":could not be pinged"+pingedMsg p (PingFailed err) =+  "tmp proc:"+    ++ Text.unpack (nameOf p)+    ++ ":ping failed:"+    ++ Text.unpack err  -{-| Use an action that might throw an exception as a ping. -}-toPinged :: forall e a . Exception e => Proxy e -> IO a -> IO Pinged+-- | Use an action that might throw an exception as a ping.+toPinged :: forall e a. Exception e => Proxy e -> IO a -> IO Pinged toPinged _ action = (action >> pure OK) `catch` (\(_ :: e) -> pure NotOK)  -{-| Ping a 'ProcHandle' several times. -}+-- | Ping a 'ProcHandle' several times. nPings :: Proc a => ProcHandle a -> IO Pinged-nPings h@ProcHandle{hProc = p} =+nPings h@ProcHandle {hProc = p} =   let-    count  = fromEnum $ pingCount' p-    gap    = fromEnum $ pingGap' p+    count = fromEnum $ pingCount' p+    gap = fromEnum $ pingGap' p      badMsg x = "tmp.proc: could not start " <> nameOf p <> "; uncaught exception :" <> x     badErr x = printDebug $ badMsg x      lastMsg = "tmp.proc: could not start " <> nameOf p <> "; all pings failed"-    lastErr  = printDebug lastMsg--    pingMsg i = "tmp.proc: ping #" <> (Text.pack $ show i) <> " failed; will retry"-    nthErr n  = printDebug $ pingMsg $ count + 1 - n+    lastErr = printDebug lastMsg -    ping' x  = ping x `catch` (\(e :: SomeException) -> do-                                    let errMsg = Text.pack $ show e-                                    badErr errMsg-                                    pure $ PingFailed errMsg)+    pingMsg i = "tmp.proc: ping #" <> Text.pack (show i) <> " failed; will retry"+    nthErr n = printDebug $ pingMsg $ count + 1 - n -    go n = ping' h >>= \case-      OK             -> pure OK-      NotOK | n == 0 -> lastErr >> pure NotOK-      NotOK          -> threadDelay gap >> nthErr n >> go (n - 1)-      err            -> pure err+    ping' x =+      ping x+        `catch` ( \(e :: SomeException) -> do+                    let errMsg = Text.pack $ show e+                    badErr errMsg+                    pure $ PingFailed errMsg+                ) -  in+    go n =+      ping' h >>= \case+        OK -> pure OK+        NotOK | n == 0 -> lastErr >> pure NotOK+        NotOK -> threadDelay gap >> nthErr n >> go (n - 1)+        err -> pure err+   in     go count  -{-| Constraint alias used to constrain types where proxy of a 'Proc' type looks up+{- | 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 =@@ -390,7 +435,7 @@   )  -{-| Constraint alias used to constrain types where a 'Name' looks up+{- | Constraint alias used to constrain types where a 'Name' looks up   a type in an 'HList' of 'ProcHandle'. -} type HasNamedHandle name a procs =@@ -401,208 +446,222 @@   )  -{-| Run an action on a 'Connectable' handle as a callback on its 'Conn' -}+-- | 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 handle action = bracket (openConn handle) closeConn action+withTmpConn handle = bracket (openConn handle) closeConn  -{-| Constraint alias when several @'Name's@ are used to find matching+{- | 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))-+      (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+-- | Select the named @'ProcHandle's@ from an 'HList' of @'ProcHandle'@.+manyNamed ::+  SomeNamedHandles names namedProcs someProcs sortedProcs =>+  Proxy names ->+  HandlesOf someProcs ->+  HandlesOf namedProcs manyNamed proxy xs = manyNamed' proxy $ toSortedKVs 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' ::+  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' _ kvs = unsortHandles $ selectMany @sortedNames @ordered kvs  -{-| Specifies how to obtain a 'ProcHandle' that is present in an HList.  -}+-- | 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'@. -}+  -- | 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 _ procs = hOf @(ProcHandle p) Proxy procs+  handleOf _ = hOf @(ProcHandle p) Proxy + instance (HasNamedHandle name p procs) => HandleOf name procs p where   handleOf _ xs = select @name @(ProcHandle p) $ toKVs 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+-- | 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 xs action = flip withTmpConn action $ handleOf proxy xs  -{-| Specifies how to reset a 'ProcHandle' at an index in a list.  -}+-- | 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. -}+  -- | 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 _  xs = reset $ select @name @(ProcHandle a) $ toKVs xs+  ixReset _ xs = reset $ select @name @(ProcHandle a) $ toKVs xs + instance (HasHandle p procs) => IxReset p procs where   ixReset _ xs = reset $ hOf @(ProcHandle p) Proxy xs  -{-| Specifies how to ping a 'ProcHandle' at an index in a list.  -}+-- | 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. -}+  -- | 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 _  xs = ping $ select @name @(ProcHandle a) $ toKVs xs+  ixPing _ xs = ping $ select @name @(ProcHandle a) $ toKVs xs + instance (HasHandle p procs) => IxPing p procs where   ixPing _ xs = ping $ hOf @(ProcHandle p) Proxy xs  -{-| Specifies how to obtain the service URI a 'ProcHandle' at an index in a list.  -}+-- | 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. -}+  -- | 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 _  xs = hUri $ select @name @(ProcHandle a) $ toKVs xs+  ixUriOf _ xs = hUri $ select @name @(ProcHandle a) $ toKVs xs + instance (HasHandle p procs) => IxUriOf p procs where   ixUriOf _ xs = hUri $ hOf @(ProcHandle p) Proxy xs  -{-| Create a 'HList' of @'KV's@ from a 'HList' of @'ProcHandle's@. -}+-- | Create a 'HList' of @'KV's@ from a 'HList' of @'ProcHandle's@. toKVs :: (handles ~ Proc2Handle xs, AreProcs xs) => HList handles -> HList (Handle2KV handles) toKVs = go $ p2h procProof   where     go :: SomeHandles as -> HList as -> HList (Handle2KV as)-    go SomeHandlesNil         HNil          = HNil+    go SomeHandlesNil HNil = HNil     go (SomeHandlesCons cons) (x `HCons` y) = toKV x `HCons` go cons y  -toSortedKVs-  :: ( handles ~ Proc2Handle someProcs-     , sorted ~ SortHandles handles-     , ReorderH handles sorted-     , AreProcs sortedProcs-     , Proc2Handle sortedProcs ~ sorted-     )-  => HList handles -> HList (Handle2KV sorted)+toSortedKVs ::+  ( handles ~ Proc2Handle someProcs+  , sorted ~ SortHandles handles+  , ReorderH handles sorted+  , AreProcs sortedProcs+  , Proc2Handle sortedProcs ~ sorted+  ) =>+  HList handles ->+  HList (Handle2KV sorted) toSortedKVs procHandles = toKVs $ sortHandles procHandles  -{-| Convert a 'ProcHandle' to a 'KV'. -}+-- | Convert a 'ProcHandle' to a 'KV'. toKV :: Proc a => ProcHandle a -> KV (Name a) (ProcHandle a)-toKV h = V h+toKV = V  -{-| 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+-- | Converts list of types to the corresponding @'ProcHandle'@ types.+type family Proc2Handle (as :: [Type]) = (handleTys :: [Type]) | handleTys -> as where+  Proc2Handle '[] = '[]+  Proc2Handle (a ': as) = ProcHandle a ': Proc2Handle as  -{-| A list of @'ProcHandle'@ values. -}+-- | 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+-- | Converts list of 'Proc' the corresponding @'Name'@ symbols.+type family Proc2Name (as :: [Type]) = (nameTys :: [Symbol]) | nameTys -> as where+  Proc2Name '[] = '[]+  Proc2Name (a ': as) = Name a ': Proc2Name as  -{-| Convert list of 'ProcHandle' types to corresponding @'KV'@ types. -}-type family Handle2KV (ts :: [*]) = (kvTys :: [*]) | kvTys -> ts where-  Handle2KV '[]                   = '[]-  Handle2KV (ProcHandle t ':  ts) = KV (Name t) (ProcHandle t) ': Handle2KV ts+-- | Convert list of 'ProcHandle' types to corresponding @'KV'@ types.+type family Handle2KV (ts :: [Type]) = (kvTys :: [Type]) | kvTys -> ts where+  Handle2KV '[] = '[]+  Handle2KV (ProcHandle t ': ts) = KV (Name t) (ProcHandle t) ': Handle2KV ts  -{-| Used by @'AreProcs'@ to prove a list of types just contains @'Proc's@. -}-data SomeProcs (as :: [*]) where-  SomeProcsNil  :: SomeProcs '[]+-- | Used by @'AreProcs'@ to prove a list of types just contains @'Proc's@.+data SomeProcs (as :: [Type]) 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@. -}+-- | Declares a proof that a list of types only contains @'Proc's@. class AreProcs as where   procProof :: SomeProcs as + instance AreProcs '[] where   procProof = SomeProcsNil + instance (Proc a, AreProcs as, IsAbsent a as) => AreProcs (a ': as) where   procProof = SomeProcsCons procProof  -{-| Used to prove a list of types just contains @'ProcHandle's@. -}-data SomeHandles (as :: [*]) where-  SomeHandlesNil  :: SomeHandles '[]+-- | Used to prove a list of types just contains @'ProcHandle's@.+data SomeHandles (as :: [Type]) where+  SomeHandlesNil :: SomeHandles '[]   SomeHandlesCons :: Proc a => SomeHandles as -> SomeHandles (ProcHandle a ': as)   p2h :: SomeProcs as -> SomeHandles (Proc2Handle as)-p2h SomeProcsNil         = SomeHandlesNil+p2h SomeProcsNil = SomeHandlesNil p2h (SomeProcsCons cons) = SomeHandlesCons (p2h cons)  -{-| Used by @'Connectables'@ to prove a list of types just contains @'Connectable's@. -}-data SomeConns (as :: [*]) where-  SomeConnsNil  :: SomeConns '[]+-- | Used by @'Connectables'@ to prove a list of types just contains @'Connectable's@.+data SomeConns (as :: [Type]) 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@. -}+-- | Declares a proof that a list of types only contains @'Connectable's@. class Connectables as where   connProof :: SomeConns as + instance Connectables '[] where   connProof = SomeConnsNil + instance (Connectable a, Connectables as, IsAbsent a as) => Connectables (a ': as) where   connProof = SomeConnsCons 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+-- | Convert list of 'Connectable' types to corresponding 'Conn' types.+type family ConnsOf (cs :: [Type]) = (conns :: [Type]) | conns -> cs where+  ConnsOf '[] = '[]+  ConnsOf (c ': cs) = Conn c ': ConnsOf cs  -{-| Open all the 'Connectable' types to corresponding 'Conn' types. -}+-- | Open all the 'Connectable' types to corresponding 'Conn' types. openAll :: Connectables xs => HandlesOf xs -> IO (HList (ConnsOf xs))-openAll =  go connProof+openAll = go connProof   where     go :: SomeConns as -> HandlesOf as -> IO (HList (ConnsOf as))     go SomeConnsNil HNil = pure HNil@@ -612,102 +671,107 @@       pure $ c `HCons` others  -{-| Close some 'Connectable' types. -}+-- | Close some 'Connectable' types. closeAll :: Connectables procs => HList (ConnsOf procs) -> IO () closeAll = go connProof   where     go :: SomeConns as -> HList (ConnsOf as) -> IO ()-    go SomeConnsNil HNil                  = pure ()+    go SomeConnsNil HNil = pure ()     go (SomeConnsCons cons) (x `HCons` y) = closeConn x >> go cons y  -{-| Open some connections, use them in an action; close them. -}-withConns-  :: Connectables procs-  => HandlesOf procs-  -> (HList (ConnsOf procs) -> IO b)-  -> IO b+-- | Open some connections, use them in an action; close them.+withConns ::+  Connectables procs =>+  HandlesOf procs ->+  (HList (ConnsOf procs) -> IO b) ->+  IO b withConns handles = bracket (openAll handles) 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+-- | 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 = withConns . 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+-- | 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 = withConns . manyNamed proxy  -sortHandles-  :: ( handles ~ Proc2Handle ps-     , sorted ~ SortHandles (handles)-     , ReorderH handles sorted-     )-  => HList handles -> HList sorted+sortHandles ::+  ( handles ~ Proc2Handle ps+  , sorted ~ SortHandles handles+  , ReorderH handles sorted+  ) =>+  HList handles ->+  HList sorted sortHandles = hReorder  -unsortHandles-  :: ( sorted ~ SortHandles (handles)-     , handles ~ Proc2Handle ps-     , ReorderH sorted handles-     )-  => HList sorted -> HList handles+unsortHandles ::+  ( sorted ~ SortHandles handles+  , handles ~ Proc2Handle ps+  , ReorderH sorted handles+  ) =>+  HList sorted ->+  HList handles unsortHandles = hReorder  -{-| Sort lists of @'ProcHandle'@ types. -}+-- | 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))+  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))+  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))+  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)+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 = openBinaryFile "/dev/null"  WriteMode+devNull = openBinaryFile "/dev/null" WriteMode   dockerRun :: [String] -> IO CreateProcess dockerRun args = do   devNull' <- devNull-  pure $ (proc "docker" args) { std_err = UseHandle devNull' }+  pure $ (proc "docker" args) {std_err = UseHandle devNull'}   showDebug :: IO Bool showDebug = fmap (maybe False (const True)) $ lookupEnv debugEnv+  debugEnv :: String debugEnv = "TMP_PROC_DEBUG"
src/System/TmpProc/TypeLevel.hs view
@@ -1,21 +1,20 @@-{-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE ConstraintKinds        #-}-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs                  #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE NamedFieldPuns         #-}-{-# LANGUAGE OverloadedStrings      #-}-{-# LANGUAGE PolyKinds              #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE UndecidableInstances   #-}+{-# 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>@@ -28,23 +27,25 @@  'KV' is intended for internal use within the @tmp-proc@ package. It allows indexing and sorting of lists of tmp procs.- -} module System.TmpProc.TypeLevel   ( -- * Heterogenous List-    HList(..)+    HList (..)   , (&:)+  , only+  , (&:&)+  , both   , hHead   , hOf-  , ReorderH(..)+  , ReorderH (..)      -- * A type-level Key-Value-  , KV(..)+  , KV (..)   , select   , selectMany-  , LookupKV(..)-  , MemberKV(..)-  , ManyMemberKV(..)+  , LookupKV (..)+  , MemberKV (..)+  , ManyMemberKV (..)      -- * Other combinators   , IsAbsent@@ -55,98 +56,128 @@   ) where -import           Data.Kind                     (Type)-import           Data.Proxy                    (Proxy (..))-import           GHC.Exts                      (Constraint)-import           GHC.TypeLits                  (ErrorMessage (..), Symbol,-                                                TypeError)-import qualified GHC.TypeLits                  as TL-import           System.TmpProc.TypeLevel.Sort+import Data.Kind (Type)+import Data.Proxy (Proxy (..))+import GHC.Exts (Constraint)+import GHC.TypeLits+  ( ErrorMessage (..)+  , Symbol+  , TypeError+  )+import qualified GHC.TypeLits as TL+import System.TmpProc.TypeLevel.Sort --- $setup--- >>> import Data.Proxy--- >>> :set -XDataKinds--- >>> :set -XTypeApplications +{- $setup+>>> import Data.Proxy+>>> :set -XDataKinds+>>> :set -XTypeApplications+-} -{-| Obtain the first element of a 'HList'. -}++-- | Obtain the first element of a 'HList'. hHead :: HList (a ': as) -> a hHead (x `HCons` _) = x  -{-| Get an item in an 'HList' given its type. -}-hOf :: forall y xs . IsInProof y xs => Proxy y -> HList xs -> y+-- | Get an item in an 'HList' given its type.+hOf :: forall y xs. IsInProof y xs => Proxy y -> HList xs -> y hOf proxy = go proxy provedIsIn   where     go :: Proxy x -> IsIn x ys -> HList ys -> x-    go _ IsHead            (y `HCons` _)    = y+    go _ IsHead (y `HCons` _) = y     go pxy (IsInTail cons) (_ `HCons` rest) = go pxy cons rest  -{-| Defines a Heterogenous list. -}-data HList :: [*] -> * where-  HNil  :: HList '[]+-- | Defines a Heterogenous list.+data HList :: [Type] -> Type where+  HNil :: HList '[]   HCons :: anyTy -> HList manyTys -> HList (anyTy ': manyTys)  -infixr 5 `HCons`-infixr 5 &:+infixr 5 `HCons`, &: -{-| An infix alias for 'HCons'. -}++-- | An infix alias for 'HCons'. (&:) :: x -> HList xs -> HList (x ': xs) (&:) = HCons + instance Show (HList '[]) where   show HNil = "HNil" + instance (Show x, Show (HList xs)) => Show (HList (x ': xs)) where   show (HCons x xs) = show x ++ " &: " ++ show xs + instance Eq (HList '[]) where   HNil == HNil = True + instance (Eq x, Eq (HList xs)) => Eq (HList (x ': xs)) where   (HCons x xs) == (HCons y ys) = x == y && xs == ys  -{-| Use a type-level symbol as /key/ type that indexes a /value/ type. -}-data KV :: Symbol -> * -> * where+-- | Construct a two-item HList.+both :: x -> y -> HList '[x, y]+both v w = v &: w &: HNil+++infixr 6 `both`, &:&+++-- | An infix alias for 'both'.+(&:&) :: x -> y -> HList '[x, y]+(&:&) = both+++-- | Construct a singleton HList+only :: x -> HList '[x]+only v = v &: HNil+++-- | Use a type-level symbol as /key/ type that indexes a /value/ type.+data KV :: Symbol -> Type -> Type where   V :: a -> KV s a  -{-| A constraint that confirms that a type is not present in a type-level list. -}+-- | A constraint that confirms that a type is not present in a type-level list. type family IsAbsent e r :: Constraint where-  IsAbsent e '[]           = ()-  IsAbsent e (e ': _)      = TypeError (NotAbsentErr e)-  IsAbsent e (e' ': tail)  = IsAbsent e tail+  IsAbsent e '[] = ()+  IsAbsent e (e ': _) = TypeError (NotAbsentErr e)+  IsAbsent e (e' ': tail) = IsAbsent e tail   type NotAbsentErr e =-  ('TL.Text " type " ':<>: 'TL.ShowType e) ':<>:-  ('TL.Text " is already in this type list, and is not allowed again")+  ('TL.Text " type " ':<>: 'TL.ShowType e)+    ':<>: 'TL.Text " is already in this type list, and is not allowed again"  -{-| Proves a symbol and its type occur as entry in a list of @'KV'@ types. -}-data LookupKV (k :: Symbol) t (xs :: [*]) where+-- | Proves a symbol and its type occur as entry in a list of @'KV'@ types.+data LookupKV (k :: Symbol) t (xs :: [Type]) where   AtHead :: LookupKV k t (KV k t ': kvs)   OtherKeys :: LookupKV k t kvs -> LookupKV k t (KV ok ot ': kvs)  -{-| Generate proof instances of 'LookupKV'. -}-class MemberKV (k :: Symbol) (t :: *) (xs :: [*]) where+-- | Generate proof instances of 'LookupKV'.+class MemberKV (k :: Symbol) (t :: Type) (xs :: [Type]) where   lookupProof :: LookupKV k t xs -instance {-# Overlapping #-} MemberKV k t '[KV k t] where++instance {-# OVERLAPPING #-} MemberKV k t '[KV k t] where   lookupProof = AtHead @k @t @'[] -instance {-# Overlapping #-} MemberKV k t (KV k t ': kvs) where++instance {-# OVERLAPPING #-} MemberKV k t (KV k t ': kvs) where   lookupProof = AtHead @k @t @kvs + instance MemberKV k t kvs => MemberKV k t (KV ok ot ': kvs) where   lookupProof = OtherKeys lookupProof  -{-| Select an item from an 'HList' of @'KV's@ by /key/.+{- | Select an item from an 'HList' of @'KV's@ by /key/.   /N.B/ Returns the first item. It assumes the keys in the KV HList are unique.@@ -158,52 +189,52 @@  >>> select @"d" @Double  @'[KV "b" Bool, KV "d" Double] (V True &:  V (3.1 :: Double) &: HNil) 3.1- -}-select-  :: forall k t xs . MemberKV k t xs-  => HList xs-  -> t+select ::+  forall k t xs.+  MemberKV k t xs =>+  HList xs ->+  t select = go $ lookupProof @k @t @xs   where     go :: LookupKV k1 t1 xs1 -> HList xs1 -> t1-    go AtHead (V x `HCons` _)         = x+    go AtHead (V x `HCons` _) = x     go (OtherKeys cons) (_ `HCons` y) = go cons y  -{-| Proves that symbols with corresponding types occur as a 'KV' in a+{- | Proves that symbols with corresponding types occur as a 'KV' in a   list of 'KV' types  /Note/ - both the list symbols and @'KV'@ types need to be sorted, with @'KV'@ types sorted by key. /TODO:/ is there an easy way to incorporate this rule into the proof ?- -}-data LookupMany (keys :: [Symbol]) (t :: [*]) (xs :: [*]) where+data LookupMany (keys :: [Symbol]) (t :: [Type]) (xs :: [Type]) where   FirstOfMany :: LookupMany (k ': '[]) (t ': '[]) (KV k t ': kvs)--  NextOfMany-    :: LookupMany ks ts kvs-    -> LookupMany (k ': ks) (t ': ts) (KV k t ': kvs)-+  NextOfMany ::+    LookupMany ks ts kvs ->+    LookupMany (k ': ks) (t ': ts) (KV k t ': kvs)   ManyOthers :: LookupMany ks ts kvs -> LookupMany ks ts (KV ok ot ': kvs)  -{-| Generate proof instances of 'LookupMany'. -}-class ManyMemberKV (ks :: [Symbol]) (ts :: [*]) (kvs :: [*])  where+-- | Generate proof instances of 'LookupMany'.+class ManyMemberKV (ks :: [Symbol]) (ts :: [Type]) (kvs :: [Type]) where   manyProof :: LookupMany ks ts kvs -instance {-# Overlapping #-} ManyMemberKV '[k] '[t] (KV k t ': ks) where++instance {-# OVERLAPPING #-} ManyMemberKV '[k] '[t] (KV k t ': ks) where   manyProof = FirstOfMany @k @t @ks -instance {-# Overlapping #-} ManyMemberKV ks ts kvs => ManyMemberKV (k ': ks) (t ': ts) (KV k t ': kvs) where++instance {-# OVERLAPPING #-} ManyMemberKV ks ts kvs => ManyMemberKV (k ': ks) (t ': ts) (KV k t ': kvs) where   manyProof = NextOfMany manyProof -instance ManyMemberKV ks ts kvs  => ManyMemberKV ks ts (KV ok ot ': kvs) where++instance ManyMemberKV ks ts kvs => ManyMemberKV ks ts (KV ok ot ': kvs) where   manyProof = ManyOthers manyProof  -{-| Select items with specified keys from an @'HList'@ of @'KV's@ by /key/.+{- | Select items with specified keys from an @'HList'@ of @'KV's@ by /key/.  /N.B./ this this is an internal function. @@ -215,21 +246,21 @@  >>> selectMany @'["b"] @'[Bool] @'[KV "b" Bool, KV "d" Double] (V True &:  V (3.1 :: Double) &: HNil) True &: HNil- -}-selectMany-  :: forall ks ts xs . ManyMemberKV ks ts xs-  => HList xs-  -> HList ts+selectMany ::+  forall ks ts xs.+  ManyMemberKV ks ts xs =>+  HList xs ->+  HList ts selectMany = go $ manyProof @ks @ts @xs   where     go :: LookupMany ks1 ts1 xs1 -> HList xs1 -> HList ts1-    go FirstOfMany (V x `HCons` _)       = x `HCons` HNil+    go FirstOfMany (V x `HCons` _) = x `HCons` HNil     go (NextOfMany cons) (V x `HCons` y) = x `HCons` go cons y-    go (ManyOthers cons) (_ `HCons` y)   = go cons y+    go (ManyOthers cons) (_ `HCons` y) = go cons y  -{-| Allows reordering of similar @'HList's@.+{- | Allows reordering of similar @'HList's@.  ==== __Examples__ @@ -239,30 +270,33 @@  >>> hReorder @_ @'[Double, Bool, Int] ('c' &: (3 :: Int) &: True &: (3.1 :: Double) &: HNil) 3.1 &: True &: 3 &: HNil- -} class ReorderH xs ys where   hReorder :: HList xs -> HList ys + instance ReorderH xs '[] where   hReorder _ = HNil + instance (IsInProof y xs, ReorderH xs ys) => ReorderH xs (y ': ys) where   hReorder xs = hOf @y Proxy xs `HCons` hReorder xs  -{-| Proves a type is present in a list of other types. -}+-- | Proves a type is present in a list of other types. data IsIn t (xs :: [Type]) where-  IsHead   :: IsIn t (t ': tys)+  IsHead :: IsIn t (t ': tys)   IsInTail :: IsIn t tys -> IsIn t (otherTy ': tys)  -{-| Generate proof instances of 'IsIn'. -}+-- | Generate proof instances of 'IsIn'. class IsInProof t (tys :: [Type]) where   provedIsIn :: IsIn t tys -instance {-# Overlapping #-} IsInProof t (t ': tys) where++instance {-# OVERLAPPING #-} IsInProof t (t ': tys) where   provedIsIn = IsHead @t @tys+  instance IsInProof t tys => IsInProof t (a : tys) where   provedIsIn = IsInTail provedIsIn
test/Test/HttpBin.hs view
@@ -12,25 +12,39 @@ import qualified Data.Text as Text import qualified Network.HTTP.Client as HC import Network.HTTP.Types.Status (statusCode)-import System.TmpProc (-  HList (..),-  HandlesOf,-  HostIpAddress,-  Pinged (..),-  Proc (..),-  ProcHandle (..),-  SvcURI,-  manyNamed,-  startupAll,-  toPinged,-  (&:),- )+import System.TmpProc+  ( HandlesOf+  , HostIpAddress+  , Pinged (..)+  , Proc (..)+  , ProcHandle (..)+  , SvcURI+  , manyNamed+  , startupAll+  , toPinged+  , (&:)+  , (&:&)+  )  -setupHandles :: IO (HandlesOf '[HttpBinTest, HttpBinTest2, HttpBinTest3])-setupHandles = startupAll $ HttpBinTest &: HttpBinTest2 &: HttpBinTest3 &: HNil+setupHandles :: IO (HandlesOf '[HttpBinTest, NginxTest, HttpBinTest3])+setupHandles = startupAll $ HttpBinTest &: NginxTest &:& HttpBinTest3  +-- | A data type representing a connection to an Nginx server.+data NginxTest = NginxTest+++-- | Run Nginx as temporary process.+instance Proc NginxTest where+  type Image NginxTest = "nginx:1.25.1"+  type Name NginxTest = "nginx-test"+  uriOf = mkUri'+  runArgs = []+  reset _ = pure ()+  ping = ping'++ -- | A data type representing a connection to a HttpBin server. data HttpBinTest = HttpBinTest @@ -39,8 +53,6 @@ instance Proc HttpBinTest where   type Image HttpBinTest = "kennethreitz/httpbin"   type Name HttpBinTest = "http-bin-test"--   uriOf = mkUri'   runArgs = []   reset _ = pure ()@@ -59,8 +71,6 @@ instance Proc HttpBinTest2 where   type Image HttpBinTest2 = "kennethreitz/httpbin"   type Name HttpBinTest2 = "http-bin-test-2"--   uriOf = mkUri'   runArgs = []   reset _ = pure ()@@ -79,8 +89,6 @@ instance Proc HttpBinTest3 where   type Image HttpBinTest3 = "kennethreitz/httpbin"   type Name HttpBinTest3 = "http-bin-test-3"--   uriOf = mkUri'   runArgs = []   reset _ = pure ()@@ -126,7 +134,7 @@   pure $ manyNamed @'["http-bin-test-3", "http-bin-test"] Proxy allHandles  -typeLevelCheck4 :: IO (HandlesOf '[HttpBinTest2, HttpBinTest3, HttpBinTest])+typeLevelCheck4 :: IO (HandlesOf '[HttpBinTest3, NginxTest, HttpBinTest]) typeLevelCheck4 = do   allHandles <- setupHandles-  pure $ manyNamed @'["http-bin-test-2", "http-bin-test-3", "http-bin-test"] Proxy allHandles+  pure $ manyNamed @'["http-bin-test-3", "nginx-test", "http-bin-test"] Proxy allHandles
test/Test/System/TmpProc/HttpBinSpec.hs view
@@ -1,45 +1,47 @@-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeFamilies        #-}-module Test.System.TmpProc.HttpBinSpec where--import           Test.Hspec+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} -import           Data.Proxy         (Proxy (Proxy))-import qualified Data.Text          as Text+module Test.System.TmpProc.HttpBinSpec where -import           System.TmpProc     (Pinged (..), ixPing, ixReset, nameOf,-                                     terminateAll)-import           Test.Hspec.TmpProc (tdescribe)-import           Test.HttpBin+import Data.Proxy (Proxy (Proxy))+import System.TmpProc+  ( Pinged (..)+  , ixPing+  , ixReset+  , terminateAll+  )+import Test.Hspec+import Test.Hspec.TmpProc (tdescribe)+import Test.HttpBin   spec :: Spec-spec = tdescribe ("Tmp.Proc: " ++ Text.unpack (nameOf HttpBinTest)) $ do+spec = tdescribe "Tmp.Proc: ping and reset" $ do   beforeAll setupHandles $ afterAll terminateAll $ do     context "When accessing the services in the list of test tmp procs" $ do-       context "ixPing" $ do+        it "should succeed when accessing the nginx proc by name" $ \hs ->+          ixPing @"nginx-test" Proxy hs `shouldReturn` OK -        it "should succeed when accessing a Proc by name" $ \hs-          -> ixPing @"http-bin-test" Proxy hs `shouldReturn` OK+        it "should succeed when accessing the http-bin proc by name" $ \hs ->+          ixPing @"http-bin-test" Proxy hs `shouldReturn` OK -        it "should succeed when accessing a Proc by type" $ \hs-          -> ixPing @HttpBinTest Proxy hs `shouldReturn` OK+        it "should succeed when accessing a Proc by type" $ \hs ->+          ixPing @HttpBinTest Proxy hs `shouldReturn` OK        context "ixReset" $ do--        it "should succeed when accessing a Proc by name" $ \hs-          -> ixReset @"http-bin-test" Proxy hs `shouldReturn`()+        it "should succeed when accessing a Proc by name" $ \hs ->+          ixReset @"http-bin-test" Proxy hs `shouldReturn` () -        it "should succeed when accessing a different Proc by name" $ \hs-          -> ixReset @"http-bin-test-3" Proxy hs `shouldReturn`()+        it "should succeed when accessing a different Proc by name" $ \hs ->+          ixReset @"http-bin-test-3" Proxy hs `shouldReturn` () -        it "should succeed when accessing a Proc by type" $ \hs-          -> ixReset @HttpBinTest Proxy hs `shouldReturn`()+        it "should succeed when accessing a http-bin proc by type" $ \hs ->+          ixReset @HttpBinTest Proxy hs `shouldReturn` () -        it "should succeed when accessing a different Proc by type" $ \hs-          -> ixReset @HttpBinTest2 Proxy hs `shouldReturn`()+        it "should succeed when accessing the nginx proc by type" $ \hs ->+          ixReset @NginxTest Proxy hs `shouldReturn` ()
test/Test/System/TmpProc/WarpSpec.hs view
@@ -15,24 +15,25 @@ import qualified Network.HTTP.Client as HC import Network.HTTP.Types (status200, status400) import Network.Wai (Application, pathInfo, responseLBS)-import System.TmpProc.Docker (-  HList (..),-  HandlesOf,-  Pinged (..),-  ProcHandle,-  handleOf,-  ixPing,- )-import System.TmpProc.Warp (-  ServerHandle,-  handles,-  runServer,-  runTLSServer,-  serverPort,-  shutdown,-  testWithApplication,-  testWithTLSApplication,- )+import System.TmpProc.Docker+  ( HList (..)+  , HandlesOf+  , Pinged (..)+  , ProcHandle+  , handleOf+  , ixPing+  , only+  )+import System.TmpProc.Warp+  ( ServerHandle+  , handles+  , runServer+  , runTLSServer+  , serverPort+  , shutdown+  , testWithApplication+  , testWithTLSApplication+  ) import Test.Hspec import Test.Hspec.TmpProc (tdescribe) import Test.HttpBin@@ -45,7 +46,7 @@   testProcs :: HList '[HttpBinTest]-testProcs = HttpBinTest `HCons` HNil+testProcs = only HttpBinTest   testApp :: HandlesOf '[HttpBinTest] -> IO Application@@ -151,6 +152,6 @@                   )   catchHttp $ do     gotStatus <- handleGet handle "/status/200"-    if (gotStatus == 200)+    if gotStatus == 200       then pure ()       else fail "tmp proc:httpbin:incorrect ping status"
tmp-proc.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               tmp-proc-version:            0.5.2.1+version:            0.5.3.0 synopsis:           Run 'tmp' processes in integration tests description:   @tmp-proc@ runs services in docker containers for use in integration tests.@@ -36,13 +36,15 @@   ChangeLog.md tested-with:   GHC == 8.8.4-  GHC == 8.10.5   GHC == 8.10.7-  GHC == 9.2.2+  GHC == 9.0.2+  GHC == 9.2.8+  GHC == 9.4.5  source-repository head   type:     git   location: https://github.com/adetokunbo/tmp-proc.git+  subdir:   tmp-proc  library   exposed-modules: