From b3b5cd86953b0018dae40b20646af5d1af4ce1b4 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Sat, 24 Feb 2024 04:07:03 -0800 Subject: [PATCH] Improve logging callstack for createProcessWithLogging etc. and add demo --- demos/demo-processes/LICENSE | 30 +++++++++++++ demos/demo-processes/app/Main.hs | 54 +++++++++++++++++++++++ demos/demo-processes/demo-processes.cabal | 37 ++++++++++++++++ demos/demo-processes/package.yaml | 32 ++++++++++++++ sandwich/CHANGELOG.md | 2 + sandwich/src/Test/Sandwich/Logging.hs | 32 +++++++------- stack.yaml | 1 + 7 files changed, 172 insertions(+), 16 deletions(-) create mode 100644 demos/demo-processes/LICENSE create mode 100644 demos/demo-processes/app/Main.hs create mode 100644 demos/demo-processes/demo-processes.cabal create mode 100644 demos/demo-processes/package.yaml diff --git a/demos/demo-processes/LICENSE b/demos/demo-processes/LICENSE new file mode 100644 index 00000000..4b04e0b0 --- /dev/null +++ b/demos/demo-processes/LICENSE @@ -0,0 +1,30 @@ +Copyright Tom McLaughlin (c) 2023 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Tom McLaughlin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/demos/demo-processes/app/Main.hs b/demos/demo-processes/app/Main.hs new file mode 100644 index 00000000..81080c2f --- /dev/null +++ b/demos/demo-processes/app/Main.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import Common +import Control.Concurrent +import Control.Monad.IO.Class +import Control.Monad.Logger +import Data.String.Interpolate +import System.Exit +import System.Process +import Test.Sandwich + + +parallelNDemo :: TopSpec +parallelNDemo = describe "Creating processes with logging" $ do + it "createProcessWithLogging" $ do + p <- createProcessWithLogging (shell "echo hiiiiii") + liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess) + + it "createProcessWithLogging'" $ do + p <- createProcessWithLogging' LevelDebug (shell "echo hiiiiii") + liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess) + + it "createProcessWithLoggingAndStdin" $ do + p <- createProcessWithLoggingAndStdin (shell "echo hiiiiii") "" + liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess) + + it "createProcessWithLoggingAndStdin'" $ do + p <- createProcessWithLoggingAndStdin' LevelDebug (shell "echo hiiiiii") "" + liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess) + + it "readCreateProcessWithLogging" $ do + stdout <- readCreateProcessWithLogging (shell ">&2 echo hiiiiii") "" + info [i|Got stdout: #{stdout}|] + + it "readCreateProcessWithLogging'" $ do + stdout <- readCreateProcessWithLogging' LevelDebug (shell ">&2 echo hiiiiii") "" + info [i|Got stdout: #{stdout}|] + + it "callCommandWithLogging" $ do + callCommandWithLogging ">&2 echo hiiiiii" + + it "callCommandWithLogging'" $ do + callCommandWithLogging' LevelDebug ">&2 echo hiiiiii" + +testOptions = defaultOptions { + optionsTestArtifactsDirectory = defaultTestArtifactsDirectory + } + +main :: IO () +main = runSandwichWithCommandLineArgs testOptions parallelNDemo diff --git a/demos/demo-processes/demo-processes.cabal b/demos/demo-processes/demo-processes.cabal new file mode 100644 index 00000000..802c7fb5 --- /dev/null +++ b/demos/demo-processes/demo-processes.cabal @@ -0,0 +1,37 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: demo-processes +version: 0.1.0.0 +license: BSD3 +license-file: LICENSE +build-type: Simple + +executable demo-processes + main-is: Main.hs + other-modules: + Paths_demo_processes + hs-source-dirs: + app + default-extensions: + OverloadedStrings + QuasiQuotes + NamedFieldPuns + RecordWildCards + ScopedTypeVariables + FlexibleContexts + FlexibleInstances + LambdaCase + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base + , monad-logger + , process + , sandwich + , sandwich-demos + , string-interpolate + , time + default-language: Haskell2010 diff --git a/demos/demo-processes/package.yaml b/demos/demo-processes/package.yaml new file mode 100644 index 00000000..3147d171 --- /dev/null +++ b/demos/demo-processes/package.yaml @@ -0,0 +1,32 @@ +name: demo-processes +version: 0.1.0.0 +license: BSD3 + +dependencies: +- base +- monad-logger +- process +- sandwich +- sandwich-demos +- string-interpolate +- time + +default-extensions: +- OverloadedStrings +- QuasiQuotes +- NamedFieldPuns +- RecordWildCards +- ScopedTypeVariables +- FlexibleContexts +- FlexibleInstances +- LambdaCase + +ghc-options: +- -threaded +- -rtsopts +- -with-rtsopts=-N + +executables: + demo-processes: + main: Main.hs + source-dirs: app diff --git a/sandwich/CHANGELOG.md b/sandwich/CHANGELOG.md index 0467979a..06193f6d 100644 --- a/sandwich/CHANGELOG.md +++ b/sandwich/CHANGELOG.md @@ -2,6 +2,8 @@ ## Unreleased changes +* Make createProcessWithLogging, readCreateProcessWithLogging etc. log with the callstack from the line where they're called (and not an internal line). + ## 0.2.2.0 * Add primed versions of createProcessWithLogging etc. with customizable log level diff --git a/sandwich/src/Test/Sandwich/Logging.hs b/sandwich/src/Test/Sandwich/Logging.hs index 3f7a2814..cc2fffa8 100644 --- a/sandwich/src/Test/Sandwich/Logging.hs +++ b/sandwich/src/Test/Sandwich/Logging.hs @@ -74,11 +74,11 @@ logOther = logOtherCS callStack -- | Spawn a process with its stdout and stderr connected to the logging system. -- Every line output by the process will be fed to a 'debug' call. -createProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> m ProcessHandle -createProcessWithLogging = createProcessWithLogging' LevelDebug +createProcessWithLogging :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> m ProcessHandle +createProcessWithLogging = withFrozenCallStack (createProcessWithLogging' LevelDebug) -- | Spawn a process with its stdout and stderr connected to the logging system. -createProcessWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> m ProcessHandle +createProcessWithLogging' :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> CreateProcess -> m ProcessHandle createProcessWithLogging' logLevel cp = do (hRead, hWrite) <- liftIO createPipe @@ -88,18 +88,18 @@ createProcessWithLogging' logLevel cp = do _ <- async $ forever $ do line <- liftIO $ hGetLine hRead - logOther logLevel [i|#{name}: #{line}|] + logOtherCS callStack logLevel [i|#{name}: #{line}|] (_, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hWrite, std_err = UseHandle hWrite }) return p -- | Like 'readCreateProcess', but capture the stderr output in the logs. -- Every line output by the process will be fed to a 'debug' call. -readCreateProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> String -> m String -readCreateProcessWithLogging = readCreateProcessWithLogging' LevelDebug +readCreateProcessWithLogging :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> String -> m String +readCreateProcessWithLogging = withFrozenCallStack (readCreateProcessWithLogging' LevelDebug) -- | Like 'readCreateProcess', but capture the stderr output in the logs. -readCreateProcessWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> String -> m String +readCreateProcessWithLogging' :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m String readCreateProcessWithLogging' logLevel cp input = do (hReadErr, hWriteErr) <- liftIO createPipe @@ -109,7 +109,7 @@ readCreateProcessWithLogging' logLevel cp input = do _ <- async $ forever $ do line <- liftIO $ hGetLine hReadErr - logOther logLevel [i|#{name}: #{line}|] + logOtherCS callStack logLevel [i|#{name}: #{line}|] -- Do this just like 'readCreateProcess' -- https://hackage.haskell.org/package/process-1.6.17.0/docs/src/System.Process.html#readCreateProcess @@ -149,11 +149,11 @@ readCreateProcessWithLogging' logLevel cp input = do -- | Spawn a process with its stdout and stderr connected to the logging system. -- Every line output by the process will be fed to a 'debug' call. -createProcessWithLoggingAndStdin :: (MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> String -> m ProcessHandle -createProcessWithLoggingAndStdin = createProcessWithLoggingAndStdin' LevelDebug +createProcessWithLoggingAndStdin :: (HasCallStack, MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> String -> m ProcessHandle +createProcessWithLoggingAndStdin = withFrozenCallStack (createProcessWithLoggingAndStdin' LevelDebug) -- | Spawn a process with its stdout and stderr connected to the logging system. -createProcessWithLoggingAndStdin' :: (MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> String -> m ProcessHandle +createProcessWithLoggingAndStdin' :: (HasCallStack, MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m ProcessHandle createProcessWithLoggingAndStdin' logLevel cp input = do (hRead, hWrite) <- liftIO createPipe @@ -163,7 +163,7 @@ createProcessWithLoggingAndStdin' logLevel cp input = do _ <- async $ forever $ do line <- liftIO $ hGetLine hRead - logOther logLevel [i|#{name}: #{line}|] + logOtherCS callStack logLevel [i|#{name}: #{line}|] (Just inh, _, _, p) <- liftIO $ createProcess ( cp { std_out = UseHandle hWrite @@ -179,11 +179,11 @@ createProcessWithLoggingAndStdin' logLevel cp input = do return p -- | Higher level version of 'createProcessWithLogging', accepting a shell command. -callCommandWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => String -> m () -callCommandWithLogging = callCommandWithLogging' LevelDebug +callCommandWithLogging :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => String -> m () +callCommandWithLogging = withFrozenCallStack (callCommandWithLogging' LevelDebug) -- | Higher level version of 'createProcessWithLogging'', accepting a shell command. -callCommandWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> String -> m () +callCommandWithLogging' :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> String -> m () callCommandWithLogging' logLevel cmd = do (hRead, hWrite) <- liftIO createPipe @@ -195,7 +195,7 @@ callCommandWithLogging' logLevel cmd = do _ <- async $ forever $ do line <- liftIO $ hGetLine hRead - logOther logLevel [i|#{cmd}: #{line}|] + logOtherCS callStack logLevel [i|#{cmd}: #{line}|] liftIO (waitForProcess p) >>= \case ExitSuccess -> return () diff --git a/stack.yaml b/stack.yaml index a9799e0b..f873e734 100644 --- a/stack.yaml +++ b/stack.yaml @@ -27,6 +27,7 @@ packages: - ./demos/demo-hedgehog - ./demos/demo-landing - ./demos/demo-paralleln +- ./demos/demo-processes - ./demos/demo-quickcheck - ./demos/demo-setup-teardown - ./demos/demo-slack