Flameshot.Internal: add logger callbacks

1 files changed, 26 insertions, 0 deletions

diff --git a/src/Flameshot/Internal.hs b/src/Flameshot/Internal.hs
index b01b145..fc561fe 100644
--- a/src/Flameshot/Internal.hs
+++ b/src/Flameshot/Internal.hs
@@ -21,6 +21,7 @@ import DBus.Socket
 import Data.Text (Text)
 import qualified Data.Text.Extended as T
 import qualified Flameshot.Internal.Process as P
+import System.Exit
 
 
 blessBusName :: BusName -> Blessings Text
@@ -111,3 +112,28 @@ showUnprintable =
 copyToClipboard :: String -> ByteString -> IO ()
 copyToClipboard mimetype =
     P.writeDaemon "xclip" ["-selection", "clipboard", "-t", mimetype, "-i"]
+
+logger :: (Blessings Text -> IO ()) -> Text -> P.Callbacks
+logger putLog name =
+    P.Callbacks
+      { P.onOutLine = \pid s ->
+        putLog' pid $ "stdout: " <> Plain s
+
+      , P.onErrLine = \pid s ->
+        putLog' pid $ "stderr: " <> red (Plain s)
+
+      , P.onError = \pid err ->
+        putLog' pid $ "error: " <> blessShow err
+
+      , P.onExit = \pid status ->
+        case status of
+          ExitSuccess ->
+            putLog' pid $ "exited"
+          ExitFailure code ->
+            putLog' pid $ "exited with code " <> red (blessShow code)
+
+      , P.onStart = \pid ->
+        putLog' pid "started"
+      }
+  where
+    putLog' pid s = putLog $ Plain name <> "[" <> blessShow pid <> "] " <> s