diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,40 @@ +# Revision history for tmp-proc + +`tmp-proc` uses [PVP Versioning][1]. + +## 0.5.0.0 -- 2021-09-28 + +* Initial release to hackage + +* Re-implemented the user surface to be more typeful and hopefully easier to use. + +* Switched the development build environment to haskell.nix + +## 0.4.0.0 -- 2021-08-03 + +* Update versions of major dependencies, allowing it to build with GHC 8.10 + +## 0.3.2.0 -- 2019-04-01 + +* Make the run*Server functions throw exceptions in app threads to the calling + thread. + +## 0.3.1.0 -- 2019-02-26 + +* Add new public functions that allow TLS-protected endpoints + +## 0.3.0.0 -- 2019-02-25 + +* Reorganize the public API for simpler usage with HSpec and Tasty + + +## 0.2.0.0 -- 2019-02-18 + +* Added integration tests, removed unnecessary internal features from the public + api. + +## 0.1.0.0 -- 2019-02-17 + +* First version. Extracted from some a non-public test library + +[1]: https://pvp.haskell.org diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, Tim Emiola + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Tim Emiola nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/doctest/Main.hs b/doctest/Main.hs new file mode 100644 --- /dev/null +++ b/doctest/Main.hs @@ -0,0 +1,7 @@ +-- file doctests.hs +import Test.DocTest + +main :: IO () +main = doctest ["-isrc", "src/System/TmpProc/TypeLevel/Sort.hs", + "-isrc", "src/System/TmpProc/TypeLevel.hs" + ] diff --git a/src/System/TmpProc.hs b/src/System/TmpProc.hs new file mode 100644 --- /dev/null +++ b/src/System/TmpProc.hs @@ -0,0 +1,23 @@ +{-| +Copyright : (c) 2020-2021 Tim Emiola +SPDX-License-Identifier: BSD3 +Maintainer : Tim Emiola + +Exports all tmp-proc behaviour. + +@tmp-proc@ is a package that aims to simplify writing integration tests that use +dockerizable services. + +The package has the following structure: + +* __"System.TmpProc.Docker":__ definition of core data types, @Proc@ and @ProcHandle@, and their combinators. +* __"System.TmpProc.Warp":__ functions that make it easy to test a WAI @application@ that accesses @tmp@ @procs@ + +-} +module System.TmpProc + ( module System.TmpProc.Docker + , module System.TmpProc.Warp + ) where + +import System.TmpProc.Docker +import System.TmpProc.Warp diff --git a/src/System/TmpProc/Docker.hs b/src/System/TmpProc/Docker.hs new file mode 100644 --- /dev/null +++ b/src/System/TmpProc/Docker.hs @@ -0,0 +1,719 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK prune not-home #-} + +{-| +Copyright : (c) 2020-2021 Tim Emiola +SPDX-License-Identifier: BSD3 +Maintainer : Tim Emiola + +Provides the core data types and combinators used to launch temporary /(tmp)/ +processes /(procs)/ using docker. + +@tmp-proc@ aims to simplify integration tests that use dockerizable services. + +* Basically, @tmp-proc@ helps launch services used in integration test on docker + +* While it's possible to write integration tests that use services hosted on + docker /without/ @tmp-proc@, @tmp-proc@ aims to make writing those kind of + tests easier, by providing types and combinators that take care of + + * launching services on docker + * obtaining references to the launched service + * cleaning up docker once the tests are finished + +This module does all that via its data types: + +* A /'Proc'/ specifies a docker image that provides a service and other details + related to its use in tests. + +* A /'ProcHandle'/ is created whenever a service specifed by a /'Proc'/ is +started, and is used to access and eventually terminate the running service. + +* Some @'Proc's@ will also be /'Connectable'/; these specify how access the +service via some /'Conn'-ection/ type. + +-} +module System.TmpProc.Docker + ( -- * @'Proc'@ + Proc(..) + , Pinged(..) + , AreProcs + , SomeProcs(..) + , nameOf + , startup + , toPinged + , uriOf' + , runArgs' + + -- * @'ProcHandle'@ + , ProcHandle(..) + , Proc2Handle + , HandlesOf + , startupAll + , terminateAll + , withTmpProcs + , manyNamed + , handleOf + , ixReset + , ixPing + , ixUriOf + , HasHandle + , HasNamedHandle + , SomeNamedHandles + + -- * @'Connectable'@ + , Connectable(..) + , Connectables + , withTmpConn + , withConnOf + , openAll + , closeAll + , withConns + , withKnownConns + , withNamedConns + + -- * Docker status + , hasDocker + + -- * Aliases + , HostIpAddress + , SvcURI + + -- * Re-exports + , module System.TmpProc.TypeLevel + ) +where + +import Control.Concurrent (threadDelay) +import Control.Exception (SomeException, bracket, catch, + onException, Exception) +import Control.Monad (void, when) +import qualified Data.ByteString.Char8 as C8 +import Data.Kind (Type) +import Data.List (dropWhileEnd) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import GHC.TypeLits (CmpSymbol, KnownSymbol, Nat, Symbol, + symbolVal) +import Numeric.Natural (Natural) +import System.Exit (ExitCode (..)) +import System.Environment (lookupEnv) +import System.IO (stderr, Handle, openBinaryFile, IOMode(..)) +import System.Process (StdStream (..), proc, readProcess, + std_err, std_out, waitForProcess, + withCreateProcess, readCreateProcess, CreateProcess) + +import System.TmpProc.TypeLevel (Drop, HList (..), HalfOf, IsAbsent, + IsInProof, KV (..), LengthOf, + ManyMemberKV, MemberKV, + ReorderH (..), SortSymbols, Take, + hOf, select, selectMany, (&:)) + + +{-| Determines if the docker daemon is accessible. -} +hasDocker :: IO Bool +hasDocker = do + 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 <$> 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 +withTmpProcs procs = bracket (startupAll procs) terminateAll + + +{-| Provides access to a 'Proc' that has been started. -} +data ProcHandle a = ProcHandle + { hProc :: !a + , hPid :: !String + , hUri :: !SvcURI + , hAddr :: !HostIpAddress + } + + +{-| Start up processes for each 'Proc' type. -} +startupAll :: AreProcs procs => HList procs -> IO (HandlesOf procs) +startupAll = go procProof + where + go :: SomeProcs as -> HList as -> IO (HandlesOf as) + go SomeProcsNil HNil = pure HNil + go (SomeProcsCons cons) (x `HCons` y) = do + h <- startup x + others <- go cons y `onException` terminate h + pure $ h `HCons` others + + +{-| Terminate all processes owned by some @'ProcHandle's@. -} +terminateAll :: AreProcs procs => HandlesOf procs -> IO () +terminateAll = go $ p2h procProof + where + go :: SomeHandles as -> HList as -> IO () + go SomeHandlesNil HNil = pure () + go (SomeHandlesCons cons) (x `HCons` y) = do + terminate x + go cons y + + +{-| 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 ] "" + + +{-| Specifies how to a get a connection to a 'Proc'. -} +class Proc a => Connectable a where + {-| The connection type. -} + type Conn a = (conn :: *) | conn -> a + + {-| Get a connection to the Proc via its 'ProcHandle', -} + openConn :: ProcHandle a -> IO (Conn a) + + {-| Close a connection to a 'Proc', -} + closeConn :: Conn a -> IO () + closeConn = const $ pure () + + +{-| Specifies how to launch a temporary process using Docker. -} +class (KnownSymbol (Image a), KnownSymbol (Name a)) => Proc a where + {-| The image name of the docker image, e.g, /postgres:10.6/ -} + type Image a :: Symbol + + {-| A label used to refer to running process created from this image, e.g, + /a-postgres-db/ -} + type Name a = (labelName :: Symbol) | labelName -> a + + {-| Additional arguments to the docker command that launches the tmp proc. -} + runArgs :: [Text] + runArgs = mempty + + {-| Determines the service URI of the process, when applicable. -} + uriOf :: HostIpAddress -> SvcURI + + {-| Resets some state in a tmp proc service. -} + reset :: ProcHandle a -> IO () + + {-| Checks if the tmp proc started ok. -} + ping :: ProcHandle a -> IO Pinged + + {-| Maximum number of pings to perform during startup. -} + pingCount :: Natural + pingCount = 4 + + {-| Number of milliseconds between pings. -} + pingGap :: Natural + pingGap = 1000000 + + +{-| Indicates the result of pinging a 'Proc'. + +If the ping succeeds, 'ping2' should return 'OK'. + +'ping2' should catch any exceptions that are expected when the @'Proc's@ service +is not available and return 'NotOK'. + +'startupAll' uses 'PingFailed' to report any unexpected exceptions that escape +'ping2'. + +-} +data Pinged = + {-| The service is running OK. -} + OK + + {-| The service is not running. -} + | NotOK + + {-| Contact to the service failed unexpectedly. -} + | PingFailed Text + + deriving (Eq, Show) + +{-| 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 '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 'uriOf'. -} +uriOf' :: forall a . (Proc a) => a -> HostIpAddress -> SvcURI +uriOf' _ addr = uriOf @a addr + + +{-| 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] + + +imageText' :: forall a . (Proc a) => Text +imageText' = Text.pack $ symbolVal (Proxy :: Proxy (Image a)) + + +-- | The IP address of the docker host. +type HostIpAddress = Text + + +-- | A connection string used to access the service once its running. +type SvcURI = C8.ByteString + + +{-| Starts a 'Proc'. + +It uses 'ping' to determine if the 'Proc' started up ok, and will fail by +throwing an exception if it did not. + +Returns the 'ProcHandle' used to control the 'Proc' once a ping has succeeded. + +-} +startup :: forall a . Proc a => a -> IO (ProcHandle a) +startup 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}}'" + ] "" + let hUri = uriOf @a hAddr + h = ProcHandle {hProc=x, hPid, hUri, hAddr } + (nPings h `onException` terminate h) >>= \case + OK -> pure h + pinged -> do + terminate h + fail $ pingedMsg x pinged + + +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) + + +{-| 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. -} +nPings :: Proc a => ProcHandle a -> IO Pinged +nPings h@ProcHandle{hProc = p} = + let + 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 + + ping' x = ping x `catch` (\(e :: SomeException) -> do + let errMsg = Text.pack $ show e + badErr errMsg + pure $ PingFailed errMsg) + + 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 + a value in an 'HList' of 'ProcHandle'. +-} +type HasHandle aProc procs = + ( Proc aProc + , AreProcs procs + , IsInProof (ProcHandle aProc) (Proc2Handle procs) + ) + + +{-| Constraint alias used to constrain types where a 'Name' looks up + a type in an 'HList' of 'ProcHandle'. +-} +type HasNamedHandle name a procs = + ( name ~ Name a + , Proc a + , AreProcs procs + , MemberKV name (ProcHandle a) (Handle2KV (Proc2Handle procs)) + ) + + +{-| Run an action on a 'Connectable' handle as a callback on its 'Conn' -} +withTmpConn :: Connectable a => ProcHandle a -> (Conn a -> IO b) -> IO b +withTmpConn handle action = bracket (openConn handle) closeConn action + + +{-| Constraint alias when several @'Name's@ are used to find matching + types in an 'HList' of 'ProcHandle'. +-} +type SomeNamedHandles names procs someProcs sortedProcs = + ( names ~ Proc2Name procs + , ManyMemberKV + (SortSymbols names) + (SortHandles (Proc2Handle procs)) + (Handle2KV (Proc2Handle sortedProcs)) + + , ReorderH (SortHandles (Proc2Handle procs)) (Proc2Handle procs) + , ReorderH (Proc2Handle someProcs) (Proc2Handle sortedProcs) + + , AreProcs sortedProcs + , SortHandles (Proc2Handle someProcs) ~ Proc2Handle sortedProcs + ) + + +{-| Select the named @'ProcHandle's@ from an 'HList' of @'ProcHandle'@. -} +manyNamed + :: SomeNamedHandles names namedProcs someProcs sortedProcs + => Proxy names -> HandlesOf someProcs -> HandlesOf namedProcs +manyNamed proxy 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' _ kvs = unsortHandles $ selectMany @sortedNames @ordered kvs + + +{-| Specifies how to obtain a 'ProcHandle' that is present in an HList. -} +class HandleOf a procs b where + + {-| Obtain the handle matching the given type from a @'HList'@ of @'ProcHandle'@. -} + handleOf :: Proxy a -> HandlesOf procs -> ProcHandle b + +instance (HasHandle p procs) => HandleOf p procs p where + handleOf _ procs = hOf @(ProcHandle p) Proxy procs + +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 +withConnOf proxy xs action = flip withTmpConn action $ handleOf proxy xs + + +{-| Specifies how to reset a 'ProcHandle' at an index in a list. -} +class IxReset a procs where + + {-| Resets the handle whose index is specified by the proxy type. -} + ixReset :: Proxy a -> HandlesOf procs -> IO () + +instance (HasNamedHandle name a procs) => IxReset name procs where + ixReset _ 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. -} +class IxPing a procs where + + {-| Pings the handle whose index is specified by the proxy type. -} + ixPing :: Proxy a -> HandlesOf procs -> IO Pinged + +instance (HasNamedHandle name a procs) => IxPing name procs where + ixPing _ 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. -} +class IxUriOf a procs where + + {-| Obtains the service URI of the handle whose index is specified by the proxy type. -} + ixUriOf :: Proxy a -> HandlesOf procs -> SvcURI + +instance (HasNamedHandle name a procs) => IxUriOf name procs where + ixUriOf _ 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@. -} +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 (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 procHandles = toKVs $ sortHandles procHandles + + +{-| Convert a 'ProcHandle' to a 'KV'. -} +toKV :: Proc a => ProcHandle a -> KV (Name a) (ProcHandle a) +toKV h = V h + + +{-| Converts list of types to the corresponding @'ProcHandle'@ types. -} +type family Proc2Handle (as :: [*]) = (handleTys :: [*]) | handleTys -> as where + Proc2Handle '[] = '[] + Proc2Handle (a ': as) = ProcHandle a ': Proc2Handle as + + +{-| A list of @'ProcHandle'@ values. -} +type HandlesOf procs = HList (Proc2Handle procs) + + +{-| Converts list of 'Proc' the corresponding @'Name'@ symbols. -} +type family Proc2Name (as :: [*]) = (nameTys :: [Symbol]) | nameTys -> as where + Proc2Name '[] = '[] + Proc2Name (a ': as) = Name a ': Proc2Name as + + +{-| Convert list of 'ProcHandle' types to corresponding @'KV'@ types. -} +type family Handle2KV (ts :: [*]) = (kvTys :: [*]) | kvTys -> ts where + Handle2KV '[] = '[] + Handle2KV (ProcHandle t ': ts) = KV (Name t) (ProcHandle t) ': Handle2KV ts + + +{-| Used by @'AreProcs'@ to prove a list of types just contains @'Proc's@. -} +data SomeProcs (as :: [*]) where + SomeProcsNil :: SomeProcs '[] + SomeProcsCons :: (Proc a, IsAbsent a as) => SomeProcs as -> SomeProcs (a ': as) + + +{-| Declares a proof that a list of types only contains @'Proc's@. -} +class AreProcs as where + procProof :: SomeProcs as + +instance AreProcs '[] where + procProof = 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 '[] + SomeHandlesCons :: Proc a => SomeHandles as -> SomeHandles (ProcHandle a ': as) + + +p2h :: SomeProcs as -> SomeHandles (Proc2Handle as) +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 '[] + SomeConnsCons :: (Connectable a, IsAbsent a as) => SomeConns as -> SomeConns (a ': as) + + +{-| Declares a proof that a list of types only contains @'Connectable's@. -} +class Connectables as where + connProof :: SomeConns as + +instance Connectables '[] where + connProof = 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 + + +{-| Open all the 'Connectable' types to corresponding 'Conn' types. -} +openAll :: Connectables xs => HandlesOf xs -> IO (HList (ConnsOf xs)) +openAll = go connProof + where + go :: SomeConns as -> HandlesOf as -> IO (HList (ConnsOf as)) + go SomeConnsNil HNil = pure HNil + go (SomeConnsCons cons) (x `HCons` y) = do + c <- openConn x + others <- go cons y `onException` closeConn c + pure $ c `HCons` others + + +{-| 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 (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 +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 +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 +withNamedConns proxy = withConns . manyNamed proxy + + +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 = hReorder + + +{-| Sort lists of @'ProcHandle'@ types. -} +type family SortHandles (xs :: [Type]) :: [Type] where + SortHandles '[] = '[] + SortHandles '[x] = '[x] + SortHandles '[x, y] = MergeHandles '[x] '[y] -- just an optimization, not required + SortHandles xs = SortHandlesStep xs (HalfOf (LengthOf xs)) + +type family SortHandlesStep (xs :: [Type]) (halfLen :: Nat) :: [Type] where + SortHandlesStep xs halfLen = MergeHandles (SortHandles (Take xs halfLen)) (SortHandles (Drop xs halfLen)) + +type family MergeHandles (xs :: [Type]) (ys :: [Type]) :: [Type] where + MergeHandles xs '[] = xs + MergeHandles '[] ys = ys + MergeHandles (ProcHandle x ': xs) (ProcHandle y ': ys) = + MergeHandlesImpl (ProcHandle x ': xs) (ProcHandle y ': ys) (CmpSymbol (Name x) (Name y)) + +type family MergeHandlesImpl (xs :: [Type]) (ys :: [Type]) (o :: Ordering) :: [Type] where + MergeHandlesImpl (ProcHandle x ': xs) (ProcHandle y ': ys) 'GT = + ProcHandle y ': MergeHandles (ProcHandle x ': xs) ys + + MergeHandlesImpl (ProcHandle x ': xs) (ProcHandle y ': ys) leq = + ProcHandle x ': MergeHandles xs (ProcHandle y ': ys) + + +devNull :: IO Handle +devNull = openBinaryFile "/dev/null" WriteMode + + +dockerRun :: [String] -> IO CreateProcess +dockerRun args = do + devNull' <- 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" + + +printDebug :: Text -> IO () +printDebug t = do + canPrint <- showDebug + when canPrint $ Text.hPutStrLn stderr t diff --git a/src/System/TmpProc/TypeLevel.hs b/src/System/TmpProc/TypeLevel.hs new file mode 100644 --- /dev/null +++ b/src/System/TmpProc/TypeLevel.hs @@ -0,0 +1,268 @@ +{-# 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 TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK prune not-home #-} +{-| +Copyright : (c) 2020-2021 Tim Emiola +SPDX-License-Identifier: BSD3 +Maintainer : Tim Emiola + +Defines type-level data structures and combinators used by +"System.TmpProc.Docker" and "System.TmpProc.Warp". + +'HList' implements a heterogenous list used to define types that represent +multiple concurrent @tmp procs@. + +'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(..) + , (&:) + , hHead + , hOf + , ReorderH(..) + + -- * A type-level Key-Value + , KV(..) + , select + , selectMany + , LookupKV(..) + , MemberKV(..) + , ManyMemberKV(..) + + -- * Other combinators + , IsAbsent + , IsInProof + + -- * Re-exports + , module System.TmpProc.TypeLevel.Sort + ) +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 + +-- $setup +-- >>> import Data.Proxy +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications + + +{-| 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 +hOf proxy = go proxy provedIsIn + where + go :: Proxy x -> IsIn x ys -> HList ys -> x + go _ IsHead (y `HCons` _) = y + go pxy (IsInTail cons) (_ `HCons` rest) = go pxy cons rest + + +{-| Defines a Heterogenous list. -} +data HList :: [*] -> * where + HNil :: HList '[] + HCons :: anyTy -> HList manyTys -> HList (anyTy ': manyTys) + + +infixr 5 `HCons` +infixr 5 &: + +{-| 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 + V :: a -> KV s a + + +{-| 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 + + +type NotAbsentErr e = + ('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 + 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 + lookupProof :: LookupKV k t xs + +instance {-# Overlapping #-} MemberKV k t '[KV k t] where + lookupProof = AtHead @k @t @'[] + +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/. + + +/N.B/ Returns the first item. It assumes the keys in the KV HList are unique. +/TODO:/ enforce this rule using a constraint. + + +==== __Examples__ + + +>>> 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 = go $ lookupProof @k @t @xs + where + go :: LookupKV k1 t1 xs1 -> HList xs1 -> t1 + 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 + 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 + FirstOfMany :: LookupMany (k ': '[]) (t ': '[]) (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 + manyProof :: LookupMany ks ts kvs + +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 + manyProof = NextOfMany manyProof + +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/. + +/N.B./ this this is an internal function. + +The keys must be provided in the same order as they occur in the +HList, any other order will likely result in an compiler error. + +==== __Examples__ + + +>>> 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 = go $ manyProof @ks @ts @xs + where + go :: LookupMany ks1 ts1 xs1 -> HList xs1 -> HList ts1 + 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 + + +{-| Allows reordering of similar @'HList's@. + +==== __Examples__ + + +>>> hReorder @_ @'[Bool, Int] ('c' &: (3 :: Int) &: True &: (3.1 :: Double) &: HNil) +True &: 3 &: HNil + +>>> 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. -} +data IsIn t (xs :: [Type]) where + IsHead :: IsIn t (t ': tys) + IsInTail :: IsIn t tys -> IsIn t (otherTy ': tys) + + +{-| Generate proof instances of 'IsIn'. -} +class IsInProof t (tys :: [Type]) where + provedIsIn :: IsIn t tys + +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/src/System/TmpProc/TypeLevel/Sort.hs b/src/System/TmpProc/TypeLevel/Sort.hs new file mode 100644 --- /dev/null +++ b/src/System/TmpProc/TypeLevel/Sort.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK prune not-home #-} + +{-| +Copyright : (c) 2020-2021 Tim Emiola +SPDX-License-Identifier: BSD3 +Maintainer : Tim Emiola + +Defines type-level combinators for performing a merge sort of type-level lists. + +'SortSymbols' sorts type-level lists of @Symbols@. + +The other exported combinators make it easy to implement type-level merge sort +for similar type-level lists. + +This is an internal module that provides type-level functions used in +various constraints in "System.TmpProc.Docker". + +-} +module System.TmpProc.TypeLevel.Sort + ( -- * Merge sort for @Symbols@. + SortSymbols + + -- * Sort combinators + , Take + , Drop + , LengthOf + , HalfOf + ) +where + +import GHC.TypeLits (CmpNat, CmpSymbol, Nat, Symbol, type (*), + type (+), type (-)) + + +-- $setup +-- >>> import Data.Proxy +-- >>> :set -XDataKinds +-- >>> :set -XTypeFamilies + + +{-| Takes 1 element at a time from a list until the desired length is reached. + +==== __Examples__ + +>>> :kind! Take '[1, 2, 3, 4] 2 +Take '[1, 2, 3, 4] 2 :: [Nat] += '[1, 2] + +-} +type family Take (xs :: [k]) (n :: Nat) :: [k] where + Take '[] n = '[] + Take xs 0 = '[] + Take (x ': xs) n = (x ': Take xs (n - 1)) + + +{-| Drops 1 element at a time until the the dropped target is reached. + +==== __Examples__ + +>>> :kind! Drop '[1, 2, 3, 4] 2 +Drop '[1, 2, 3, 4] 2 :: [Nat] += '[3, 4] + + +>>> :kind! Drop '[1] 2 +Drop '[1] 2 :: [Nat] += '[] + +-} +type family Drop (xs :: [k]) (n :: Nat) :: [k] where + Drop '[] n = '[] + Drop xs 0 = xs + Drop (x ': xs) n = Drop xs (n - 1) + + +{-| Counts a list, 1 element at a time. + +==== __Examples__ + +>>> :kind! LengthOf '[1, 2, 3, 4] +LengthOf '[1, 2, 3, 4] :: Nat += 4 + +-} +type family LengthOf (xs :: [k]) :: Nat where + LengthOf '[] = 0 + LengthOf (x ': xs) = 1 + LengthOf xs + + +{-| Computes the midpoint of a number. + +N.B: maximum value that this works for depends on the reduction limit of the +type-checker. + +==== __Examples__ + +>>> :kind! HalfOf 99 +HalfOf 99 :: Nat += 49 + +>>> :kind! HalfOf 100 +HalfOf 100 :: Nat += 50 + +-} +type family HalfOf (n :: Nat) :: Nat where + -- optimizations for faster compilation + HalfOf 0 = 0 + HalfOf 1 = 1 + HalfOf 2 = 1 + HalfOf 3 = 1 + HalfOf 4 = 2 + HalfOf 5 = 2 + HalfOf 6 = 3 + HalfOf 7 = 3 + -- the general case + HalfOf n = HalfOfImpl n 0 n 'LT + +{-| Implements 'HalfOf'. -} +type family HalfOfImpl (n :: Nat) (i :: Nat) (dist :: Nat) (o :: Ordering) :: Nat where + HalfOfImpl n m dist 'GT = m - 1 + HalfOfImpl n m dist 'EQ = m + HalfOfImpl n m 1 'LT = m + HalfOfImpl n m dist 'LT = HalfOfImpl n (m + 2) (n - ((m + 2) * 2)) (CmpNat ((m + 2) * 2) n) + + +{-| Sort a list of type-level @symbols@ using merge sort. + +==== __Examples__ + +>>> :kind! SortSymbols '["xyz", "def", "abc"] +SortSymbols '["xyz", "def", "abc"] :: [Symbol] += '["abc", "def", "xyz"] + +-} +type family SortSymbols (xs :: [Symbol]) :: [Symbol] where + SortSymbols '[] = '[] + SortSymbols '[x] = '[x] + SortSymbols '[x, y] = MergeSymbols '[x] '[y] -- an optimization, could be removed + SortSymbols xs = SortSymbolsStep xs (HalfOf (LengthOf xs)) + + +{-| Used internally by @SortSymbols. -} +type family SortSymbolsStep (xs :: [Symbol]) (halfLen :: Nat) :: [Symbol] where + SortSymbolsStep xs halfLen = MergeSymbols + (SortSymbols (Take xs halfLen)) + (SortSymbols (Drop xs halfLen)) + +{-| Used internally by @SortSymbols. -} +type family MergeSymbols (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where + MergeSymbols xs '[] = xs + MergeSymbols '[] ys = ys + MergeSymbols (x ': xs) (y ': ys) = MergeSymbolsImpl (x ': xs) (y ': ys) (CmpSymbol x y) + +type family MergeSymbolsImpl (xs :: [Symbol]) (ys :: [Symbol]) (o :: Ordering) :: [Symbol] where + MergeSymbolsImpl (x ': xs) (y ': ys) 'GT = y ': MergeSymbols (x ': xs) ys + MergeSymbolsImpl (x ': xs) (y ': ys) leq = x ': MergeSymbols xs (y ': ys) diff --git a/src/System/TmpProc/Warp.hs b/src/System/TmpProc/Warp.hs new file mode 100644 --- /dev/null +++ b/src/System/TmpProc/Warp.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# OPTIONS_HADDOCK prune not-home #-} +{-| +Copyright : (c) 2020-2021 Tim Emiola +SPDX-License-Identifier: BSD3 +Maintainer : Tim Emiola + +Provides functions that make it easy to run /'Application's/ + that access services running as @tmp@ @procs@ in integration tests. + +-} +module System.TmpProc.Warp + ( -- * Continuation-style setup + testWithApplication + , testWithReadyApplication + , testWithTLSApplication + , testWithReadyTLSApplication + + -- * ServerHandle + , ServerHandle + , serverPort + , handles + , shutdown + , runServer + , runReadyServer + , runTLSServer + , runReadyTLSServer + + -- * Health check support + , checkHealth + ) + +where + +import Control.Concurrent (myThreadId, newEmptyMVar, putMVar, + readMVar, takeMVar, threadDelay, + throwTo) +import Control.Exception (ErrorCall (..)) +import Control.Monad (void, when) +import Control.Monad.Cont (cont, runCont) +import Network.Socket (Socket, close) +import Network.Wai (Application) +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Handler.WarpTLS as Warp +import UnliftIO (Async, async, bracket, cancel, + catch, onException, race, throwIO, + waitEither) + +import System.TmpProc.Docker (AreProcs, HList (..), HandlesOf, + startupAll, terminateAll, + withTmpProcs) + + +-- | Represents a started Warp application and any 'AreProcs' dependencies. +data ServerHandle procs = ServerHandle + { shServer :: !(Async ()) + , shPort :: !Warp.Port + , shSocket :: !Socket + , shHandles :: !(HandlesOf procs) + } + +-- | Runs an 'Application' with @ProcHandle@ dependencies on a free port. +runServer + :: AreProcs procs + => HList procs + -> (HandlesOf procs -> IO Application) + -> IO (ServerHandle procs) +runServer = runReadyServer doNothing + + +{-| Like 'runServer'; with an additional @ready@ that determines if the server is ready.'. -} +runReadyServer + :: AreProcs procs + => (Warp.Port -> IO ()) -- ^ throws an exception if the server is not ready + -> HList procs -- ^ defines the dependent @Proc@s + -> (HandlesOf procs -> IO Application) + -> IO (ServerHandle procs) +runReadyServer = runReadyServer' Warp.runSettingsSocket + + +{-| Like 'runServer'; the port is secured with 'Warp.TLSSettings'. -} +runTLSServer + :: AreProcs procs + => Warp.TLSSettings + -> HList procs + -> (HandlesOf procs -> IO Application) + -> IO (ServerHandle procs) +runTLSServer tlsSettings = runReadyServer' (Warp.runTLSSocket tlsSettings) doNothing + + +{-| Like 'runReadyServer'; the port is secured with 'Warp.TLSSettings'. -} +runReadyTLSServer + :: AreProcs procs + => Warp.TLSSettings + -> (Warp.Port -> IO ()) -- ^ throws an exception if the server is not ready + -> HList procs -- ^ defines the dependent @Proc@s + -> (HandlesOf procs -> IO Application) + -> IO (ServerHandle procs) +runReadyTLSServer tlsSettings = runReadyServer' (Warp.runTLSSocket tlsSettings) + + +-- | Used to implement 'runReadyServer' +runReadyServer' + :: AreProcs procs + => (Warp.Settings -> Socket -> Application -> IO ()) + -> (Warp.Port -> IO ()) -- ^ throws an exception if the server is not ready + -> HList procs -- ^ defines the dependent @Proc@s + -> (HandlesOf procs -> IO Application) + -> IO (ServerHandle procs) +runReadyServer' runApp check procs mkApp = do + callingThread <- myThreadId + h <- startupAll procs + (p, sock) <- Warp.openFreePort + signal <- newEmptyMVar + let settings = readySettings(putMVar signal ()) + app <- mkApp h + let wrappedApp request respond = + app request respond `catch` \ e -> do + when + (Warp.defaultShouldDisplayException e) + (throwTo callingThread e) + throwIO e + s <- async (pure wrappedApp >>= runApp settings sock) + aConfirm <- async (takeMVar signal) + let result = ServerHandle s p sock h + waitEither s aConfirm >>= \case + Left _ -> do + shutdown result + error "setup: server thread stopped unexpectedly" + Right _ -> do + check p `onException` shutdown result + pure result + + +-- | Shuts down the 'ServerHandle' server and its @tmp proc@ dependencies. +shutdown :: AreProcs procs => ServerHandle procs -> IO () +shutdown h = do + let ServerHandle { shServer, shSocket, shHandles } = h + terminateAll shHandles + cancel shServer + close shSocket + + +-- | The @'ServerHandle's@ @ProcHandles@. +handles :: AreProcs procs => ServerHandle procs -> HandlesOf procs +handles = shHandles + + +-- | The 'Warp.Port' on which the 'ServerHandle's server is running. +serverPort :: ServerHandle procs -> Warp.Port +serverPort = shPort + + +{-| Set up some @ProcHandles@ then run an 'Application' that uses them on a free + port. + +Allows the app to configure itself using the @tmp procs@, then provides a +callback with access to the handles. + +The @tmp procs@ are shut down when the application is shut down. +-} +testWithApplication + :: AreProcs procs + => HList procs + -> (HandlesOf procs -> IO Application) + -> ((HandlesOf procs, Warp.Port) -> IO a) + -> IO a +testWithApplication procs mkApp = runCont $ do + oh <- cont $ withTmpProcs procs + p <- cont $ Warp.testWithApplication $ mkApp oh + pure (oh, p) + + +{-| Like 'testWithApplication', but the port is secured using a 'Warp.TLSSettings. '-} +testWithTLSApplication + :: AreProcs procs + => Warp.TLSSettings + -> HList procs + -> (HandlesOf procs -> IO Application) + -> ((HandlesOf procs, Warp.Port) -> IO a) + -> IO a +testWithTLSApplication tlsSettings procs mkApp = runCont $ do + oh <- cont $ withTmpProcs procs + p <- cont $ withTLSApplicationSettings tlsSettings Warp.defaultSettings $ mkApp oh + pure (oh, p) + + +{-| Set up some @ProcHandles@ then run an 'Application' that uses them on a free + port. + +Allows the app to configure itself using the @tmp procs@, then provides a +callback with access to the handles. + +Also runs a @ready@ action that to determine if the application started +correctly. + +The @tmp procs@ are shut down when the application is shut down. +-} +testWithReadyApplication + :: AreProcs procs + => (Warp.Port -> IO ()) -- throws an exception if the server is not ready + -> HList procs + -> (HandlesOf procs -> IO Application) + -> ((HandlesOf procs, Warp.Port) -> IO a) + -> IO a +testWithReadyApplication check procs mkApp = runCont $ do + oh <- cont $ withTmpProcs procs + w <- cont $ bracket (mkWaiter check) doNothing + p <- cont $ Warp.testWithApplicationSettings (waiterSettings w) $ mkApp oh + _ <- cont $ bracket (waitFor w p) doNothing + return (oh, p) + + +{-| Like 'testWithReadyApplication'; the port is secured with 'Warp.TLSSettings'. -} +testWithReadyTLSApplication + :: AreProcs procs + => Warp.TLSSettings + -> (Warp.Port -> IO ()) -- throws an exception if the server is not ready + -> HList procs + -> (HandlesOf procs -> IO Application) + -> ((HandlesOf procs, Warp.Port) -> IO a) + -> IO a +testWithReadyTLSApplication tlsSettings check procs mkApp = runCont $ do + oh <- cont $ withTmpProcs procs + w <- cont $ bracket (mkWaiter check) doNothing + p <- cont $ withTLSApplicationSettings tlsSettings (waiterSettings w) $ mkApp oh + _ <- cont $ bracket (waitFor w p) doNothing + return (oh, p) + + +-- | Simplifies writing the health checks used by @ready@ variants of this module. +checkHealth :: Int -> IO (Either a b) -> IO () +checkHealth tries h = go tries + where + go 0 = error "healthy: server isn't healthy" + go n = h >>= \case + Left _ -> threadDelay pingPeriod >> go (n - 1) + Right _ -> pure () + + + +-- | A 'Warp.Settings' configured with a ready action. +-- +-- The ready action is used to check if a server is healthy. +readySettings :: IO () -> Warp.Settings +readySettings ready = Warp.setBeforeMainLoop ready Warp.defaultSettings + + + +-- | A 'Warp.Settings' configured with a ready action. +-- +-- The ready action is used to check if a server is healthy. +waiterSettings :: PortWaiter () -> Warp.Settings +waiterSettings w = Warp.setBeforeMainLoop (notify w ()) Warp.defaultSettings + + + +-- | Simplifies creation of a ready action. +data PortWaiter a = + PortWaiter + { notify :: a -> IO () + , waitFor :: Warp.Port -> IO a + } + + +-- | Simplifies creation of a ready action. +mkWaiter :: (Warp.Port -> IO a) -> IO (PortWaiter a) +mkWaiter check = do + mvar <- newEmptyMVar + let waitFor p = do + res <- readMVar mvar + void $ check p + pure res + pure PortWaiter + { notify = putMVar mvar + , waitFor + } + + +-- | Gap between service pings in milliseconds. +pingPeriod :: Int +pingPeriod = 1000000 + + +-- | Like 'Warp.testWithApplicationSettings' , but the port is secured using the +-- provided 'Warp.TLSSettings'. +withTLSApplicationSettings + :: Warp.TLSSettings + -> Warp.Settings + -> IO Application + -> (Warp.Port -> IO a) + -> IO a +withTLSApplicationSettings tlsSettings settings mkApp action = do + app <- mkApp + withFreePort $ \ (p, sock) -> do + started <- mkWaiter doNothing + let settings' = Warp.setBeforeMainLoop (notify started ()) settings + result <- race + (Warp.runTLSSocket tlsSettings settings' sock app) + (waitFor started p >> action p) + case result of + Left () -> throwIO $ ErrorCall "Unexpected: runSettingsSocket exited" + Right x -> return x + + +-- | Like "Network.Wai.Handler.Warp.openFreePort" but closes the socket before exiting. +withFreePort :: ((Warp.Port, Socket) -> IO a) -> IO a +withFreePort = bracket Warp.openFreePort (close . snd) + + +-- | Improves readability... +doNothing :: b -> IO () +doNothing = const $ pure () diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Main (main) where + +import Test.Hspec + +import System.IO +import qualified Test.System.TmpProc.HttpBinSpec as HB +import qualified Test.System.TmpProc.WarpSpec as W3 + +main :: IO () +main = do + hSetBuffering stdin NoBuffering + hSetBuffering stdout NoBuffering + hspec $ do + HB.spec + W3.spec diff --git a/test/Test/Hspec/TmpProc.hs b/test/Test/Hspec/TmpProc.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/TmpProc.hs @@ -0,0 +1,23 @@ +module Test.Hspec.TmpProc + ( -- * functions + tdescribe + ) +where + +import System.TmpProc (hasDocker) +import Test.Hspec + + +{-| Like 'describe', but makes the specs @pending@ when docker is unavailable. -} +tdescribe :: HasCallStack => String -> SpecWith a -> SpecWith a +tdescribe label action = do + noDocker <- not <$> runIO hasDocker + if noDocker then tmpPending label action else describe label action + + +tmpPending :: HasCallStack => String -> SpecWith a -> SpecWith a +tmpPending label spec = before_ (pendingWith noDockerMessage) $ describe label spec + + +noDockerMessage :: String +noDockerMessage = "docker could not be detected" diff --git a/test/Test/HttpBin.hs b/test/Test/HttpBin.hs new file mode 100644 --- /dev/null +++ b/test/Test/HttpBin.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +module Test.HttpBin where + +import qualified Data.ByteString.Char8 as C8 +import Data.List (foldl') +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Network.HTTP.Req + +import System.TmpProc (HList (..), HandlesOf, HostIpAddress, + Pinged (..), Proc (..), ProcHandle (..), + SvcURI, manyNamed, startupAll, toPinged, + (&:)) + + +setupHandles :: IO (HandlesOf '[HttpBinTest, HttpBinTest2, HttpBinTest3]) +setupHandles = startupAll $ HttpBinTest &: HttpBinTest2 &: HttpBinTest3 &: HNil + + +{-| A data type representing a connection to a HttpBin server. -} +data HttpBinTest = HttpBinTest + +{-| Run HttpBin as temporary process. -} +instance Proc HttpBinTest where + type Image HttpBinTest = "kennethreitz/httpbin" + type Name HttpBinTest = "http-bin-test" + + uriOf = mkUri' + runArgs = [] + reset _ = pure () + ping = ping' + + +{-| Another data type representing a connection to a HttpBin server. + +Used in this module to allow mulitple types in test lists, to improve the +chances of detecting type-related compilationr errors. + +-} +data HttpBinTest2 = HttpBinTest2 + +{-| Run HttpBin as temporary process. -} +instance Proc HttpBinTest2 where + type Image HttpBinTest2 = "kennethreitz/httpbin" + type Name HttpBinTest2 = "http-bin-test-2" + + uriOf = mkUri' + runArgs = [] + reset _ = pure () + ping = ping' + + +{-| Yet another data type representing a connection to a HttpBin server. + +Used in this module to allow mulitple types in test lists, to improve the +chances of detecting type-related compilationr errors. + +-} +data HttpBinTest3 = HttpBinTest3 + +{-| Run HttpBin as temporary process. -} +instance Proc HttpBinTest3 where + type Image HttpBinTest3 = "kennethreitz/httpbin" + type Name HttpBinTest3 = "http-bin-test-3" + + uriOf = mkUri' + runArgs = [] + reset _ = pure () + ping = ping' + + +{-| Make a uri access the http-bin server. -} +mkUri' :: HostIpAddress -> SvcURI +mkUri' ip = "http://" <> C8.pack (Text.unpack ip) <> "/" + + +ping' :: ProcHandle a -> IO Pinged +ping' handle = toPinged @HttpException Proxy $ do + gotStatus <- handleGet handle "/status/200" + if (gotStatus == 200) then pure OK else pure NotOK + + +-- | Determine the status from a Get on localhost. +handleGet :: ProcHandle a -> Text -> IO Int +handleGet handle urlPath = runReq defaultHttpConfig $ do + r <- req GET (handleUrl handle urlPath) NoReqBody ignoreResponse $ mempty + return $ responseStatusCode r + + +handleUrl :: ProcHandle a -> Text -> Url 'Http +handleUrl handle urlPath = foldl' (/:) (http $ hAddr handle) + $ Text.splitOn "/" $ Text.dropWhile (== '/') urlPath + + +{-| Verify that the compile time type computations related to 'manyNamed' are ok. -} +typeLevelCheck1 :: IO (HandlesOf '[HttpBinTest3]) +typeLevelCheck1 = do + allHandles <- setupHandles + pure $ manyNamed @'["http-bin-test-3"] Proxy allHandles + + +typeLevelCheck2 :: IO (HandlesOf '[HttpBinTest, HttpBinTest3]) +typeLevelCheck2 = do + allHandles <- setupHandles + pure $ manyNamed @'["http-bin-test", "http-bin-test-3"] Proxy allHandles + + +typeLevelCheck3 :: IO (HandlesOf '[HttpBinTest3, HttpBinTest]) +typeLevelCheck3 = do + allHandles <- setupHandles + pure $ manyNamed @'["http-bin-test-3", "http-bin-test"] Proxy allHandles + + +typeLevelCheck4 :: IO (HandlesOf '[HttpBinTest2, HttpBinTest3, HttpBinTest]) +typeLevelCheck4 = do + allHandles <- setupHandles + pure $ manyNamed @'["http-bin-test-2", "http-bin-test-3", "http-bin-test"] Proxy allHandles diff --git a/test/Test/SimpleServer.hs b/test/Test/SimpleServer.hs new file mode 100644 --- /dev/null +++ b/test/Test/SimpleServer.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +module Test.SimpleServer + ( -- * functions + statusOfGet + , statusOfGet' + + -- * test constants + , defaultTLSSettings + ) +where + +import Data.List (foldl') + +import Data.Text (Text) +import qualified Data.Text as Text + +import qualified Network.Connection as HC +import qualified Network.HTTP.Client as HC +import Network.HTTP.Client.TLS (mkManagerSettings) +import Network.HTTP.Req +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Handler.WarpTLS as Warp + + +-- | Determine the status from a Get on localhost. +statusOfGet :: Warp.Port -> Text -> IO Int +statusOfGet p path = runReq defaultHttpConfig $ do + r <- req GET (localUrl path) NoReqBody ignoreResponse $ port p + return $ responseStatusCode r + + +statusOfGet' :: Int -> Text -> IO Int +statusOfGet' p path = do + manager <- mkSimpleTLSManager + runReq (defaultHttpConfig { httpConfigAltManager = Just manager }) $ do + r <- req GET (localHttpsUrl path) NoReqBody ignoreResponse $ port p + return $ responseStatusCode r + + +localUrl :: Text -> Url 'Http +localUrl p = foldl' (/:) (http "localhost") + $ Text.splitOn "/" $ Text.dropWhile (== '/') p + + +localHttpsUrl :: Text -> Url 'Https +localHttpsUrl p = foldl' (/:) (https "localhost") + $ Text.splitOn "/" $ Text.dropWhile (== '/') p + + +defaultTLSSettings :: Warp.TLSSettings +defaultTLSSettings = Warp.tlsSettings "test_certs/certificate.pem" "test_certs/key.pem" + + +mkSimpleTLSManager :: IO HC.Manager +mkSimpleTLSManager = HC.newManager + $ mkManagerSettings (HC.TLSSettingsSimple True False False) Nothing diff --git a/test/Test/System/TmpProc/Hspec.hs b/test/Test/System/TmpProc/Hspec.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/TmpProc/Hspec.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.System.TmpProc.Hspec (noDockerSpec) where + +import Test.Hspec + + +-- | Used as pending alternative when docker is unavailable. +noDockerSpec :: String -> Spec +noDockerSpec desc = describe desc $ + it "cannot run as docker is unavailable" pending diff --git a/test/Test/System/TmpProc/HttpBinSpec.hs b/test/Test/System/TmpProc/HttpBinSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/TmpProc/HttpBinSpec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +module Test.System.TmpProc.HttpBinSpec where + +import Test.Hspec + +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Text as Text + +import System.TmpProc (Pinged (..), ixPing, ixReset, nameOf, + terminateAll) +import Test.Hspec.TmpProc (tdescribe) +import Test.HttpBin + + +spec :: Spec +spec = tdescribe ("Tmp.Proc: " ++ Text.unpack (nameOf HttpBinTest)) $ 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 a 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 + + 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 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 different Proc by type" $ \hs + -> ixReset @HttpBinTest2 Proxy hs `shouldReturn`() diff --git a/test/Test/System/TmpProc/WarpSpec.hs b/test/Test/System/TmpProc/WarpSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/TmpProc/WarpSpec.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +module Test.System.TmpProc.WarpSpec where + +import Test.Hspec + +import Control.Exception (catch) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Network.HTTP.Req +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 Test.Hspec.TmpProc (tdescribe) +import Test.HttpBin +import Test.SimpleServer (defaultTLSSettings, statusOfGet, + statusOfGet') + + +spec :: Spec +spec = tdescribe "Tmp.Proc: Warp server with Tmp.Proc dependency" $ do + beforeAllSpec >> aroundSpec + + +testProcs :: HList '[HttpBinTest] +testProcs = HttpBinTest `HCons` HNil + + +testApp :: HandlesOf '[HttpBinTest] -> IO Application +testApp hs = mkTestApp' + (pingOrFail $ handleOf @"http-bin-test" Proxy hs) + (pingOrFail $ handleOf @"http-bin-test" Proxy hs) + + +setupBeforeAll :: IO (ServerHandle '[HttpBinTest]) +setupBeforeAll = runServer testProcs testApp + +setupBeforeAllTls :: IO (ServerHandle '[HttpBinTest]) +setupBeforeAllTls = runTLSServer defaultTLSSettings testProcs testApp + + +suffixAround, suffixBeforeAll, prefixHttp, prefixHttps :: String +suffixAround = " when the server is restarted for each test" +suffixBeforeAll = " when the server starts beforeAll tests" +prefixHttp = "Warp+HTTP:" +prefixHttps = "Warp+HTTPS:" + + +beforeAllSpec :: Spec +beforeAllSpec = do + checkBeforeAll prefixHttp setupBeforeAll statusOfGet + checkBeforeAll prefixHttps setupBeforeAllTls statusOfGet' + + +checkBeforeAll + :: String + -> IO (ServerHandle '[HttpBinTest]) + -> (Int -> Text -> IO Int) -> Spec +checkBeforeAll descPrefix setup getter = beforeAll setup $ afterAll shutdown $ do + describe (descPrefix ++ suffixBeforeAll) $ do + + it "should ping the proc handle" $ \sh -> + ixPing @"http-bin-test" Proxy (handles sh) `shouldReturn` OK + + it "should invoke the warp server via its port" $ \sh -> + getter (serverPort sh) "test" `shouldReturn` 200 + + +setupAround :: ((HandlesOf '[HttpBinTest], Int) -> IO a) -> IO a +setupAround = testWithApplication testProcs testApp + + +setupAroundTls :: ((HandlesOf '[HttpBinTest], Int) -> IO a) -> IO a +setupAroundTls = testWithTLSApplication defaultTLSSettings testProcs testApp + + +aroundSpec :: Spec +aroundSpec = do + checkEachTest prefixHttp setupAround statusOfGet + checkEachTest prefixHttps setupAroundTls statusOfGet' + + +checkEachTest + :: String + -> (ActionWith (HandlesOf '[HttpBinTest], Int) -> IO ()) + -> (Int -> Text -> IO Int) + -> Spec +checkEachTest descPrefix setup getter = around setup $ do + describe (descPrefix ++ suffixAround) $ do + + it "should ping the proc handle" $ \(h, _) -> + ixPing @"http-bin-test" Proxy h `shouldReturn` OK + + it "should invoke the warp server via its port" $ \(_, p) -> + getter p "test" `shouldReturn` 200 + + +-- | A WAI app that triggers an action on a TmpProc dependency on /test, and +-- responds to health checks on /health. +mkTestApp' + :: IO () + -> IO () + -> IO Application +mkTestApp' onStart onTest = onStart >> pure app + where + app rq respond + | isHealthReq rq = respond $ responseLBS status200 [] "ok" + app rq respond + | isTestReq rq = onTest >> respond (responseLBS status200 [] "ok") + app _ respond = respond $ responseLBS status400 [] "Incorrect request" + + isHealthReq = isReqPathsEq ["health"] + isTestReq = isReqPathsEq ["test"] + isReqPathsEq x rq = x == pathInfo rq + + +pingOrFail :: ProcHandle a -> IO () +pingOrFail handle = do + let catchHttp x = x `catch` (\(_ :: HttpException) -> + fail "tmp proc:httpbin:ping failed") + catchHttp $ do + gotStatus <- handleGet handle "/status/200" + if (gotStatus == 200) then pure () else + fail "tmp proc:httpbin:incorrect ping status" diff --git a/test_certs/certificate.csr b/test_certs/certificate.csr new file mode 100644 --- /dev/null +++ b/test_certs/certificate.csr @@ -0,0 +1,27 @@ +-----BEGIN CERTIFICATE REQUEST----- +MIIElTCCAn0CAQAwUDELMAkGA1UEBhMCSlAxDDAKBgNVBAgMA0ZVSzERMA8GA1UE +BwwISXRvc2hpbWExDDAKBgNVBAoMA0RpczESMBAGA1UEAwwJbG9jYWxob3N0MIIC +IjANBgkqhkiG9w0BAQEFAAOCAg8AMIICCgKCAgEA6I1BtufmkS2ztej42UsL9CKF +dvO64s1qLjlmKSx9pipR6O47mXqo1GLWthisLycHiVEdhy7/tPeWvuWvWQi3Ts/H +zvDS290tfKNOsCAC8lRAmW6ttLjJXFCJ9orS+mbCCdYKVwg8W99VKDZtv8krgJLl +s9GfU3kWNyUAL8V0FHSupZnap659qi2uG9sm822eRzLXvk+SjXG4qlbxyNTX+pEh +1WWNzshDg+lxp+b7rb6a7qUwOtSFyQTBSkDfIgh0w9nEju2TvKQWQACVujxtnr1F +nnaQ0PoOnz3AUq0O6sGi+Bw35C6aD/yfeF/u7s8Nt7VRa+zkDa9fNLwdBhrvqvDA +6ZYuQCjDDLmkCburNQNQWI+M4172A6DwGs9qEWHJPCCNqs1P82GMzaKva7BSebjA +juwpWdaU8T8UuJQZRDauofhEAqlCkrPRU2h+4d9rA2hYA+1rnOi2A8Ze2YTDm+BS +gU237oZyj4+d5R/kiQPIPXYVFZocN5luvzcg17EbNRqjR+w6ZiQS7M9Ow5tozqCx +ocZyjkYEGkQwuDtRnzWphWdZguISY5/wGD6cRLgA28Ww0/MNOvs891GDJyBIAiag +9xBtdNTA7Q1dGLb72Pn3UP/bSLvxSAFTPsE6x8xmkPuNPgx84KHiV+SqxFz9Y9ea +wMla4rxAbdoVV3J1J00CAwEAAaAAMA0GCSqGSIb3DQEBCwUAA4ICAQDUbiS9Tkkn +5ohDf07CZSsMOJRHsbWCe9UX4IjY9nR+FeHszcOY00H2gCoYLdiKA8JWeeeeBDBr +ymAhl4WQMaMjUQoPAjTY3v+mNZpltLlYzUYsWl6LVXoFGKk4V9tforx6XGzCcicr +YF1Vmsr9Bp32GKiqESjdaVBKWp+9FFqZQrI7ymKVbXJ9WdckHCsUTnZWJQbN3Doh +sy/VWW8Jlq6+gDv9gaLBjXtPfIhw+EU/5zURkmZcRNpwW4TTZbOaR58w64ecWuKn +k0hmqMN0uA4gj2VwxtErJSAZ3EawwqGEZ8j29eKDWwcZS3ptg+dQUQzMuhF7J1OK +rz1AmdQViuy3NYMNFNsD0cYeZXfGoe4iwpNxeH6lPbsth5vxIs0eGMrLW5/40fgt +Kp0NTE23dfkaCHolfCRs6s36WhwGooUn0MnisZDclCYPjgmbt6fyZs2273KC2fUK +Dlb256jVx1imo00muNATChA2nd1ynrdQgniEZZULGd3s6NPVrLgqCu6we6Vcbn6S +pH+nwSTSY+jwWPUl41dVbNdc7q72z0TLGlPUrk6DwqVJMunjn8j6X1RyjgfckYQH +LFAneruxFFd9sHYYDoC6Vq8nu+cyHFlDElbI3Vedclh2ddXZOpDZT8pAwWNM11Et ++9HudI6f7d/0ttbjxMoxWaewGFsFvJRFmw== +-----END CERTIFICATE REQUEST----- diff --git a/test_certs/certificate.pem b/test_certs/certificate.pem new file mode 100644 --- /dev/null +++ b/test_certs/certificate.pem @@ -0,0 +1,30 @@ +-----BEGIN CERTIFICATE----- +MIIFHDCCAwQCCQCZ1MePuiS6ezANBgkqhkiG9w0BAQsFADBQMQswCQYDVQQGEwJK +UDEMMAoGA1UECAwDRlVLMREwDwYDVQQHDAhJdG9zaGltYTEMMAoGA1UECgwDRGlz +MRIwEAYDVQQDDAlsb2NhbGhvc3QwHhcNMTkwMjI2MDY0MzU5WhcNMTkwMzI4MDY0 +MzU5WjBQMQswCQYDVQQGEwJKUDEMMAoGA1UECAwDRlVLMREwDwYDVQQHDAhJdG9z +aGltYTEMMAoGA1UECgwDRGlzMRIwEAYDVQQDDAlsb2NhbGhvc3QwggIiMA0GCSqG +SIb3DQEBAQUAA4ICDwAwggIKAoICAQDojUG25+aRLbO16PjZSwv0IoV287rizWou +OWYpLH2mKlHo7juZeqjUYta2GKwvJweJUR2HLv+095a+5a9ZCLdOz8fO8NLb3S18 +o06wIALyVECZbq20uMlcUIn2itL6ZsIJ1gpXCDxb31UoNm2/ySuAkuWz0Z9TeRY3 +JQAvxXQUdK6lmdqnrn2qLa4b2ybzbZ5HMte+T5KNcbiqVvHI1Nf6kSHVZY3OyEOD +6XGn5vutvprupTA61IXJBMFKQN8iCHTD2cSO7ZO8pBZAAJW6PG2evUWedpDQ+g6f +PcBSrQ7qwaL4HDfkLpoP/J94X+7uzw23tVFr7OQNr180vB0GGu+q8MDpli5AKMMM +uaQJu6s1A1BYj4zjXvYDoPAaz2oRYck8II2qzU/zYYzNoq9rsFJ5uMCO7ClZ1pTx +PxS4lBlENq6h+EQCqUKSs9FTaH7h32sDaFgD7Wuc6LYDxl7ZhMOb4FKBTbfuhnKP +j53lH+SJA8g9dhUVmhw3mW6/NyDXsRs1GqNH7DpmJBLsz07Dm2jOoLGhxnKORgQa +RDC4O1GfNamFZ1mC4hJjn/AYPpxEuADbxbDT8w06+zz3UYMnIEgCJqD3EG101MDt +DV0YtvvY+fdQ/9tIu/FIAVM+wTrHzGaQ+40+DHzgoeJX5KrEXP1j15rAyVrivEBt +2hVXcnUnTQIDAQABMA0GCSqGSIb3DQEBCwUAA4ICAQCOi2MIn+PSjIEKz1p4x2b6 +O4trvi3epP7BXIhseU++JhqR0x+hgR/Xmmir5lw5yuRwmnlG005rz9fLEK1q8W1Q +MZRQDU/2hX3+JJ/QczIaaOqQrnlzwiOj69TZtBxi9nNxMDtzoUA644s+2yngufxr +PIag7UupoeQVFrkSRgyREdszMKtZ0d7oZ0EZqEod0uUH89kkI3IE3fWW/fUtEIfV +ymscYPHlvIBCJQ9c2S/wXNxakXjCwYbiHE8yGeEJxBYcmSuZkei/kLvKmBuTmzo0 +8rENCNSyvL1EBDIe9Gp2pvFhYUepjhq8lsbWV7EjMY+hqiMyuHk7v6HS14nmg9fv +1+3J61NsunHPzqSYzf3YI8aq1r4JaC644XlRQgrVuZtcH+lD785GTn3tBN0eYEen +6qGThiUIgC5VzuGrRX4FWoZsAE46NWVU0tMmYnpmEAdJUr3PEEFFkNNG1CzobYPK +e9otNUiRJ5A9PGCHK9auWkH5/7EJECaO5WW8wgBspQYu4GJM/NF5Yioph81X4XSi +l6TROBWapD2l3Z7v5kYL0N1SqOvdO2XuJKtKN8GTlSXRDHWg24MhGkb66M70H1Mw +dJMsxq+zd2SEVFn8+MhPwAN3q78l6W9XRxSn7Ox2VY8g9Unz4f2SIWL0AHPeKHAc +ES2bGzGq8NsKtYeky1Pjow== +-----END CERTIFICATE----- diff --git a/test_certs/key.pem b/test_certs/key.pem new file mode 100644 --- /dev/null +++ b/test_certs/key.pem @@ -0,0 +1,51 @@ +-----BEGIN RSA PRIVATE KEY----- +MIIJJwIBAAKCAgEA6I1BtufmkS2ztej42UsL9CKFdvO64s1qLjlmKSx9pipR6O47 +mXqo1GLWthisLycHiVEdhy7/tPeWvuWvWQi3Ts/HzvDS290tfKNOsCAC8lRAmW6t +tLjJXFCJ9orS+mbCCdYKVwg8W99VKDZtv8krgJLls9GfU3kWNyUAL8V0FHSupZna +p659qi2uG9sm822eRzLXvk+SjXG4qlbxyNTX+pEh1WWNzshDg+lxp+b7rb6a7qUw +OtSFyQTBSkDfIgh0w9nEju2TvKQWQACVujxtnr1FnnaQ0PoOnz3AUq0O6sGi+Bw3 +5C6aD/yfeF/u7s8Nt7VRa+zkDa9fNLwdBhrvqvDA6ZYuQCjDDLmkCburNQNQWI+M +4172A6DwGs9qEWHJPCCNqs1P82GMzaKva7BSebjAjuwpWdaU8T8UuJQZRDauofhE +AqlCkrPRU2h+4d9rA2hYA+1rnOi2A8Ze2YTDm+BSgU237oZyj4+d5R/kiQPIPXYV +FZocN5luvzcg17EbNRqjR+w6ZiQS7M9Ow5tozqCxocZyjkYEGkQwuDtRnzWphWdZ +guISY5/wGD6cRLgA28Ww0/MNOvs891GDJyBIAiag9xBtdNTA7Q1dGLb72Pn3UP/b +SLvxSAFTPsE6x8xmkPuNPgx84KHiV+SqxFz9Y9eawMla4rxAbdoVV3J1J00CAwEA +AQKCAgBRPLdOG+ixopN64q27yrmcSUryaOZKQJPtHeQQUhh6qaH/iumLDgxYVUbI +SgosVqgNUibMiKCPKUah3T7KDX9rqq4UHpCqebNgLPRaFnSxDrmaX82SqlK9Su1H +EOvuyWLTaNAn4xqixXvMFmd0beQigC56CKpt0IjwLp7IEWQhmTlBZGO72/rOLjL6 +TC5pL0vxd1Niig2aF7X423KPQ7tHLtfw4g8Nw2vCcxRfIROeeE1LPK2Cf6dUt7KG +K+9Gxklz+WjuvRO0/GVBanLjoiRxJZFib+za89+TxVCgERB69bXmkoT700PCfe9/ +b5PaHL6gBFkzKIfqN+88TtKcxWAfXo52xqbNiMTnf9SHmbNQjjB2qWai2EyvZvv9 ++ZRqtjohYumA4Osm/TmGgIV2LvEAsxZ45e+zJ35pzqCr9p2trHMHS6atA8kahij0 +ZWw7z+rl7uSgghJnanL4fdEhUH5Fu5s8d9a72Vhs8VAs1PBsY6waHAVVcaJeHA1b +GaCaDEuebM7HRnr9QmQ99iV778uGuezkm5sUUNmiKsBqskUdhtQZiWMlzZSNiCqO +rbPb7Fl1ovLwUsW7oPLNane4FMjFl7y9R78rpcNu34Ok2mAEAbvaLH2UeOGlVisM +cCilEg/pwfg9GGPgThJI1c5QKbUBEKlBBW1mq8ONFUPhIJD1gQKCAQEA9AlqZCWX +uaZGN4OfYI1avtmIkYBtSZ78OqGMIZZ5S8FpLIQcONPlMWJFgrXM8rCIKnJn11WV +MX7B7V+RoDMUTZue8cNV8Fvx/GEuwNF0lpXI8SAEZSez2v4lEkHU5CShZqZa4+LH +JoYndzwbVzHoc/vyRN67IBlBjTOgdhOCwKccuKTdgZeFvSfUxlIeQZq8j3L05hUQ +zhEy8El8q5Uaqj7z2e+aOB6q7fwtgH+LDlBFB6SxashrgfMwez7ZJC/NdKxl2L0K +ND2A7qmsUUFhRwzd1QHH2f4td8TrwAgUZIJEidAgEzLbWaeJ3zbyADmZo1EjBVOH +Tfvxc0ntwyxyXQKCAQEA8/O1QkwPjxaCsVBv7AZSqHbZAa3y0aZKP8fThR6qpBOu +ZiDRWqD0+tKIXtFyUkt3W7oxaK9v2Y6qzRtCYP6VPXIPuHPreGbnZRPXSz2BAf+W +XIhE4ALcAYDSX0qJ1Mz6f76fMGN7PRPPBFqQI7/rO9xUwzuR+RuhpD6eTpjGSsNH +JBluLpYK5oKbCej29wHQnT9RYUZBPkXXEJqH0JgLYJ2qhCt0lj7UWe1mTOwcN+iz +Or4GmlxPejNGRl1S4HcuZ7nIkBa3R7dpUFfRDqfmt14pc7bOZA/LTdFMJdcmxgK3 +ME1JFZ0HHdfsdSW/47fWwRCi8lE/Gt6yvJ3aZNsZsQKCAQBx69tQuQPlVKu+yqEi +L5rHMUHButRJ5AAXVsbV/yrMpJN2ho2uMazyqs+MP1ZXjPVj61hye69UFbpuF4kh +4fZ+bEF81xVNSX7jtHJg7OaiTXYqqimjFy+s8atYpIa/oiH+i3Yun/UcFNBjpxmU +UOYVDu6AHAH68A9b3VfxBxao3NpZkA0frB5wuSFpG3ioY5XW2XFd30OjDwBaj9O1 +Pbve8dhgSqwRuq9MvcZ4EBJYMjynXsi78qfNWDuvrR0s+WvOJZS94zHaRUPlJiwd +GopQ4r7D6zrilveey7zKPntWmEFqnE/85mbjqYSBQWMjm8APL5dLqzykuRJ0IXTv +Ada5AoIBAArr4DOFoDSxt0wk473XUqAEIhb3KKXGIhDU611MUCtkTix4T6cVCaKp +Bj3odovEoSVUIp4jLIi64F6qV8Br5VaI4rdJSUNsp/NYfgz6RepG/P5Lg3nb5umS +UNi/R4hlXNmXOR07dur3Fg+F1mojT26woILVCeXzHLtzqjaulEIImAi/srUXNom3 +UyWQbm4EgMhpa0VFleopykUOBgKKrAe5R0b/gwqu6WbVP/01nNXL7yo0E6uZcl1w +KjdAOlOeQk+We6onujDVvzs/kzZqweN3rbdmebr1Eg77zcLr7Op0eKsK6riy/PyT +DBz6gaq6Mj0Wd5UNmhuj2LClCH/3ZyECggEALeaBlOCBR/r+CXIk0wQm2CCzsKH8 +MgScDBUQniyxL0dhXvIIcvhb2k+watUzGWgt33FjT2jogCuaC0LkxsuhnhgAP8I7 +eeWwGa2dSyRcl4vKZi43hkGDmIp9eTMY9mYxn7+FMnTQ2JLDbuaU/lF10Nk58Yqb +0K/OeSRMUwZcv8Am3lav+YUad1+nPg6JxdhDZ4u09LXtdshhr9VJfMKz21+lhLGT +oRgvyHQFKPinSn+FLzYu5rdZCiTDPaeFU6TzQec7QGnunuOCEpc4iiT+CfpSixwo +BnjO6N0VQhN6hPrVLc730cq9GhFlK/dOgvnJtfsruoUNctMezPigPNG2ng== +-----END RSA PRIVATE KEY----- diff --git a/tmp-proc.cabal b/tmp-proc.cabal new file mode 100644 --- /dev/null +++ b/tmp-proc.cabal @@ -0,0 +1,135 @@ +cabal-version: 3.0 +name: tmp-proc +version: 0.5.0.0 +synopsis: Run 'tmp' processes in integration tests +description: + @tmp-proc@ runs services in docker containers for use in integration tests. + + It aims to make using these services become like accessing /tmp/ processes, + similar to how /tmp/ file or directories are used. + + It aspires to provide a user-friendly API, while including useful features + such as + + * launch of multiple services on docker during test setup + + * delayed test execution until the launched services are available + + * simplified use of connections to the services from a [WAI](https://hackage.haskell.org/package/wai) server under test + + * good integration with haskell testing frameworks like [hspec](https://hspec.github.io) + and [tasty](https://hackage.haskell.org/package/tasty) + +license: BSD-3-Clause +license-file: LICENSE +copyright: 2020 Tim Emiola +author: Tim Emiola +maintainer: adetokunbo@users.noreply.github.com +category: testing, docker +bug-reports: https://github.com/adetokunbo/tmp-proc/issues +build-type: Simple +extra-source-files: + ChangeLog.md + test_certs/*.csr + test_certs/*.pem +tested-with: + GHC == 8.10.5 + +source-repository head + type: git + location: https://github.com/adetokunbo/tmp-proc.git + +library + exposed-modules: + System.TmpProc + System.TmpProc.Docker + System.TmpProc.TypeLevel + System.TmpProc.TypeLevel.Sort + System.TmpProc.Warp + + hs-source-dirs: src + build-depends: + , async ^>=2.2.1 + , base >=4.11 && <4.16 + , bytestring >=0.10.8.2 && <0.12 + , mtl ^>=2.2.2 + , network >=2.6.3.6 && <3.2 + , process ^>=1.6.3.0 + , text ^>=1.2.3 + , unliftio ^>=0.2.7 + , wai ^>=3.2.1 + , warp >=3.2.3 && <3.4 + , warp-tls >=3.2.4 && <3.4 + + default-language: Haskell2010 + ghc-options: -fno-ignore-asserts -Wall + +test-suite integration-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Hspec.TmpProc + Test.HttpBin + Test.SimpleServer + Test.System.TmpProc.Hspec + Test.System.TmpProc.HttpBinSpec + Test.System.TmpProc.WarpSpec + + hs-source-dirs: test + build-depends: + , base + , bytestring + , connection + , data-default + , hspec + , http-client + , http-client-tls + , http-types + , req + , text + , tmp-proc + , wai + , warp + , warp-tls + + default-language: Haskell2010 + ghc-options: + -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts -Wall + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: + , base + , doctest >=0.8 + , tmp-proc + + hs-source-dirs: doctest + default-language: Haskell2010 + ghc-options: -threaded + +-- This is not currently working in the nix build environment. +-- +-- executable readme +-- if os(windows) +-- buildable: False + +-- build-tool-depends: markdown-unlit:markdown-unlit +-- ghc-options: -pgmL markdown-unlit +-- main-is: README.lhs +-- default-language: Haskell2010 +-- build-depends: +-- , base +-- , bytestring +-- , connection +-- , data-default +-- , hspec +-- , http-client +-- , http-client-tls +-- , http-types +-- , req +-- , text +-- , tmp-proc +-- , wai +-- , warp +-- , warp-tls