hedgehog-extras (empty) → 0.3.0.1

raw patch · 28 files changed

+2166/−0 lines, 28 filesdep +Win32dep +aesondep +aeson-pretty

Dependencies added: Win32, aeson, aeson-pretty, async, base, bytestring, deepseq, directory, exceptions, filepath, hedgehog, hw-aeson, mmorph, mtl, network, process, resourcet, stm, temporary, text, time, transformers, unliftio, unordered-containers, yaml

Files

• LICENSE +202/−0
• NOTICE +14/−0
• hedgehog-extras.cabal +113/−0
• src/Hedgehog/Extras.hs +5/−0
• src/Hedgehog/Extras/Aeson.hs +87/−0
• src/Hedgehog/Extras/Internal/Cli.hs +28/−0
• src/Hedgehog/Extras/Internal/Plan.hs +36/−0
• src/Hedgehog/Extras/Internal/Test/Integration.hs +33/−0
• src/Hedgehog/Extras/Internal/Win32/NamedPipes.hsc +71/−0
• src/Hedgehog/Extras/Stock.hs +15/−0
• src/Hedgehog/Extras/Stock/Aeson.hs +26/−0
• src/Hedgehog/Extras/Stock/CallStack.hs +13/−0
• src/Hedgehog/Extras/Stock/IO/File.hs +15/−0
• src/Hedgehog/Extras/Stock/IO/Network/NamedPipe.hs +24/−0
• src/Hedgehog/Extras/Stock/IO/Network/Socket.hs +72/−0
• src/Hedgehog/Extras/Stock/IO/Network/Sprocket.hs +60/−0
• src/Hedgehog/Extras/Stock/IO/Process.hs +41/−0
• src/Hedgehog/Extras/Stock/Monad.hs +10/−0
• src/Hedgehog/Extras/Stock/OS.hs +12/−0
• src/Hedgehog/Extras/Stock/String.hs +23/−0
• src/Hedgehog/Extras/Stock/Time.hs +24/−0
• src/Hedgehog/Extras/Test.hs +10/−0
• src/Hedgehog/Extras/Test/Base.hs +492/−0
• src/Hedgehog/Extras/Test/Concurrent.hs +16/−0
• src/Hedgehog/Extras/Test/File.hs +274/−0
• src/Hedgehog/Extras/Test/MonadAssertion.hs +32/−0
• src/Hedgehog/Extras/Test/Network.hs +71/−0
• src/Hedgehog/Extras/Test/Process.hs +347/−0

@@ -0,0 +1,202 @@++                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "[]"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright 2021 Input Output (Hong Kong) Ltd.++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.

@@ -0,0 +1,14 @@+Copyright 2021-2023 Input Output (Hong Kong) Ltd.++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.+

@@ -0,0 +1,113 @@+cabal-version: 2.4++name:                   hedgehog-extras+version:                0.3.0.1+synopsis:               Supplemental library for hedgehog+description:            Supplemental library for hedgehog.+category:               Test+author:                 IOHK+maintainer:             operations@iohk.io+license:                Apache-2.0+license-files:          LICENSE+                        NOTICE+build-type:             Simple++source-repository head+  type:                 git+  location:             https://github.com/input-output-hk/hedgehog-extras++common base                         { build-depends: base                             >= 4.12       && < 4.17     }+common aeson                        { build-depends: aeson                            >= 1.5.6.0                  }+common aeson-pretty                 { build-depends: aeson-pretty                     >= 0.8.5                    }+common async                        { build-depends: async                                                        }+common bytestring                   { build-depends: bytestring                                                   }+common deepseq                      { build-depends: deepseq                                                      }+common directory                    { build-depends: directory                                                    }+common exceptions                   { build-depends: exceptions                                                   }+common filepath                     { build-depends: filepath                                                     }+common hedgehog                     { build-depends: hedgehog                                                     }+common hw-aeson                     { build-depends: hw-aeson                         >= 0.1.8.0                  }+common mmorph                       { build-depends: mmorph                                                       }+common mtl                          { build-depends: mtl                                                          }+common network                      { build-depends: network                                                      }+common process                      { build-depends: process                                                      }+common resourcet                    { build-depends: resourcet                                                    }+common stm                          { build-depends: stm                                                          }+common temporary                    { build-depends: temporary                                                    }+common text                         { build-depends: text                                                         }+common time                         { build-depends: time                             >= 1.9.1                    }+common transformers                 { build-depends: transformers                                                 }+common unliftio                     { build-depends: unliftio                                                     }+common unordered-containers         { build-depends: unordered-containers                                         }+common yaml                         { build-depends: yaml                                                         }++common Win32+  if os(windows)+    build-depends:      Win32   >= 2.5.4.1++common project-config+  default-language:     Haskell2010+  default-extensions:   NoImplicitPrelude+  ghc-options:          -Wall+                        -Wcompat+                        -Wincomplete-record-updates+                        -Wincomplete-uni-patterns+                        -Wpartial-fields+                        -Wredundant-constraints+                        -Wunused-packages++library+  import:               base, project-config,+                        aeson-pretty,+                        aeson,+                        async,+                        bytestring,+                        deepseq,+                        directory,+                        exceptions,+                        filepath,+                        hedgehog,+                        hw-aeson,+                        mmorph,+                        mtl,+                        network,+                        process,+                        resourcet,+                        stm,+                        temporary,+                        text,+                        time,+                        transformers,+                        unliftio,+                        unordered-containers,+                        Win32,+                        yaml,+  hs-source-dirs:       src+++  if os(windows)+    exposed-modules:    Hedgehog.Extras.Internal.Win32.NamedPipes+  exposed-modules:      Hedgehog.Extras+                        Hedgehog.Extras.Aeson+                        Hedgehog.Extras.Internal.Cli+                        Hedgehog.Extras.Internal.Plan+                        Hedgehog.Extras.Internal.Test.Integration+                        Hedgehog.Extras.Stock+                        Hedgehog.Extras.Stock.Aeson+                        Hedgehog.Extras.Stock.CallStack+                        Hedgehog.Extras.Stock.IO.File+                        Hedgehog.Extras.Stock.IO.Network.NamedPipe+                        Hedgehog.Extras.Stock.IO.Network.Socket+                        Hedgehog.Extras.Stock.IO.Network.Sprocket+                        Hedgehog.Extras.Stock.IO.Process+                        Hedgehog.Extras.Stock.Monad+                        Hedgehog.Extras.Stock.OS+                        Hedgehog.Extras.Stock.String+                        Hedgehog.Extras.Stock.Time+                        Hedgehog.Extras.Test+                        Hedgehog.Extras.Test.Base+                        Hedgehog.Extras.Test.Concurrent+                        Hedgehog.Extras.Test.File+                        Hedgehog.Extras.Test.MonadAssertion+                        Hedgehog.Extras.Test.Network+                        Hedgehog.Extras.Test.Process

@@ -0,0 +1,5 @@+module Hedgehog.Extras+  ( module X+  ) where++import Hedgehog.Extras.Test as X

@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# OPTIONS_GHC -Wno-unused-local-binds #-}++module Hedgehog.Extras.Aeson+  ( goldenTestJsonValue+  , goldenTestJsonValuePretty+  ) where++import           Control.Monad+import           Control.Monad.IO.Class+import           Data.Aeson+import           Data.Aeson.Encode.Pretty+import           Data.Bool+import           Data.Either+import           Data.Eq+import           Data.Function+import           Data.Functor+import           Data.Maybe+import           Data.Semigroup+import           GHC.Stack+import           Hedgehog+import           System.IO+import           Text.Show++import qualified Data.ByteString.Lazy as LBS+import qualified Hedgehog.Internal.Property as H++writeNewGoldFiles :: Bool+writeNewGoldFiles = False++strictComparison :: Bool+strictComparison = False++goldenTestJsonValue :: forall a. ()+  => Eq a+  => FromJSON a+  => Show a+  => ToJSON a+  => HasCallStack+  => a+  -> FilePath+  -> Property+goldenTestJsonValue x path = withFrozenCallStack $ withTests 1 . property $ do+  bs <- liftIO (LBS.readFile path)+  when writeNewGoldFiles $ liftIO . LBS.writeFile (path <> ".gold") $ encode x+  when strictComparison $ fmap encode (eitherDecode @a bs) === Right bs+  case eitherDecode bs of+    Left  err -> H.failWith Nothing $ "could not decode: " <> show err+    Right x'  -> x === x'++goldenTestJsonValuePretty+  :: forall a. ()+  => Eq a+  => FromJSON a+  => HasCallStack+  => Show a+  => ToJSON a+  => a+  -> FilePath+  -> Property+goldenTestJsonValuePretty x path =+  withFrozenCallStack+    $ withTests 1+    . property+    $ do+        bs <- liftIO (LBS.readFile path)+        -- Sort keys by their order of appearance in the argument list+        -- of `keyOrder`. Keys not in the argument list are moved to the+        -- end, while their order is preserved.+        let+          defConfig' = Config+            { confIndent          = Spaces 4+            , confCompare         = keyOrder ["file", "hash"]+            , confNumFormat       = Generic+            , confTrailingNewline = False+            }+        when writeNewGoldFiles $ liftIO . LBS.writeFile (path <> ".gold") $ encodePretty' defConfig' x+        when strictComparison $ fmap (encodePretty' defConfig') (eitherDecode @a bs) === Right bs+        case eitherDecode bs of+          Left  err -> H.failWith Nothing $ "could not decode: " <> show err+          Right x'  -> x === x'

