diff options
Diffstat (limited to 'src/main.hs')
| -rw-r--r-- | src/main.hs | 102 |
1 files changed, 31 insertions, 71 deletions
diff --git a/src/main.hs b/src/main.hs index d45404f..133f51c 100644 --- a/src/main.hs +++ b/src/main.hs @@ -9,11 +9,11 @@ import Blessings.Text import Control.Concurrent.Extended import Control.Exception import Control.Monad -import qualified Data.Text.Extended as T +import Data.Int (Int32) import qualified Data.Text.IO as T +import Data.Word (Word32) import DBus import DBus.Client -import DBus.Socket import DBus.Internal.Message import DBus.Internal.Types import Flameshot.Internal @@ -21,30 +21,17 @@ import qualified Flameshot.Internal.Process as P --import System.Exit import System.Environment import System.IO +import System.Random 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 + bracket connectSession disconnect app + +app :: Client -> IO () +app client = do (captureFinish, awaitCaptureFinish) <- newRelay - (captureBegin, awaitCaptureBegin) <- newSemaphore - (daemonJoin, awaitDaemonJoin) <- newRelay + (daemonJoin, awaitDaemonJoin) <- newSemaphore (daemonPart, awaitDaemonPart) <- newSemaphore (daemonStop, awaitDaemonStop) <- newSemaphore @@ -79,7 +66,7 @@ app sock client = do } -> if new_owner /= "" - then daemonJoin (busName_ (T.unpack new_owner)) + then daemonJoin else daemonPart Signal @@ -106,19 +93,6 @@ app sock client = do _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 @@ -132,30 +106,6 @@ app sock client = do , 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 @@ -171,15 +121,25 @@ app sock client = do 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 ()) + withThread runDaemon $ \daemonThread -> do + withTimeout_ 100000 awaitDaemonJoin "daemon" "join" $ do + callId <- getStdRandom random :: IO Word32 + call client (methodCall "/" "" "graphicCapture") + { methodCallDestination = Just "org.dharkael.Flameshot" + , methodCallInterface = Nothing + , methodCallBody = + [ toVariant cGuiPath + , toVariant (0 :: Int32) + , toVariant callId + ] + } >>= \case + Right MethodReturn{} -> + awaitCaptureFinish >>= mapM_ (saveImage cGuiPath) + + Left err -> + putLog $ "capture failed: " <> blessMethodError err + + killThread daemonThread + + withTimeout_ 100000 awaitDaemonPart "daemon" "part" (return ()) + withTimeout_ 100000 awaitDaemonStop "daemon" "stop" (return ()) |