tmp-proc (empty) → 0.5.0.0
raw patch · 20 files changed
+2228/−0 lines, 20 filesdep +asyncdep +basedep +bytestringsetup-changed
Dependencies added: async, base, bytestring, connection, data-default, doctest, hspec, http-client, http-client-tls, http-types, mtl, network, process, req, text, tmp-proc, unliftio, wai, warp, warp-tls
Files
- ChangeLog.md +40/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- doctest/Main.hs +7/−0
- src/System/TmpProc.hs +23/−0
- src/System/TmpProc/Docker.hs +719/−0
- src/System/TmpProc/TypeLevel.hs +268/−0
- src/System/TmpProc/TypeLevel/Sort.hs +169/−0
- src/System/TmpProc/Warp.hs +315/−0
- test/Spec.hs +17/−0
- test/Test/Hspec/TmpProc.hs +23/−0
- test/Test/HttpBin.hs +123/−0
- test/Test/SimpleServer.hs +57/−0
- test/Test/System/TmpProc/Hspec.hs +11/−0
- test/Test/System/TmpProc/HttpBinSpec.hs +45/−0
- test/Test/System/TmpProc/WarpSpec.hs +136/−0
- test_certs/certificate.csr +27/−0
- test_certs/certificate.pem +30/−0
- test_certs/key.pem +51/−0
- tmp-proc.cabal +135/−0
+ ChangeLog.md view
@@ -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
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ doctest/Main.hs view
@@ -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"+ ]
+ src/System/TmpProc.hs view
@@ -0,0 +1,23 @@+{-|+Copyright : (c) 2020-2021 Tim Emiola+SPDX-License-Identifier: BSD3+Maintainer : Tim Emiola <adetokunbo@users.noreply.github.com>++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
+ src/System/TmpProc/Docker.hs view
@@ -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 <adetokunbo@users.noreply.github.com>++Provides the core data types and combinators used to launch temporary /(tmp)/+processes /(procs)/ using docker.++@tmp-proc@ aims to simplify integration tests that use dockerizable services.++* Basically, @tmp-proc@ helps launch services used in integration test on docker++* While it's possible to write integration tests that use services hosted on+ docker /without/ @tmp-proc@, @tmp-proc@ aims to make writing those kind of+ tests easier, by providing types and combinators that take care of++ * launching services on docker+ * obtaining references to the launched service+ * cleaning up docker once the tests are finished++This module does all that via its data types:++* A /'Proc'/ specifies a docker image that provides a service and other details+ related to its use in tests.++* A /'ProcHandle'/ is created whenever a service specifed by a /'Proc'/ is+started, and is used to access and eventually terminate the running service.++* Some @'Proc's@ will also be /'Connectable'/; these specify how access the+service via some /'Conn'-ection/ type.++-}+module System.TmpProc.Docker+ ( -- * @'Proc'@+ Proc(..)+ , Pinged(..)+ , AreProcs+ , SomeProcs(..)+ , nameOf+ , startup+ , toPinged+ , uriOf'+ , runArgs'++ -- * @'ProcHandle'@+ , ProcHandle(..)+ , Proc2Handle+ , HandlesOf+ , startupAll+ , terminateAll+ , withTmpProcs+ , manyNamed+ , handleOf+ , ixReset+ , ixPing+ , ixUriOf+ , HasHandle+ , HasNamedHandle+ , SomeNamedHandles++ -- * @'Connectable'@+ , Connectable(..)+ , Connectables+ , withTmpConn+ , withConnOf+ , openAll+ , closeAll+ , withConns+ , withKnownConns+ , withNamedConns++ -- * Docker status+ , hasDocker++ -- * Aliases+ , HostIpAddress+ , SvcURI++ -- * Re-exports+ , module System.TmpProc.TypeLevel+ )+where++import Control.Concurrent (threadDelay)+import Control.Exception (SomeException, bracket, catch,+ onException, Exception)+import Control.Monad (void, when)+import qualified Data.ByteString.Char8 as C8+import Data.Kind (Type)+import Data.List (dropWhileEnd)+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import GHC.TypeLits (CmpSymbol, KnownSymbol, Nat, Symbol,+ symbolVal)+import Numeric.Natural (Natural)+import System.Exit (ExitCode (..))+import System.Environment (lookupEnv)+import System.IO (stderr, Handle, openBinaryFile, IOMode(..))+import System.Process (StdStream (..), proc, readProcess,+ std_err, std_out, waitForProcess,+ withCreateProcess, readCreateProcess, CreateProcess)++import System.TmpProc.TypeLevel (Drop, HList (..), HalfOf, IsAbsent,+ IsInProof, KV (..), LengthOf,+ ManyMemberKV, MemberKV,+ ReorderH (..), SortSymbols, Take,+ hOf, select, selectMany, (&:))+++{-| Determines if the docker daemon is accessible. -}+hasDocker :: IO Bool+hasDocker = 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
+ src/System/TmpProc/TypeLevel.hs view
@@ -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 <adetokunbo@users.noreply.github.com>++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
+ src/System/TmpProc/TypeLevel/Sort.hs view
@@ -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 <adetokunbo@users.noreply.github.com>++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)
+ src/System/TmpProc/Warp.hs view
@@ -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 <adetokunbo@users.noreply.github.com>++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 ()
+ test/Spec.hs view
@@ -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
+ test/Test/Hspec/TmpProc.hs view
@@ -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"
+ test/Test/HttpBin.hs view
@@ -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
+ test/Test/SimpleServer.hs view
@@ -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
+ test/Test/System/TmpProc/Hspec.hs view
@@ -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
+ test/Test/System/TmpProc/HttpBinSpec.hs view
@@ -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`()
+ test/Test/System/TmpProc/WarpSpec.hs view
@@ -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"
+ test_certs/certificate.csr view
@@ -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-----
+ test_certs/certificate.pem view
@@ -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-----
+ test_certs/key.pem view
@@ -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-----
+ tmp-proc.cabal view
@@ -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