@@ -0,0 +1,28 @@+module Hedgehog.Extras.Internal.Cli+  ( argQuote+  ) where++import           Data.Bool+import           Data.Semigroup+import           Data.String++import qualified Data.List as L++-- | Format argument for a shell CLI command.+--+-- This includes automatically embedding string in double quotes if necessary, including any necessary escaping.+--+-- Note, this function does not cover all the edge cases for shell processing, so avoid use in production code.+argQuote :: String -> String+argQuote arg = if ' ' `L.elem` arg || '"' `L.elem` arg || '$' `L.elem` arg+  then "\"" <> escape arg <> "\""+  else arg+  where escape :: String -> String+        escape ('"':xs) = '\\':'"':escape xs+        escape ('\\':xs) = '\\':'\\':escape xs+        escape ('\n':xs) = '\\':'n':escape xs+        escape ('\r':xs) = '\\':'r':escape xs+        escape ('\t':xs) = '\\':'t':escape xs+        escape ('$':xs) = '\\':'$':escape xs+        escape (x:xs) = x:escape xs+        escape "" = ""

@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Hedgehog.Extras.Internal.Plan+  ( Plan(..)+  , Component(..)+  ) where++import           Control.Applicative+import           Data.Aeson+import           Data.Eq+import           Data.Function+import           Data.Maybe+import           Data.Text (Text)+import           GHC.Generics+import           Text.Show++data Component = Component+  { componentName :: Maybe Text+  , binFile :: Maybe Text+  }+  deriving (Generic, Eq, Show)++newtype Plan = Plan+  { installPlan :: [Component]+  }+  deriving (Generic, Eq, Show)++instance FromJSON Plan where+    parseJSON = withObject "Plan" $ \v -> Plan+        <$> v .: "install-plan"++instance FromJSON Component where+    parseJSON = withObject "Plan" $ \v -> Component+        <$> v .:? "component-name"+        <*> v .:? "bin-file"

@@ -0,0 +1,33 @@++module Hedgehog.Extras.Internal.Test.Integration+  ( Integration+  , IntegrationState(..)+  , newIntegrationStateIO+  , newIntegrationStateM+  , runIntegrationReaderT+  ) where++import           Control.Monad.Reader+import           Control.Monad.Trans.Resource (ResourceT)+import           Data.Functor+import           System.IO (IO)++import qualified Control.Concurrent.STM as STM+import qualified Hedgehog as H++newtype IntegrationState = IntegrationState+  { integrationStateFinals :: STM.TVar [Integration ()]+  }++type Integration a = H.PropertyT (ReaderT IntegrationState (ResourceT IO)) a++newIntegrationStateIO :: IO IntegrationState+newIntegrationStateIO = IntegrationState <$> STM.newTVarIO []++newIntegrationStateM :: MonadIO m => m IntegrationState+newIntegrationStateM = liftIO newIntegrationStateIO++runIntegrationReaderT :: MonadIO m => ReaderT IntegrationState m a -> m a+runIntegrationReaderT f = do+  s <- newIntegrationStateM+  runReaderT f s

@@ -0,0 +1,71 @@+#include <fcntl.h>+#include <windows.h>++{-# LANGUAGE CPP                #-}+{-# LANGUAGE MultiWayIf         #-}++-- | For full details on the Windows named pipes API see+-- <https://docs.microsoft.com/en-us/windows/desktop/ipc/named-pipes>+--+module Hedgehog.Extras.Internal.Win32.NamedPipes+  ( -- ** waiting for named pipe instances+    waitNamedPipe,++    TimeOut,+    nMPWAIT_USE_DEFAULT_WAIT,+    nMPWAIT_WAIT_FOREVER,+  ) where++import Control.Applicative (pure)+import Data.Bool (Bool (..), otherwise)+import Data.Eq ((==))+import Data.Function (($))+import Data.String (String)+import Foreign.C.String (withCString)+import System.IO (IO)+import System.Win32.File+import System.Win32.Types hiding (try)++-- | Timeout in milliseconds.+--+-- * 'nMPWAIT_USE_DEFAULT_WAIT' indicates that the timeout value passed to+--   'createNamedPipe' should be used.+-- * 'nMPWAIT_WAIT_FOREVER' - 'waitNamedPipe' will block forever, until a named+--   pipe instance is available.+--+type TimeOut = DWORD+#{enum TimeOut,+ , nMPWAIT_USE_DEFAULT_WAIT = NMPWAIT_USE_DEFAULT_WAIT+ , nMPWAIT_WAIT_FOREVER     = NMPWAIT_WAIT_FOREVER+ }++-- | Wait until a named pipe instance is available.  If there is no instance at+-- hand before the timeout, it will error with 'ERROR_SEM_TIMEOUT', i.e.+-- @invalid argument (The semaphore timeout period has expired)@+--+-- It returns 'True' if there is an available instance, subsequent 'createFile'+-- might still fail, if another thread will take turn and connect before, or if+-- the other end shuts down the name pipe.+--+-- It returns 'False' if timeout fired.+--+waitNamedPipe :: String  -- ^ pipe name+              -> TimeOut -- ^ nTimeOut+              -> IO Bool+waitNamedPipe name timeout =+    withCString name $ \ c_name -> do+      r <- c_WaitNamedPipe c_name timeout+      e <- getLastError+      if | r                      -> pure r+         | e == eRROR_SEM_TIMEOUT -> pure False+         | otherwise              -> failWith "waitNamedPipe" e+++-- 'c_WaitNamedPipe' is a blocking call, hence the _safe_ import.+foreign import ccall safe "windows.h WaitNamedPipeA"+  c_WaitNamedPipe :: LPCSTR -- lpNamedPipeName+                  -> DWORD  -- nTimeOut+                  -> IO BOOL++eRROR_SEM_TIMEOUT :: ErrCode+eRROR_SEM_TIMEOUT = #const ERROR_SEM_TIMEOUT

@@ -0,0 +1,15 @@+module Hedgehog.Extras.Stock+  ( module X+  ) where++import Hedgehog.Extras.Stock.Aeson as X+import Hedgehog.Extras.Stock.CallStack as X+import Hedgehog.Extras.Stock.IO.File as X+import Hedgehog.Extras.Stock.IO.Network.NamedPipe as X+import Hedgehog.Extras.Stock.IO.Network.Socket as X+import Hedgehog.Extras.Stock.IO.Network.Sprocket as X+import Hedgehog.Extras.Stock.IO.Process as X+import Hedgehog.Extras.Stock.Monad as X+import Hedgehog.Extras.Stock.OS as X+import Hedgehog.Extras.Stock.String as X+import Hedgehog.Extras.Stock.Time as X

@@ -0,0 +1,26 @@+module Hedgehog.Extras.Stock.Aeson+  ( rewriteObject+  , rewriteArrayElements+  ) where++import           Data.Aeson+import           Data.Functor+import           Data.HashMap.Lazy+import           Data.Text+import           Prelude ((.), ($))++import qualified HaskellWorks.Data.Aeson.Compat.Map as KM++-- | Rewrite a JSON object to another JSON object using the function 'f'.+--+-- All other JSON values are preserved.+rewriteObject :: (HashMap Text Value -> HashMap Text Value) -> Value -> Value+rewriteObject f (Object hm) = Object (KM.fromHashMapText . f . KM.toHashMapText $ hm)+rewriteObject _ v = v++-- | Rewrite each element of a JSON array using the function 'f'.+--+-- All other JSON values are preserved.+rewriteArrayElements :: (Value -> Value) -> Value -> Value+rewriteArrayElements f (Array hm) = Array (fmap f hm)+rewriteArrayElements _ v = v

@@ -0,0 +1,13 @@+module Hedgehog.Extras.Stock.CallStack+  ( callerModuleName+  ) where++import           Data.Function+import           Data.Maybe+import           Data.String+import           Data.Tuple+import           GHC.Stack (HasCallStack, callStack, getCallStack, srcLocModule)++-- | Get the module name of the caller.+callerModuleName :: HasCallStack => String+callerModuleName = maybe "<no-module>" (srcLocModule . snd) (listToMaybe (getCallStack callStack))

@@ -0,0 +1,15 @@+module Hedgehog.Extras.Stock.IO.File+  ( fileContains+  ) where++import           Data.Bool+import           Data.Functor+import           Data.String (String)+import           System.IO (FilePath, IO)++import qualified Data.List as L+import qualified System.IO as IO++-- | Determine if the given string is found in the given file.+fileContains :: String -> FilePath -> IO Bool+fileContains text path = (text `L.isInfixOf`) <$> IO.readFile path

@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}++module Hedgehog.Extras.Stock.IO.Network.NamedPipe+  ( doesNamedPipeExist+  ) where++import           Data.Bool+import           Prelude (error)+import           System.IO (FilePath, IO)++#ifdef mingw32_HOST_OS+import qualified Hedgehog.Extras.Internal.Win32.NamedPipes as W32+#endif++doesNamedPipeExist :: FilePath -> IO Bool+doesNamedPipeExist path =+#ifdef mingw32_HOST_OS+  W32.waitNamedPipe path 1+#else+  error "doesNamedPipeExist may only be called on Windows"+#endif

