mirror of
https://github.com/codedownio/sandwich.git
synced 2024-10-26 20:49:20 +03:00
Improve logging callstack for createProcessWithLogging etc. and add demo
This commit is contained in:
parent
7983d5c6d3
commit
b3b5cd8695
30
demos/demo-processes/LICENSE
Normal file
30
demos/demo-processes/LICENSE
Normal file
@ -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.
|
54
demos/demo-processes/app/Main.hs
Normal file
54
demos/demo-processes/app/Main.hs
Normal file
@ -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
|
37
demos/demo-processes/demo-processes.cabal
Normal file
37
demos/demo-processes/demo-processes.cabal
Normal file
@ -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
|
32
demos/demo-processes/package.yaml
Normal file
32
demos/demo-processes/package.yaml
Normal file
@ -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
|
@ -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
|
||||
|
@ -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 ()
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user