diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/NOTICE b/NOTICE new file mode 100644 --- /dev/null +++ b/NOTICE @@ -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. + diff --git a/hedgehog-extras.cabal b/hedgehog-extras.cabal new file mode 100644 --- /dev/null +++ b/hedgehog-extras.cabal @@ -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 diff --git a/src/Hedgehog/Extras.hs b/src/Hedgehog/Extras.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras.hs @@ -0,0 +1,5 @@ +module Hedgehog.Extras + ( module X + ) where + +import Hedgehog.Extras.Test as X diff --git a/src/Hedgehog/Extras/Aeson.hs b/src/Hedgehog/Extras/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Aeson.hs @@ -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' diff --git a/src/Hedgehog/Extras/Internal/Cli.hs b/src/Hedgehog/Extras/Internal/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Internal/Cli.hs @@ -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 "" = "" diff --git a/src/Hedgehog/Extras/Internal/Plan.hs b/src/Hedgehog/Extras/Internal/Plan.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Internal/Plan.hs @@ -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" diff --git a/src/Hedgehog/Extras/Internal/Test/Integration.hs b/src/Hedgehog/Extras/Internal/Test/Integration.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Internal/Test/Integration.hs @@ -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 diff --git a/src/Hedgehog/Extras/Internal/Win32/NamedPipes.hsc b/src/Hedgehog/Extras/Internal/Win32/NamedPipes.hsc new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Internal/Win32/NamedPipes.hsc @@ -0,0 +1,71 @@ +#include +#include + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} + +-- | For full details on the Windows named pipes API see +-- +-- +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 diff --git a/src/Hedgehog/Extras/Stock.hs b/src/Hedgehog/Extras/Stock.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Stock.hs @@ -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 diff --git a/src/Hedgehog/Extras/Stock/Aeson.hs b/src/Hedgehog/Extras/Stock/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Stock/Aeson.hs @@ -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 diff --git a/src/Hedgehog/Extras/Stock/CallStack.hs b/src/Hedgehog/Extras/Stock/CallStack.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Stock/CallStack.hs @@ -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 "" (srcLocModule . snd) (listToMaybe (getCallStack callStack)) diff --git a/src/Hedgehog/Extras/Stock/IO/File.hs b/src/Hedgehog/Extras/Stock/IO/File.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Stock/IO/File.hs @@ -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 diff --git a/src/Hedgehog/Extras/Stock/IO/Network/NamedPipe.hs b/src/Hedgehog/Extras/Stock/IO/Network/NamedPipe.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Stock/IO/Network/NamedPipe.hs @@ -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 diff --git a/src/Hedgehog/Extras/Stock/IO/Network/Socket.hs b/src/Hedgehog/Extras/Stock/IO/Network/Socket.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Stock/IO/Network/Socket.hs @@ -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 diff --git a/src/Hedgehog/Extras/Stock/IO/Network/Sprocket.hs b/src/Hedgehog/Extras/Stock/IO/Network/Sprocket.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Stock/IO/Network/Sprocket.hs @@ -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 [] = [] diff --git a/src/Hedgehog/Extras/Stock/IO/Process.hs b/src/Hedgehog/Extras/Stock/IO/Process.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Stock/IO/Process.hs @@ -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) diff --git a/src/Hedgehog/Extras/Stock/Monad.hs b/src/Hedgehog/Extras/Stock/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Stock/Monad.hs @@ -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 <$!>) diff --git a/src/Hedgehog/Extras/Stock/OS.hs b/src/Hedgehog/Extras/Stock/OS.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Stock/OS.hs @@ -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 #-} diff --git a/src/Hedgehog/Extras/Stock/String.hs b/src/Hedgehog/Extras/Stock/String.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Stock/String.hs @@ -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 diff --git a/src/Hedgehog/Extras/Stock/Time.hs b/src/Hedgehog/Extras/Stock/Time.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Stock/Time.hs @@ -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")) diff --git a/src/Hedgehog/Extras/Test.hs b/src/Hedgehog/Extras/Test.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Test.hs @@ -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 diff --git a/src/Hedgehog/Extras/Test/Base.hs b/src/Hedgehog/Extras/Test/Base.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Test/Base.hs @@ -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 diff --git a/src/Hedgehog/Extras/Test/Concurrent.hs b/src/Hedgehog/Extras/Test/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Test/Concurrent.hs @@ -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 diff --git a/src/Hedgehog/Extras/Test/File.hs b/src/Hedgehog/Extras/Test/File.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Test/File.hs @@ -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" diff --git a/src/Hedgehog/Extras/Test/MonadAssertion.hs b/src/Hedgehog/Extras/Test/MonadAssertion.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Test/MonadAssertion.hs @@ -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) diff --git a/src/Hedgehog/Extras/Test/Network.hs b/src/Hedgehog/Extras/Test/Network.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Test/Network.hs @@ -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 diff --git a/src/Hedgehog/Extras/Test/Process.hs b/src/Hedgehog/Extras/Test/Process.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Test/Process.hs @@ -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 "."