@@ -0,0 +1,72 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Hedgehog.Extras.Stock.IO.Network.Socket+  ( doesSocketExist+  , isPortOpen+  , canConnect+  , listenOn+  , allocateRandomPorts+  ) where++import           Control.Exception (IOException, handle)+import           Control.Monad+import           Data.Bool+import           Data.Function+import           Data.Functor+import           Data.Int+import           Data.Maybe+import           Network.Socket (Family (AF_INET), SockAddr (..), Socket, SocketType (Stream))+import           Prelude (fromIntegral)+import           System.IO (FilePath, IO)+import           Text.Show (show)++import qualified Network.Socket as IO+import qualified System.Directory as IO+import qualified UnliftIO.Exception as IO++-- | Check if a TCP port is open+isPortOpen :: Int -> IO Bool+isPortOpen port = do+  socketAddressInfos <- IO.getAddrInfo Nothing (Just "127.0.0.1") (Just (show port))+  case socketAddressInfos of+    socketAddressInfo:_ ->+      handle (return . const @Bool @IOException False) $+        canConnect (IO.addrAddress socketAddressInfo) $> True+    [] -> return False++-- | Check if it is possible to connect to a socket address+canConnect :: SockAddr -> IO ()+canConnect sockAddr = IO.bracket (IO.socket AF_INET Stream 6) IO.close' $ \sock -> do+  IO.connect sock sockAddr++-- | Open a socket at the specified port for listening+listenOn :: Int -> IO Socket+listenOn n = do+  sock <- IO.socket AF_INET Stream 0+  sockAddrInfo:_ <- IO.getAddrInfo Nothing (Just "127.0.0.1") (Just (show n))+  IO.setSocketOption sock IO.ReuseAddr 1+  IO.bind sock (IO.addrAddress sockAddrInfo)+  IO.listen sock 2+  return sock++doesSocketExist :: FilePath -> IO Bool+doesSocketExist = IO.doesFileExist+{-# INLINE doesSocketExist #-}++-- | Allocate the specified number of random ports+allocateRandomPorts :: Int -> IO [Int]+allocateRandomPorts n = do+  let hints = IO.defaultHints+        { IO.addrFlags = [IO.AI_PASSIVE]+        , IO.addrSocketType = IO.Stream+        }++  -- Create n sockets with randomly bound ports, grab the port numbers and close those ports+  addr:_ <- IO.getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0")+  socks <- forM [1..n] $ \_ -> IO.socket (IO.addrFamily addr) (IO.addrSocketType addr) (IO.addrProtocol addr)+  forM_ socks $ \sock -> IO.bind sock (IO.addrAddress addr)+  ports <- forM socks IO.socketPort+  forM_ socks IO.close++  return $ fmap fromIntegral ports

@@ -0,0 +1,60 @@+module Hedgehog.Extras.Stock.IO.Network.Sprocket+  ( Sprocket(..)+  , doesSprocketExist+  , sprocketArgumentName+  , sprocketSystemName+  , maxSprocketArgumentNameLength+  ) where++import           Data.Bool+import           Data.Char+import           Data.Eq+import           Data.Functor+import           Data.Int+import           Data.Semigroup+import           Data.String (String)+import           Hedgehog.Extras.Stock.OS+import           System.IO (FilePath, IO)+import           Text.Show++import qualified Hedgehog.Extras.Stock.IO.Network.NamedPipe as IO+import qualified Hedgehog.Extras.Stock.IO.Network.Socket as IO++-- | Socket emulation.  On Posix it represents a socket.  On Windows it represents a named pipe.+data Sprocket = Sprocket+  { sprocketBase :: String+  , sprocketName :: String+  } deriving (Eq, Show)++-- | Test if the sprocket exists+doesSprocketExist :: Sprocket -> IO Bool+doesSprocketExist socket = if isWin32+  then IO.doesNamedPipeExist (sprocketSystemName socket)+  else IO.doesSocketExist (sprocketSystemName socket)++-- | Use this to query the OS about the sprocket+sprocketSystemName :: Sprocket -> FilePath+sprocketSystemName sprocket@(Sprocket base name) = if isWin32+  then sprocketNamedPipeName sprocket+  else base <> "/" <> name++-- | Use this when needing to pass a sprocket into a command line argument.+sprocketArgumentName :: Sprocket -> FilePath+sprocketArgumentName sprocket@(Sprocket _ name) = if isWin32+  then sprocketNamedPipeName sprocket+  else name++maxSprocketArgumentNameLength :: Int+maxSprocketArgumentNameLength = if isWin32+  then 256+  else 104++-- | The named pipe name of the sprocket on Win32 systems+sprocketNamedPipeName :: Sprocket -> FilePath+sprocketNamedPipeName (Sprocket _ name) = "\\\\.\\pipe" <> dedupBackslash ("\\" <> fmap slackToBack name)+  where slackToBack :: Char -> Char+        slackToBack c = if c == '/' then '\\' else c+        dedupBackslash :: String -> String+        dedupBackslash ('\\':'\\':xs) = dedupBackslash ('\\':xs)+        dedupBackslash (x:xs) = x:dedupBackslash xs+        dedupBackslash [] = []

@@ -0,0 +1,41 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Hedgehog.Extras.Stock.IO.Process+  ( maybeWaitForProcess+  , waitSecondsForProcess+  , TimedOut(..)+  ) where++import           Control.Concurrent.Async+import           Control.Exception+import           Control.Monad+import           Data.Either+import           Data.Eq+import           Data.Function+import           Data.Int+import           Data.Maybe+import           GHC.Num+import           System.Exit+import           System.IO+import           System.Process+import           Text.Show++import qualified Control.Concurrent as IO+import qualified Control.Concurrent.Async as IO+import qualified System.Process as IO++data TimedOut = TimedOut deriving (Eq, Show)++maybeWaitForProcess+  :: ProcessHandle+  -> IO (Maybe ExitCode)+maybeWaitForProcess hProcess =+  catch (fmap Just (IO.waitForProcess hProcess)) $ \(_ :: AsyncCancelled) -> return Nothing++waitSecondsForProcess+  :: Int+  -> ProcessHandle+  -> IO (Either TimedOut (Maybe ExitCode))+waitSecondsForProcess seconds hProcess = IO.race+  (IO.threadDelay (seconds * 1000000) >> return TimedOut)+  (maybeWaitForProcess hProcess)

@@ -0,0 +1,10 @@+module Hedgehog.Extras.Stock.Monad+  ( forceM+  ) where++import           Control.DeepSeq (NFData, force)+import           Control.Monad++-- | Force the evaluation of the return value in a monadic computation.+forceM :: (Monad m, NFData a) => m a -> m a+forceM = (force <$!>)

