diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -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. diff --git a/src/System/TmpProc/Docker.hs b/src/System/TmpProc/Docker.hs --- a/src/System/TmpProc/Docker.hs +++ b/src/System/TmpProc/Docker.hs @@ -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 @@ -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" diff --git a/src/System/TmpProc/TypeLevel.hs b/src/System/TmpProc/TypeLevel.hs --- a/src/System/TmpProc/TypeLevel.hs +++ b/src/System/TmpProc/TypeLevel.hs @@ -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 @@ -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 diff --git a/test/Test/HttpBin.hs b/test/Test/HttpBin.hs --- a/test/Test/HttpBin.hs +++ b/test/Test/HttpBin.hs @@ -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 diff --git a/test/Test/System/TmpProc/HttpBinSpec.hs b/test/Test/System/TmpProc/HttpBinSpec.hs --- a/test/Test/System/TmpProc/HttpBinSpec.hs +++ b/test/Test/System/TmpProc/HttpBinSpec.hs @@ -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` () diff --git a/test/Test/System/TmpProc/WarpSpec.hs b/test/Test/System/TmpProc/WarpSpec.hs --- a/test/Test/System/TmpProc/WarpSpec.hs +++ b/test/Test/System/TmpProc/WarpSpec.hs @@ -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" diff --git a/tmp-proc.cabal b/tmp-proc.cabal --- a/tmp-proc.cabal +++ b/tmp-proc.cabal @@ -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: