diff options
Diffstat (limited to 'src/main.hs')
| -rw-r--r-- | src/main.hs | 185 |
1 files changed, 185 insertions, 0 deletions
diff --git a/src/main.hs b/src/main.hs new file mode 100644 index 0000000..d45404f --- /dev/null +++ b/src/main.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Main (main) where + +import Blessings.Text +import Control.Concurrent.Extended +import Control.Exception +import Control.Monad +import qualified Data.Text.Extended as T +import qualified Data.Text.IO as T +import DBus +import DBus.Client +import DBus.Socket +import DBus.Internal.Message +import DBus.Internal.Types +import Flameshot.Internal +import qualified Flameshot.Internal.Process as P +--import System.Exit +import System.Environment +import System.IO + + +main :: IO () +main = + getSessionAddress >>= \case + Just addr -> + withSocket addr $ \sock -> do + send sock (methodCall dbusPath dbusInterface "Hello") + { methodCallDestination = Just "org.freedesktop.DBus" + } (\_ser -> return ()) + _ <- receive sock + bracket connectSession disconnect (app sock) + Nothing -> + error + (mconcat + [ "DBus session bus address not found; " + , "is DBUS_SESSION_BUS_ADDRESS set properly?" + ]) + +app :: Socket -> Client -> IO () +app sock client = do + (captureFinish, awaitCaptureFinish) <- newRelay + (captureBegin, awaitCaptureBegin) <- newSemaphore + (daemonJoin, awaitDaemonJoin) <- newRelay + (daemonPart, awaitDaemonPart) <- newSemaphore + (daemonStop, awaitDaemonStop) <- newSemaphore + + cGuiPath <- getEnv "FLAMESHOT_CAPTURE_PATH" + let + cLogTime = True + cLogHandle = stderr + + hSetBuffering cLogHandle LineBuffering + logToTTY <- hIsTerminalDevice cLogHandle + (putLog, takeLog0) <- newChan + + let + takeLog1 = if cLogTime then takeLog0 >>= prefixTimestamp else takeLog0 + takeLog2 = showUnprintable <$> takeLog1 + takeLog3 = if logToTTY then takeLog2 else stripSGR <$> takeLog2 + takeLog = takeLog3 + + _ <- + addMatch client matchAny $ \case + Signal + { signalPath = "/org/freedesktop/DBus" + , signalInterface = "org.freedesktop.DBus" + , signalMember = "NameOwnerChanged" + , signalSender = Just "org.freedesktop.DBus" + , signalDestination = Nothing + , signalBody = + [ Variant (ValueAtom (AtomText "org.dharkael.Flameshot")) + , Variant (ValueAtom (AtomText _old_owner)) + , Variant (ValueAtom (AtomText new_owner)) + ] + } + -> + if new_owner /= "" + then daemonJoin (busName_ (T.unpack new_owner)) + else daemonPart + + Signal + { signalPath = "/" + , signalInterface = "org.dharkael.Flameshot" + , signalDestination = Nothing + , signalBody = Variant (ValueAtom (AtomWord32 _callId)) : rest + , .. + } + -> + case signalMember of + "captureTaken" -> do + captureFinish (Just rawImage) + + "captureFailed" -> do + captureFinish Nothing + + _other -> do + captureFinish Nothing + + where + [Variant (ValueBytes rawImage)] = rest + + _sig -> + return () + + send sock (methodCall dbusPath dbusInterface "AddMatch") + { methodCallDestination = Just "org.freedesktop.DBus" + , methodCallBody = + [ toVariant (T.intercalate "," + [ "type='method_call'" + , "eavesdrop=true" + , "path=/" + , "destination=org.dharkael.Flameshot" + , "member=graphicCapture" + ] ) + ] + } (\_ser -> return ()) + + let + runDaemon = + P.run "flameshot" [] Nothing Nothing "" Nothing P.Callbacks + { P.onOutLine = \_ s -> putLog $ "daemon stdout: " <> Plain s + , P.onErrLine = \_ s -> putLog $ "daemon stderr: " <> red (Plain s) + , P.onError = \_ _err -> do + daemonStop + + , P.onExit = \_ _status -> do + daemonStop + + , P.onStart = \_ -> return () + } + runGui = + P.run "flameshot" ["gui", "-p", cGuiPath] Nothing Nothing "" Nothing P.Callbacks + { P.onOutLine = \_ s -> putLog $ "gui stdout: " <> Plain s + , P.onErrLine = \_ s -> putLog $ "gui stderr: " <> red (Plain s) + , P.onError = \_ _err -> return () + , P.onExit = \_ _ -> return () + , P.onStart = \_ -> return () + } + runReceiver = + forever $ receive sock >>= \case + ReceivedMethodCall _ser MethodCall + { methodCallSender = Just _sender + , methodCallBody = + [ Variant (ValueAtom (AtomText _path)) + , Variant (ValueAtom (AtomInt32 _delay)) + , Variant (ValueAtom (AtomWord32 _callId)) + ] + } + -> do + captureBegin + + _received -> + return () + + runLogPrinter = + forever $ takeLog >>= T.hPutStrLn stderr . pp + + let + withTimeout time f s v io = + timeout time f >>= \case + Right x -> + io x + Left _time -> + putLog (s <> " " <> v <> " timeout after " <> blessTime time) + + withTimeout_ time f s v io = + withTimeout time f s v (const io) + + withThread_ runLogPrinter $ do + withThread_ runReceiver $ do + withThread runDaemon $ \daemonThread -> do + withTimeout 100000 awaitDaemonJoin "daemon" "join" $ \_daemonBusName -> do + withThread_ runGui $ do + withTimeout_ 100000 awaitCaptureBegin "gui" "join" $ do + _maybeRawImage <- awaitCaptureFinish + return () + + killThread daemonThread + + withTimeout_ 100000 awaitDaemonPart "daemon" "part" (return ()) + withTimeout_ 100000 awaitDaemonStop "daemon" "stop" (return ()) |