@@ -0,0 +1,12 @@+module Hedgehog.Extras.Stock.OS+  ( isWin32+  ) where++import           Data.Bool+import           Data.Eq+import           System.Info++-- | Determine if the operating system is Windows.+isWin32 :: Bool+isWin32 = os == "mingw32"+{-# INLINE isWin32 #-}

@@ -0,0 +1,23 @@+module Hedgehog.Extras.Stock.String+  ( strip+  , lastLine+  , firstLine+  ) where++import           Data.Function+import           Data.String++import qualified Data.List as L+import qualified Data.Text as T++-- | Strip whitepsace from the beginning and end of the string.+strip :: String -> String+strip = T.unpack . T.strip . T.pack++-- | Get the last line in the string+lastLine :: String -> String+lastLine = strip . L.unlines . L.reverse . L.take 1 . L.reverse . L.lines++-- | Get the first line in the string+firstLine :: String -> String+firstLine = strip . L.unlines . L.take 1 . L.lines

@@ -0,0 +1,24 @@+{-# LANGUAGE TypeApplications #-}++module Hedgehog.Extras.Stock.Time+  ( showUTCTimeSeconds+  , formatIso8601+  ) where++import           Data.Int+import           Data.Maybe+import           Data.String+import           Data.Time.Clock (UTCTime)+import           Prelude (floor)+import           Text.Show++import qualified Data.Time.Clock.POSIX as DTC+import qualified Data.Time.Format as DT++-- | Show 'UTCTime' in seconds since epoch+showUTCTimeSeconds :: UTCTime -> String+showUTCTimeSeconds time = show @Int64 (floor (DTC.utcTimeToPOSIXSeconds time))++-- | Format the given time as an ISO 8601 date-time string+formatIso8601 :: UTCTime -> String+formatIso8601 = DT.formatTime DT.defaultTimeLocale (DT.iso8601DateFormat (Just "%H:%M:%SZ"))

@@ -0,0 +1,10 @@+module Hedgehog.Extras.Test+  ( module X+  ) where++import Hedgehog.Extras.Test.Base as X+import Hedgehog.Extras.Test.Concurrent as X+import Hedgehog.Extras.Test.File as X+import Hedgehog.Extras.Test.MonadAssertion as X+import Hedgehog.Extras.Test.Network as X+import Hedgehog.Extras.Test.Process as X

@@ -0,0 +1,492 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hedgehog.Extras.Test.Base+  ( propertyOnce++  , workspace+  , moduleWorkspace++  , note+  , note_+  , noteM+  , noteM_+  , noteIO+  , noteIO_++  , noteShow+  , noteShow_+  , noteShowM+  , noteShowM_+  , noteShowIO+  , noteShowIO_++  , noteEach+  , noteEach_+  , noteEachM+  , noteEachM_+  , noteEachIO+  , noteEachIO_++  , noteTempFile++  , headM+  , fromJustM++  , nothingFail+  , nothingFailM+  , leftFail+  , leftFailM+  , jsonErrorFail+  , jsonErrorFailM++  , failWithCustom+  , failMessage++  , assertByDeadlineM+  , assertByDeadlineIO+  , assertByDeadlineMFinally+  , assertByDeadlineIOFinally+  , assertM+  , assertIO++  , byDeadlineM+  , byDeadlineIO+  , byDurationM+  , byDurationIO++  , onFailure++  , Integration+  , release++  , runFinallies++  , retry+  ) where++import           Control.Monad+import           Control.Monad.Catch (MonadCatch)+import           Control.Monad.Morph (hoist)+import           Control.Monad.Reader+import           Control.Monad.Trans.Resource (ReleaseKey, runResourceT)+import           Data.Aeson (Result (..))+import           Data.Bool+import           Data.Either (Either (..))+import           Data.Eq+import           Data.Foldable+import           Data.Function (($), (.))+import           Data.Functor+import           Data.Int+import           Data.Maybe (Maybe (..), listToMaybe, maybe)+import           Data.Monoid (Monoid (..))+import           Data.Ord+import           Data.Semigroup (Semigroup (..))+import           Data.String (String)+import           Data.Time.Clock (NominalDiffTime, UTCTime)+import           Data.Traversable+import           Data.Tuple+import           GHC.Num+import           GHC.Stack (CallStack, HasCallStack)+import           Hedgehog (MonadTest)+import           Hedgehog.Extras.Internal.Test.Integration+import           Hedgehog.Extras.Stock.CallStack+import           Hedgehog.Extras.Stock.Monad+import           Hedgehog.Extras.Test.MonadAssertion (MonadAssertion)+import           Hedgehog.Internal.Property (Diff, liftTest, mkTest)+import           Hedgehog.Internal.Source (getCaller)+import           Prelude (floor)+import           System.IO (FilePath, IO)+import           Text.Show++import qualified Control.Concurrent as IO+import qualified Control.Concurrent.STM as STM+import qualified Control.Monad.Trans.Resource as IO+import qualified Data.Time.Clock as DTC+import qualified GHC.Stack as GHC+import qualified Hedgehog as H+import qualified Hedgehog.Extras.Test.MonadAssertion as H+import qualified Hedgehog.Internal.Property as H+import qualified System.Directory as IO+import qualified System.Environment as IO+import qualified System.Info as IO+import qualified System.IO as IO+import qualified System.IO.Temp as IO++{- HLINT ignore "Reduce duplication" -}++-- | Run a property with only one test.  This is intended for allowing hedgehog+-- to run unit tests.+propertyOnce :: HasCallStack => Integration () -> H.Property+propertyOnce = H.withTests 1 . H.property . hoist runResourceT . hoist runIntegrationReaderT++-- | Takes a 'CallStack' so the error can be rendered at the appropriate call site.+failWithCustom :: MonadTest m => CallStack -> Maybe Diff -> String -> m a+failWithCustom cs mdiff msg = liftTest $ mkTest (Left $ H.Failure (getCaller cs) msg mdiff, mempty)++-- | Takes a 'CallStack' so the error can be rendered at the appropriate call site.+failMessage :: MonadTest m => CallStack -> String -> m a+failMessage cs = failWithCustom cs Nothing++-- | Create a workspace directory which will exist for at least the duration of+-- the supplied block.+--+-- The directory will have the supplied prefix but contain a generated random+-- suffix to prevent interference between tests+--+-- The directory will be deleted if the block succeeds, but left behind if+-- the block fails.+workspace :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> (FilePath -> m ()) -> m ()+workspace prefixPath f = GHC.withFrozenCallStack $ do+  systemTemp <- H.evalIO IO.getCanonicalTemporaryDirectory+  maybeKeepWorkspace <- H.evalIO $ IO.lookupEnv "KEEP_WORKSPACE"+  ws <- H.evalIO $ IO.createTempDirectory systemTemp $ prefixPath <> "-test"+  H.annotate $ "Workspace: " <> ws+  liftIO $ IO.writeFile (ws <> "/module") callerModuleName+  f ws+  when (IO.os /= "mingw32" && maybeKeepWorkspace /= Just "1") $ do+    H.evalIO $ IO.removeDirectoryRecursive ws++-- | Create a workspace directory which will exist for at least the duration of+-- the supplied block.+--+-- The directory will have the prefix as "$prefixPath/$moduleName" but contain a generated random+-- suffix to prevent interference between tests+--+-- The directory will be deleted if the block succeeds, but left behind if+-- the block fails.+moduleWorkspace :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> (FilePath -> m ()) -> m ()+moduleWorkspace prefixPath f = GHC.withFrozenCallStack $ do+  let srcModule = maybe "UnknownModule" (GHC.srcLocModule . snd) (listToMaybe (GHC.getCallStack GHC.callStack))+  workspace (prefixPath <> "/" <> srcModule) f++-- | Annotate the given string at the context supplied by the callstack.+noteWithCallstack :: MonadTest m => CallStack -> String -> m ()+noteWithCallstack cs a = H.writeLog $ H.Annotation (getCaller cs) a++-- | Annotate with the given string.+note :: (MonadTest m, HasCallStack) => String -> m String+note a = GHC.withFrozenCallStack $ do+  !b <- H.eval a+  noteWithCallstack GHC.callStack b+  return b++-- | Annotate the given string returning unit.+note_ :: (MonadTest m, HasCallStack) => String -> m ()+note_ a = GHC.withFrozenCallStack $ noteWithCallstack GHC.callStack a++-- | Annotate the given string in a monadic context.+noteM :: (MonadTest m, MonadCatch m, HasCallStack) => m String -> m String+noteM a = GHC.withFrozenCallStack $ do+  !b <- H.evalM a+  noteWithCallstack GHC.callStack b+  return b++-- | Annotate the given string in a monadic context returning unit.+noteM_ :: (MonadTest m, MonadCatch m, HasCallStack) => m String -> m ()+noteM_ a = GHC.withFrozenCallStack $ do+  !b <- H.evalM a+  noteWithCallstack GHC.callStack b+  return ()++-- | Annotate the given string in IO.+noteIO :: (MonadTest m, MonadIO m, HasCallStack) => IO String -> m String+noteIO f = GHC.withFrozenCallStack $ do+  !a <- H.evalIO f+  noteWithCallstack GHC.callStack a+  return a++-- | Annotate the given string in IO returning unit.+noteIO_ :: (MonadTest m, MonadIO m, HasCallStack) => IO String -> m ()+noteIO_ f = GHC.withFrozenCallStack $ do+  !a <- H.evalIO f+  noteWithCallstack GHC.callStack a+  return ()++-- | Annotate the given value.+noteShow :: (MonadTest m, HasCallStack, Show a) => a -> m a+noteShow a = GHC.withFrozenCallStack $ do+  !b <- H.eval a+  noteWithCallstack GHC.callStack (show b)+  return b++-- | Annotate the given value returning unit.+noteShow_ :: (MonadTest m, HasCallStack, Show a) => a -> m ()+noteShow_ a = GHC.withFrozenCallStack $ noteWithCallstack GHC.callStack (show a)++-- | Annotate the given value in a monadic context.+noteShowM :: (MonadTest m, MonadCatch m, HasCallStack, Show a) => m a -> m a+noteShowM a = GHC.withFrozenCallStack $ do+  !b <- H.evalM a+  noteWithCallstack GHC.callStack (show b)+  return b++-- | Annotate the given value in a monadic context returning unit.+noteShowM_ :: (MonadTest m, MonadCatch m, HasCallStack, Show a) => m a -> m ()+noteShowM_ a = GHC.withFrozenCallStack $ do+  !b <- H.evalM a+  noteWithCallstack GHC.callStack (show b)+  return ()++-- | Annotate the given value in IO.+noteShowIO :: (MonadTest m, MonadIO m, HasCallStack, Show a) => IO a -> m a+noteShowIO f = GHC.withFrozenCallStack $ do+  !a <- H.evalIO f+  noteWithCallstack GHC.callStack (show a)+  return a++-- | Annotate the given value in IO returning unit.+noteShowIO_ :: (MonadTest m, MonadIO m, HasCallStack, Show a) => IO a -> m ()+noteShowIO_ f = GHC.withFrozenCallStack $ do+  !a <- H.evalIO f+  noteWithCallstack GHC.callStack (show a)+  return ()++-- | Annotate the each value in the given traversable.+noteEach :: (MonadTest m, HasCallStack, Show a, Traversable f) => f a -> m (f a)+noteEach as = GHC.withFrozenCallStack $ do+  for_ as $ noteWithCallstack GHC.callStack . show+  return as++-- | Annotate the each value in the given traversable returning unit.+noteEach_ :: (MonadTest m, HasCallStack, Show a, Traversable f) => f a -> m ()+noteEach_ as = GHC.withFrozenCallStack $ for_ as $ noteWithCallstack GHC.callStack . show++-- | Annotate the each value in the given traversable in a monadic context.+noteEachM :: (MonadTest m, HasCallStack, Show a, Traversable f) => m (f a) -> m (f a)+noteEachM f = GHC.withFrozenCallStack $ do+  !as <- f+  for_ as $ noteWithCallstack GHC.callStack . show+  return as++-- | Annotate the each value in the given traversable in a monadic context returning unit.+noteEachM_ :: (MonadTest m, HasCallStack, Show a, Traversable f) => m (f a) -> m ()+noteEachM_ f = GHC.withFrozenCallStack $ do+  !as <- f+  for_ as $ noteWithCallstack GHC.callStack . show++-- | Annotate the each value in the given traversable in IO.+noteEachIO :: (MonadTest m, MonadIO m, HasCallStack, Show a, Traversable f) => IO (f a) -> m (f a)+noteEachIO f = GHC.withFrozenCallStack $ do+  !as <- H.evalIO f+  for_ as $ noteWithCallstack GHC.callStack . show+  return as++-- | Annotate the each value in the given traversable in IO returning unit.+noteEachIO_ :: (MonadTest m, MonadIO m, HasCallStack, Show a, Traversable f) => IO (f a) -> m ()+noteEachIO_ f = GHC.withFrozenCallStack $ do+  !as <- H.evalIO f+  for_ as $ noteWithCallstack GHC.callStack . show++-- | Return the test file path after annotating it relative to the project root directory+noteTempFile :: (MonadTest m, HasCallStack) => FilePath -> FilePath -> m FilePath+noteTempFile tempDir filePath = GHC.withFrozenCallStack $ do+  let relPath = tempDir <> "/" <> filePath+  H.annotate relPath+  return relPath++-- | Fail when the result is Nothing.+nothingFail :: (MonadTest m, HasCallStack) => Maybe a -> m a+nothingFail r = GHC.withFrozenCallStack $ case r of+  Just a -> return a+  Nothing -> failMessage GHC.callStack "Expected Just"++-- | Fail when the computed result is Nothing.+nothingFailM :: (MonadTest m, HasCallStack) => m (Maybe a) -> m a+nothingFailM f = f >>= nothingFail++-- | Fail when the result is Left.+leftFail :: (MonadTest m, Show e, HasCallStack) => Either e a -> m a+leftFail r = GHC.withFrozenCallStack $ case r of+  Right a -> return a+  Left e -> failMessage GHC.callStack ("Expected Right: " <> show e)++-- | Fail when the computed result is Left.+leftFailM :: (MonadTest m, Show e, HasCallStack) => m (Either e a) -> m a+leftFailM f = f >>= leftFail++headM :: (MonadTest m, HasCallStack) => [a] -> m a+headM (a:_) = return a+headM [] = GHC.withFrozenCallStack $ failMessage GHC.callStack "Cannot take head of empty list"++fromJustM :: (MonadTest m, HasCallStack) => Maybe a -> m a+fromJustM (Just a) = return a+fromJustM Nothing = GHC.withFrozenCallStack $ failMessage GHC.callStack "Cannot take head of empty list"++-- | Fail when the result is Error.+jsonErrorFail :: (MonadTest m, HasCallStack) => Result a -> m a+jsonErrorFail r = GHC.withFrozenCallStack $ case r of+  Success a -> return a+  Error msg -> failMessage GHC.callStack ("Expected Right: " <> msg)++-- | Fail when the computed result is Error.+jsonErrorFailM :: (MonadTest m, HasCallStack) => m (Result a) -> m a+jsonErrorFailM f = f >>= jsonErrorFail++-- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.+--+-- Expiration of the deadline results in an assertion failure+byDeadlineIO :: (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> UTCTime -> String -> IO a -> m a+byDeadlineIO period deadline errorMessage f = GHC.withFrozenCallStack $ byDeadlineM period deadline errorMessage $ liftIO f++-- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.+--+-- Expiration of the deadline results in an assertion failure+byDeadlineM :: forall m a. (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> UTCTime -> String -> m a -> m a+byDeadlineM period deadline errorMessage f = GHC.withFrozenCallStack $ do+  start <- liftIO DTC.getCurrentTime+  a <- goM+  end <- liftIO DTC.getCurrentTime+  note_ $ "Operation completed in " <> show (DTC.diffUTCTime end start)+  return a+  where goM :: m a+        goM = H.catchAssertion f $ \e -> do+          currentTime <- liftIO DTC.getCurrentTime+          if currentTime < deadline+            then do+              liftIO $ IO.threadDelay (floor (DTC.nominalDiffTimeToSeconds period * 1000000))+              goM+            else do+              H.annotateShow currentTime+              void $ failMessage GHC.callStack $ "Condition not met by deadline: " <> errorMessage+              H.throwAssertion e++-- | Run the operation 'f' once a second until it returns 'True' or the duration expires.+--+-- Expiration of the duration results in an assertion failure+byDurationIO :: (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> NominalDiffTime -> String -> IO a -> m a+byDurationIO period duration errorMessage f = GHC.withFrozenCallStack $ byDurationM period duration errorMessage $ liftIO f++-- | Run the operation 'f' once a second until it returns 'True' or the duration expires.+--+-- Expiration of the duration results in an assertion failure+byDurationM :: (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> NominalDiffTime -> String -> m a -> m a+byDurationM period duration errorMessage f = GHC.withFrozenCallStack $ do+  deadline <- DTC.addUTCTime duration <$> liftIO DTC.getCurrentTime+  byDeadlineM period deadline errorMessage f++-- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.+--+-- Expiration of the deadline results in an assertion failure+assertByDeadlineIO :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> IO Bool -> m ()+assertByDeadlineIO deadline f = GHC.withFrozenCallStack $ do+  success <- liftIO f+  unless success $ do+    currentTime <- liftIO DTC.getCurrentTime+    if currentTime < deadline+      then do+        liftIO $ IO.threadDelay 1000000+        assertByDeadlineIO deadline f+      else do+        H.annotateShow currentTime+        failMessage GHC.callStack "Condition not met by deadline"++-- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.+--+-- Expiration of the deadline results in an assertion failure+assertByDeadlineM :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> m Bool -> m ()+assertByDeadlineM deadline f = GHC.withFrozenCallStack $ do+  success <- f+  unless success $ do+    currentTime <- liftIO DTC.getCurrentTime+    if currentTime < deadline+      then do+        liftIO $ IO.threadDelay 1000000+        assertByDeadlineM deadline f+      else do+        H.annotateShow currentTime+        failMessage GHC.callStack "Condition not met by deadline"++-- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.+--+-- The action 'g' is run after expiration of the deadline, but before failure allowing for+-- additional annotations to be presented.+--+-- Expiration of the deadline results in an assertion failure+assertByDeadlineIOFinally :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> IO Bool -> m () -> m ()+assertByDeadlineIOFinally deadline f g = GHC.withFrozenCallStack $ do+  success <- liftIO f+  unless success $ do+    currentTime <- liftIO DTC.getCurrentTime+    if currentTime < deadline+      then do+        liftIO $ IO.threadDelay 1000000+        assertByDeadlineIOFinally deadline f g+      else do+        H.annotateShow currentTime+        g+        failMessage GHC.callStack "Condition not met by deadline"++-- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.+--+-- The action 'g' is run after expiration of the deadline, but before failure allowing for+-- additional annotations to be presented.+--+-- Expiration of the deadline results in an assertion failure+assertByDeadlineMFinally :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> m Bool -> m () -> m ()+assertByDeadlineMFinally deadline f g = GHC.withFrozenCallStack $ do+  success <- f+  unless success $ do+    currentTime <- liftIO DTC.getCurrentTime+    if currentTime < deadline+      then do+        liftIO $ IO.threadDelay 1000000+        assertByDeadlineMFinally deadline f g+      else do+        H.annotateShow currentTime+        g+        failMessage GHC.callStack "Condition not met by deadline"++-- | Run the monadic action 'f' and assert the return value is 'True'.+assertM :: (MonadTest m, HasCallStack) => m Bool -> m ()+assertM f = GHC.withFrozenCallStack $ f >>= H.assert++-- | Run the IO action 'f' and assert the return value is 'True'.+assertIO :: (MonadTest m, MonadIO m, HasCallStack) => IO Bool -> m ()+assertIO f = GHC.withFrozenCallStack $ H.evalIO (forceM f) >>= H.assert++-- | Release the given release key.+release :: (MonadTest m, MonadIO m) => ReleaseKey -> m ()+release k = GHC.withFrozenCallStack . H.evalIO $ IO.release k++onFailure :: Integration () -> Integration ()+onFailure f = do+  s <- ask+  liftIO . STM.atomically $ STM.modifyTVar (integrationStateFinals s) (f:)++reportFinally :: Integration () -> Integration ()+reportFinally f = do+  result <- H.catchAssertion (fmap Right f) (return . Left)++  case result of+    Right () -> return ()+    Left a -> note_ $ "Unable to run finally: " <> show a++runFinallies :: Integration a -> Integration a+runFinallies f = do+  result <- H.catchAssertion (fmap Right f) (return . Left)++  case result of+    Right a -> return a+    Left assertion -> do+      s <- ask+      finals <- liftIO . STM.atomically $ STM.swapTVar (integrationStateFinals s) []+      mapM_ reportFinally finals+      H.throwAssertion assertion++retry :: forall a. Int -> Integration a -> Integration a+retry n f = go 0+  where go :: Int -> Integration a+        go i = do+          note_ $ "Retry attempt " <> show i <> " of " <> show n+          result <- H.catchAssertion (fmap Right f) (return . Left)++          case result of+            Right a -> return a+            Left assertion -> do+              if i >= n+                then go (i + 1)+                else do+                  note_ $ "All " <> show (n + 1) <> " attempts failed"+                  H.throwAssertion assertion

@@ -0,0 +1,16 @@+module Hedgehog.Extras.Test.Concurrent+  ( threadDelay+  ) where++import           Control.Monad.IO.Class (MonadIO)+import           Data.Function (($), (.))+import           Data.Int+import           Hedgehog (MonadTest)++import qualified Control.Concurrent as IO+import qualified GHC.Stack as GHC+import qualified Hedgehog as H++-- Delay the thread by 'n' milliseconds.+threadDelay :: (MonadTest m, MonadIO m) => Int -> m ()+threadDelay n = GHC.withFrozenCallStack . H.evalIO $ IO.threadDelay n

@@ -0,0 +1,274 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeApplications #-}++module Hedgehog.Extras.Test.File+  ( createDirectoryIfMissing+  , copyFile+  , renameFile+  , createFileLink+  , listDirectory++  , appendFile+  , writeFile+  , openFile+  , readFile+  , lbsWriteFile+  , lbsReadFile+  , textWriteFile+  , textReadFile++  , copyRewriteJsonFile+  , readJsonFile+  , rewriteJsonFile+  , rewriteLbsJson++  , copyRewriteYamlFile+  , readYamlFile+  , rewriteYamlFile+  , rewriteLbsYaml++  , cat++  , assertIsJsonFile+  , assertIsYamlFile++  , assertFilesExist+  , assertFileOccurences+  , assertFileLines+  , assertEndsWithSingleNewline++  , appendFileTimeDelta+  ) where++import           Control.Monad+import           Control.Monad.IO.Class+import           Data.Aeson (Value)+import           Data.Bool+import           Data.Either+import           Data.Function+import           Data.Functor+import           Data.Int+import           Data.Maybe+import           Data.Semigroup+import           Data.String (String)+import           Data.Text (Text)+import           Data.Time.Clock (UTCTime)+import           GHC.Stack (HasCallStack)+import           Hedgehog (MonadTest)+import           Hedgehog.Extras.Stock.Monad+import           Hedgehog.Extras.Stock.OS+import           System.IO (FilePath, Handle, IOMode)+import           Text.Show++import qualified Data.Aeson as J+import qualified Data.ByteString.Lazy as LBS+import qualified Data.List as L+import qualified Data.Text.IO as T+import qualified Data.Time.Clock as DTC+import qualified Data.Yaml as Y+import qualified GHC.Stack as GHC+import qualified Hedgehog as H+import qualified Hedgehog.Extras.Test.Base as H+import qualified System.Directory as IO+import qualified System.IO as IO++-- | Create the 'filePath' directory if it is missing.+createDirectoryIfMissing :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m ()+createDirectoryIfMissing filePath = GHC.withFrozenCallStack $ do+  H.annotate $ "Creating directory if missing: " <> filePath+  H.evalIO $ IO.createDirectoryIfMissing True filePath++-- | Copy the contents of the 'src' file to the 'dst' file.+copyFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> FilePath -> m ()+copyFile src dst = GHC.withFrozenCallStack $ do+  H.annotate $ "Copying from " <> show src <> " to " <> show dst+  H.evalIO $ IO.copyFile src dst++-- | Rename the 'src' file to 'dst'.+renameFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> FilePath -> m ()+renameFile src dst = GHC.withFrozenCallStack $ do+  H.annotate $ "Copying from " <> show src <> " to " <> show dst+  H.evalIO $ IO.renameFile src dst++-- | Create a symbolic link from 'dst' to 'src'.+createFileLink :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> FilePath -> m ()+createFileLink src dst = GHC.withFrozenCallStack $ do+  H.annotate $ "Creating link from " <> show dst <> " to " <> show src+  if isWin32+    then H.evalIO $ IO.copyFile src dst+    else H.evalIO $ IO.createFileLink src dst++-- | List 'p' directory.+listDirectory :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m [FilePath]+listDirectory p = GHC.withFrozenCallStack $ do+  void . H.annotate $ "Listing directory: " <> p+  H.evalIO $ IO.listDirectory p++-- | Append 'contents' to the 'filePath' file.+appendFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> String -> m ()+appendFile filePath contents = GHC.withFrozenCallStack $ do+  void . H.annotate $ "Writing file: " <> filePath+  H.evalIO $ IO.appendFile filePath contents++-- | Write 'contents' to the 'filePath' file.+writeFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> String -> m ()+writeFile filePath contents = GHC.withFrozenCallStack $ do+  void . H.annotate $ "Writing file: " <> filePath+  H.evalIO $ IO.writeFile filePath contents++-- | Open a handle to the 'filePath' file.+openFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> IOMode -> m Handle+openFile filePath mode = GHC.withFrozenCallStack $ do+  void . H.annotate $ "Opening file: " <> filePath+  H.evalIO $ IO.openFile filePath mode++-- | Read the contents of the 'filePath' file.+readFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m String+readFile filePath = GHC.withFrozenCallStack $ do+  void . H.annotate $ "Reading file: " <> filePath+  H.evalIO $ IO.readFile filePath++-- | Write 'contents' to the 'filePath' file.+lbsWriteFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> LBS.ByteString -> m ()+lbsWriteFile filePath contents = GHC.withFrozenCallStack $ do+  void . H.annotate $ "Writing file: " <> filePath+  H.evalIO $ LBS.writeFile filePath contents++-- | Read the contents of the 'filePath' file.+lbsReadFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m LBS.ByteString+lbsReadFile filePath = GHC.withFrozenCallStack $ do+  void . H.annotate $ "Reading file: " <> filePath+  H.evalIO $ LBS.readFile filePath++-- | Write 'contents' to the 'filePath' file.+textWriteFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> Text -> m ()+textWriteFile filePath contents = GHC.withFrozenCallStack $ do+  void . H.annotate $ "Writing file: " <> filePath+  H.evalIO $ T.writeFile filePath contents++-- | Read the contents of the 'filePath' file.+textReadFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m Text+textReadFile filePath = GHC.withFrozenCallStack $ do+  void . H.annotate $ "Reading file: " <> filePath+  H.evalIO $ T.readFile filePath++-- | Read the 'filePath' file as JSON.+readJsonFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m (Either String Value)+readJsonFile filePath = GHC.withFrozenCallStack $ do+  void . H.annotate $ "Reading JSON file: " <> filePath+  H.evalIO $ J.eitherDecode @Value <$> LBS.readFile filePath++rewriteLbsJson :: (MonadTest m, HasCallStack) => (Value -> Value) -> LBS.ByteString -> m LBS.ByteString+rewriteLbsJson f lbs = GHC.withFrozenCallStack $ do+  case J.eitherDecode lbs of+    Right iv -> return (J.encode (f iv))+    Left msg -> H.failMessage GHC.callStack msg++-- | Rewrite the 'filePath' JSON file using the function 'f'.+rewriteJsonFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> (Value -> Value) -> m ()+rewriteJsonFile filePath f = GHC.withFrozenCallStack $ do+  void . H.annotate $ "Rewriting JSON file: " <> filePath+  lbsReadFile filePath >>= rewriteLbsJson f >>= lbsWriteFile filePath++-- | Rewrite the 'filePath' JSON file using the function 'f'.+copyRewriteJsonFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> FilePath -> (Value -> Value) -> m ()+copyRewriteJsonFile src dst f = GHC.withFrozenCallStack $ do+  void . H.annotate $ "Rewriting JSON from file: " <> src <> " to file " <> dst+  lbsReadFile src >>= rewriteLbsJson f >>= lbsWriteFile dst++-- | Read the 'filePath' file as YAML.+readYamlFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m (Either Y.ParseException Value)+readYamlFile filePath = GHC.withFrozenCallStack $ do+  void . H.annotate $ "Reading YAML file: " <> filePath+  H.evalIO $ Y.decodeEither' @Value . LBS.toStrict <$> LBS.readFile filePath++rewriteLbsYaml :: (MonadTest m, HasCallStack) => (Value -> Value) -> LBS.ByteString -> m LBS.ByteString+rewriteLbsYaml f lbs = GHC.withFrozenCallStack $ do+  case Y.decodeEither' (LBS.toStrict lbs) of+    Right iv -> return (J.encode (f iv))+    Left msg -> H.failMessage GHC.callStack (show msg)++-- | Rewrite the 'filePath' YAML file using the function 'f'.+rewriteYamlFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> (Value -> Value) -> m ()+rewriteYamlFile filePath f = GHC.withFrozenCallStack $ do+  void . H.annotate $ "Rewriting YAML file: " <> filePath+  lbsReadFile filePath >>= rewriteLbsYaml f >>= lbsWriteFile filePath++-- | Rewrite the 'filePath' YAML file using the function 'f'.+copyRewriteYamlFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> FilePath -> (Value -> Value) -> m ()+copyRewriteYamlFile src dst f = GHC.withFrozenCallStack $ do+  void . H.annotate $ "Rewriting YAML from file: " <> src <> " to file " <> dst+  lbsReadFile src >>= rewriteLbsYaml f >>= lbsWriteFile dst++-- | Annotate the contents of the 'filePath' file.+cat :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m ()+cat filePath = GHC.withFrozenCallStack $ do+  !contents <- forceM $ readFile filePath+  void . H.annotate $ L.unlines+    [ "━━━━ File: " <> filePath <> " ━━━━"+    , contents+    ]+  return ()++-- | Assert the 'filePath' can be parsed as JSON.+assertIsJsonFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m ()+assertIsJsonFile fp = GHC.withFrozenCallStack $ do+  jsonResult <- readJsonFile fp+  case jsonResult of+    Right _ -> return ()+    Left msg -> H.failMessage GHC.callStack msg++-- | Assert the 'filePath' can be parsed as YAML.+assertIsYamlFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m ()+assertIsYamlFile fp = GHC.withFrozenCallStack $ do+  result <- readJsonFile fp+  case result of+    Right _ -> return ()+    Left msg -> H.failMessage GHC.callStack msg++-- | Checks if all files gives exists. If this fails, all files are deleted.+assertFilesExist :: (MonadTest m, MonadIO m, HasCallStack) => [FilePath] -> m ()+assertFilesExist [] = return ()+assertFilesExist (file:rest) = do+  exists <- H.evalIO $ IO.doesFileExist file+  if exists+    then GHC.withFrozenCallStack $ assertFilesExist rest+    else H.failWithCustom GHC.callStack Nothing (file <> " has not been successfully created.")++-- | Assert the file contains the given number of occurrences of the given string+assertFileOccurences :: (MonadTest m, MonadIO m, HasCallStack) => Int -> String -> FilePath -> m ()+assertFileOccurences n s fp = GHC.withFrozenCallStack $ do+  contents <- readFile fp++  L.length (L.filter (s `L.isInfixOf`) (L.lines contents)) H.=== n++-- | Assert the file contains the given number of occurrences of the given string+assertFileLines :: (MonadTest m, MonadIO m, HasCallStack) => (Int -> Bool) -> FilePath -> m ()+assertFileLines p fp = GHC.withFrozenCallStack $ do+  contents <- readFile fp++  let lines = L.lines contents++  let len = case L.reverse lines of+        "":xs -> L.length xs+        xs -> L.length xs++  unless (p len) $ do+    H.failWithCustom GHC.callStack Nothing (fp <> " has an unexpected number of lines")++-- | Assert the file contains the given number of occurrences of the given string+assertEndsWithSingleNewline :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m ()+assertEndsWithSingleNewline fp = GHC.withFrozenCallStack $ do+  contents <- readFile fp++  case L.reverse contents of+    '\n':'\n':_ -> H.failWithCustom GHC.callStack Nothing (fp <> " ends with too many newlines.")+    '\n':_ -> return ()+    _ -> H.failWithCustom GHC.callStack Nothing (fp <> " must end with newline.")++-- | Write 'contents' to the 'filePath' file.+appendFileTimeDelta :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> UTCTime ->  m ()+appendFileTimeDelta filePath offsetTime = GHC.withFrozenCallStack $ do+  baseTime <- H.noteShowIO DTC.getCurrentTime+  let delay = DTC.diffUTCTime baseTime offsetTime+  appendFile filePath $ show @DTC.NominalDiffTime delay <> "\n"

@@ -0,0 +1,32 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}++module Hedgehog.Extras.Test.MonadAssertion+  ( MonadAssertion(..)+  ) where++import           Control.Monad+import           Control.Monad.Trans.Class+import           Data.Either+import           Data.Function+import           Data.Monoid (mempty)++import qualified Control.Monad.Trans.Except as E+import qualified Control.Monad.Trans.Resource as IO+import qualified Control.Monad.Trans.Resource.Internal as IO+import qualified Hedgehog as H+import qualified Hedgehog.Internal.Property as H++class Monad m => MonadAssertion m where+  throwAssertion :: H.Failure -> m a+  catchAssertion :: m a -> (H.Failure -> m a) -> m a++instance Monad m => MonadAssertion (H.TestT m) where+  throwAssertion f = H.liftTest $ H.mkTest (Left f, mempty)+  catchAssertion g h = H.TestT $ E.catchE (H.unTest g) (H.unTest . h)++instance MonadAssertion m => MonadAssertion (IO.ResourceT m) where+  throwAssertion = lift . throwAssertion+  catchAssertion r h = IO.ResourceT $ \i -> IO.unResourceT r i `catchAssertion` \e -> IO.unResourceT (h e) i++deriving instance Monad m => MonadAssertion (H.PropertyT m)

@@ -0,0 +1,71 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Hedgehog.Extras.Test.Network+  ( doesFileExists+  , isPortOpen+  , doesSocketExist+  , assertFileExists+  , assertPortOpen+  , assertSocketExists+  , doesSprocketExist+  ) where++import           Control.Exception (IOException, try)+import           Control.Monad+import           Control.Monad.IO.Class (MonadIO)+import           Data.Bool+import           Data.Either+import           Data.Function+import           Data.Int+import           Data.Semigroup+import           GHC.Stack (HasCallStack)+import           Hedgehog (MonadTest)+import           Hedgehog.Extras.Stock.IO.Network.Sprocket (Sprocket, sprocketSystemName)+import           System.IO (FilePath)+import           Text.Show++import qualified GHC.Stack as GHC+import qualified Hedgehog as H+import qualified Hedgehog.Extras.Stock.IO.Network.NamedPipe as IO+import qualified Hedgehog.Extras.Stock.IO.Network.Socket as IO+import qualified Hedgehog.Extras.Stock.OS as OS+import qualified Hedgehog.Extras.Test.Base as H+import qualified System.Directory as IO++-- | Test if a file exists+doesFileExists :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m Bool+doesFileExists = GHC.withFrozenCallStack . H.evalIO . IO.doesFileExist++-- | Test if a port is open+isPortOpen :: (MonadTest m, MonadIO m, HasCallStack) => Int -> m Bool+isPortOpen port = GHC.withFrozenCallStack $ do+  H.note_ $ "Port: " <> show port+  H.evalIO $ IO.isPortOpen port++-- | Test if a socket file exists+doesSocketExist :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m Bool+doesSocketExist = GHC.withFrozenCallStack . H.evalIO . IO.doesSocketExist++-- | Assert that a file exists+assertFileExists :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m ()+assertFileExists = GHC.withFrozenCallStack . H.assertM . doesFileExists++-- | Assert that a port is open+assertPortOpen :: (MonadTest m, MonadIO m, HasCallStack) => Int -> m ()+assertPortOpen = GHC.withFrozenCallStack . H.assertM . isPortOpen++-- | Assert that a socket file exists is open+assertSocketExists :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m ()+assertSocketExists = GHC.withFrozenCallStack . H.assertM . doesSocketExist++-- | Test if the sprocket exists+doesSprocketExist :: (MonadTest m, MonadIO m, HasCallStack) => Sprocket -> m Bool+doesSprocketExist socket = GHC.withFrozenCallStack $ do+  waitResult <- H.evalIO . try $ if OS.isWin32+    then IO.doesNamedPipeExist (sprocketSystemName socket)+    else IO.doesSocketExist (sprocketSystemName socket)+  case waitResult of+    Right result -> return result+    Left (e :: IOException) -> do+      H.annotate $ "Error: " <> show e+      return False

@@ -0,0 +1,347 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Hedgehog.Extras.Test.Process+  ( createProcess+  , exec+  , exec_+  , execFlex+  , execFlex'+  , procFlex+  , binFlex++  , getProjectBase+  , waitForProcess+  , maybeWaitForProcess+  , getPid+  , waitSecondsForProcess++  , ExecConfig(..)+  , defaultExecConfig+  ) where++import           Control.Monad (Monad(..),  MonadFail(fail), void)+import           Control.Monad.Catch (MonadCatch)+import           Control.Monad.IO.Class (MonadIO, liftIO)+import           Control.Monad.Trans.Resource (MonadResource, ReleaseKey, register)+import           Data.Aeson (eitherDecode)+import           Data.Bool (Bool(..))+import           Data.Either (Either(..))+import           Data.Eq (Eq(..))+import           Data.Function (($), (&), (.))+import           Data.Functor (Functor(..))+import           Data.Int (Int)+import           Data.Maybe (Maybe (..))+import           Data.Monoid (Last (..), mempty, (<>))+import           Data.String (String)+import           GHC.Stack (HasCallStack)+import           Hedgehog (MonadTest)+import           Hedgehog.Extras.Internal.Cli (argQuote)+import           Hedgehog.Extras.Internal.Plan (Component(..), Plan(..))+import           Hedgehog.Extras.Stock.IO.Process (TimedOut (..))+import           Prelude (error)+import           System.Exit (ExitCode)+import           System.FilePath (takeDirectory)+import           System.FilePath.Posix ((</>))+import           System.IO (FilePath, Handle, IO)+import           System.Process (CmdSpec (..), CreateProcess (..), Pid, ProcessHandle)+import           Text.Show (Show(show))++import qualified Data.ByteString.Lazy as LBS+import qualified Data.List as L+import qualified Data.Text as T+import qualified GHC.Stack as GHC+import qualified Hedgehog as H+import qualified Hedgehog.Extras.Stock.IO.Process as IO+import qualified Hedgehog.Extras.Stock.OS as OS+import qualified Hedgehog.Extras.Test.Base as H+import qualified System.Directory as IO+import qualified System.Environment as IO+import qualified System.Exit as IO+import qualified System.IO.Unsafe as IO+import qualified System.Process as IO++-- | Configuration for starting a new process.  This is a subset of 'IO.CreateProcess'.+data ExecConfig = ExecConfig+  { execConfigEnv :: Last [(String, String)]+  , execConfigCwd :: Last FilePath+  } deriving (Eq, Show)++defaultExecConfig :: ExecConfig+defaultExecConfig = ExecConfig+  { execConfigEnv = mempty+  , execConfigCwd = mempty+  }++-- | Find the nearest plan.json going upwards from the current directory.+findDefaultPlanJsonFile :: IO FilePath+findDefaultPlanJsonFile = IO.getCurrentDirectory >>= go+  where go :: FilePath -> IO FilePath+        go d = do+          let file = d </> "dist-newstyle/cache/plan.json"+          exists <- IO.doesFileExist file+          if exists+            then return file+            else do+              let parent = takeDirectory d+              if parent == d+                then return "dist-newstyle/cache/plan.json"+                else go parent++-- | Discover the location of the plan.json file.+planJsonFile :: String+planJsonFile = IO.unsafePerformIO $ do+  maybeBuildDir <- liftIO $ IO.lookupEnv "CABAL_BUILDDIR"+  case maybeBuildDir of+    Just buildDir -> return $ ".." </> buildDir </> "cache/plan.json"+    Nothing -> findDefaultPlanJsonFile+{-# NOINLINE planJsonFile #-}++exeSuffix :: String+exeSuffix = if OS.isWin32 then ".exe" else ""++addExeSuffix :: String -> String+addExeSuffix s = if ".exe" `L.isSuffixOf` s+  then s+  else s <> exeSuffix++-- | Create a process returning handles to stdin, stdout, and stderr as well as the process handle.+createProcess+  :: (MonadTest m, MonadResource m, HasCallStack)+  => CreateProcess+  -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle, ReleaseKey)+createProcess cp = GHC.withFrozenCallStack $ do+  H.annotate $ "CWD: " <> show (IO.cwd cp)+  case IO.cmdspec cp of+    RawCommand cmd args -> H.annotate $ "Command line: " <> cmd <> " " <> L.unwords args+    ShellCommand cmd -> H.annotate $ "Command line: " <> cmd+  (mhStdin, mhStdout, mhStderr, hProcess) <- H.evalIO $ IO.createProcess cp+  releaseKey <- register $ IO.cleanupProcess (mhStdin, mhStdout, mhStderr, hProcess)++  return (mhStdin, mhStdout, mhStderr, hProcess, releaseKey)++-- | Get the process ID.+getPid+  :: (MonadTest m, MonadIO m, HasCallStack)+  => ProcessHandle+  -> m (Maybe Pid)+getPid hProcess = GHC.withFrozenCallStack . H.evalIO $ IO.getPid hProcess++-- | Create a process returning its stdout.+--+-- Being a 'flex' function means that the environment determines how the process is launched.+--+-- When running in a nix environment, the 'envBin' argument describes the environment variable+-- that defines the binary to use to launch the process.+--+-- When running outside a nix environment, the `pkgBin` describes the name of the binary+-- to launch via cabal exec.+execFlex+  :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)+  => String+  -> String+  -> [String]+  -> m String+execFlex = execFlex' defaultExecConfig++execFlex'+  :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)+  => ExecConfig+  -> String+  -> String+  -> [String]+  -> m String+execFlex' execConfig pkgBin envBin arguments = GHC.withFrozenCallStack $ do+  cp <- procFlex' execConfig pkgBin envBin arguments+  H.annotate . ("Command: " <>) $ case IO.cmdspec cp of+    IO.ShellCommand cmd -> cmd+    IO.RawCommand cmd args -> cmd <> " " <> L.unwords args+  (exitResult, stdout, stderr) <- H.evalIO $ IO.readCreateProcessWithExitCode cp ""+  case exitResult of+    IO.ExitFailure exitCode -> do+      H.annotate $ L.unlines $+        [ "Process exited with non-zero exit-code"+        , "━━━━ command ━━━━"+        , pkgBin <> " " <> L.unwords (fmap argQuote arguments)+        , "━━━━ stdout ━━━━"+        , stdout+        , "━━━━ stderr ━━━━"+        , stderr+        , "━━━━ exit code ━━━━"+        , show @Int exitCode+        ]+      H.failMessage GHC.callStack "Execute process failed"+    IO.ExitSuccess -> return stdout++-- | Execute a process, returning '()'.+exec_+  :: (MonadTest m, MonadIO m, HasCallStack)+  => ExecConfig+  -> String+  -> [String]+  -> m ()+exec_ execConfig bin arguments = void $ exec execConfig bin arguments++-- | Execute a process+exec+  :: (MonadTest m, MonadIO m, HasCallStack)+  => ExecConfig+  -> String+  -> [String]+  -> m String+exec execConfig bin arguments = GHC.withFrozenCallStack $ do+  let cp = (IO.proc bin arguments)+        { IO.env = getLast $ execConfigEnv execConfig+        , IO.cwd = getLast $ execConfigCwd execConfig+        }+  H.annotate . ("Command: " <>) $ bin <> " " <> L.unwords arguments+  (exitResult, stdout, stderr) <- H.evalIO $ IO.readCreateProcessWithExitCode cp ""+  case exitResult of+    IO.ExitFailure exitCode -> H.failMessage GHC.callStack . L.unlines $+      [ "Process exited with non-zero exit-code"+      , "━━━━ command ━━━━"+      , bin <> " " <> L.unwords (fmap argQuote arguments)+      , "━━━━ stdout ━━━━"+      , stdout+      , "━━━━ stderr ━━━━"+      , stderr+      , "━━━━ exit code ━━━━"+      , show @Int exitCode+      ]+    IO.ExitSuccess -> return stdout++-- | Wait for process to exit.+waitForProcess+  :: (MonadTest m, MonadIO m, HasCallStack)+  => ProcessHandle+  -> m ExitCode+waitForProcess hProcess = GHC.withFrozenCallStack $+  H.evalIO $ IO.waitForProcess hProcess++-- | Wait for process to exit or return 'Nothing' if interrupted by an asynchronous exception.+maybeWaitForProcess+  :: (MonadTest m, MonadIO m, HasCallStack)+  => ProcessHandle+  -> m (Maybe ExitCode)+maybeWaitForProcess hProcess = GHC.withFrozenCallStack $+  H.evalIO $ IO.maybeWaitForProcess hProcess++-- | Wait a maximum of 'seconds' secons for process to exit.+waitSecondsForProcess+  :: (MonadTest m, MonadIO m, HasCallStack)+  => Int+  -> ProcessHandle+  -> m (Either TimedOut ExitCode)+waitSecondsForProcess seconds hProcess = GHC.withFrozenCallStack $ do+  result <- H.evalIO $ IO.waitSecondsForProcess seconds hProcess+  case result of+    Left TimedOut -> do+      H.annotate "Timed out waiting for process to exit"+      return (Left TimedOut)+    Right maybeExitCode -> do+      case maybeExitCode of+        Nothing -> H.failMessage GHC.callStack "No exit code for process"+        Just exitCode -> do+          H.annotate $ "Process exited " <> show exitCode+          return (Right exitCode)++-- | Compute the path to the binary given a package name or an environment variable override.+binFlex+  :: (MonadTest m, MonadIO m)+  => String+  -- ^ Package name+  -> String+  -- ^ Environment variable pointing to the binary to run+  -> m FilePath+  -- ^ Path to executable+binFlex pkg binaryEnv = do+  maybeEnvBin <- liftIO $ IO.lookupEnv binaryEnv+  case maybeEnvBin of+    Just envBin -> return envBin+    Nothing -> binDist pkg++-- | Consult the "plan.json" generated by cabal to get the path to the executable corresponding.+-- to a haskell package.  It is assumed that the project has already been configured and the+-- executable has been built.+binDist+  :: (MonadTest m, MonadIO m)+  => String+  -- ^ Package name+  -> m FilePath+  -- ^ Path to executable+binDist pkg = do+  contents <- H.evalIO . LBS.readFile $ planJsonFile++  case eitherDecode contents of+    Right plan -> case L.filter matching (plan & installPlan) of+      (component:_) -> case component & binFile of+        Just bin -> return $ addExeSuffix (T.unpack bin)+        Nothing -> error $ "missing bin-file in: " <> show component+      [] -> error $ "Cannot find exe:" <> pkg <> " in plan"+    Left message -> error $ "Cannot decode plan: " <> message+  where matching :: Component -> Bool+        matching component = case componentName component of+          Just name -> name == "exe:" <> T.pack pkg+          Nothing -> False++-- | Create a 'CreateProcess' describing how to start a process given the Cabal package name+-- corresponding to the executable, an environment variable pointing to the executable,+-- and an argument list.+--+-- The actual executable used will the one specified by the environment variable, but if+-- the environment variable is not defined, it will be found instead by consulting the+-- "plan.json" generated by cabal.  It is assumed that the project has already been+-- configured and the executable has been built.+procFlex+  :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)+  => String+  -- ^ Cabal package name corresponding to the executable+  -> String+  -- ^ Environment variable pointing to the binary to run+  -> [String]+  -- ^ Arguments to the CLI command+  -> m CreateProcess+  -- ^ Captured stdout+procFlex = procFlex' defaultExecConfig++procFlex'+  :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)+  => ExecConfig+  -> String+  -- ^ Cabal package name corresponding to the executable+  -> String+  -- ^ Environment variable pointing to the binary to run+  -> [String]+  -- ^ Arguments to the CLI command+  -> m CreateProcess+  -- ^ Captured stdout+procFlex' execConfig pkg binaryEnv arguments = GHC.withFrozenCallStack . H.evalM $ do+  bin <- binFlex pkg binaryEnv+  return (IO.proc bin arguments)+    { IO.env = getLast $ execConfigEnv execConfig+    , IO.cwd = getLast $ execConfigCwd execConfig+    }++-- | Compute the project base.  This will be based on either the "CARDANO_NODE_SRC"+-- environment variable or the first parent directory that contains the `cabal.project`.+-- Both should point to the root directory of the Github project checkout.+getProjectBase+  :: (MonadTest m, MonadIO m)+  => m String+getProjectBase = do+  let+    findUp dir = do+      atBase <- liftIO $ IO.doesFileExist (dir <> "/cabal.project")+      if atBase+        then return dir+        else do+          let up = dir <> "/.."+          upExist <- liftIO $ IO.doesDirectoryExist up+          if upExist+            then findUp up+            else liftIO $ fail "Could not detect project base directory (containing cabal.project)"+  maybeNodeSrc <- liftIO $ IO.lookupEnv "CARDANO_NODE_SRC"+  case maybeNodeSrc of+    Just path -> return path+    Nothing -> findUp "."