Main.app: call graphicCapture directlyv1.0.1

3 files changed, 62 insertions, 73 deletions

diff --git a/flameshot-once.cabal b/flameshot-once.cabal
index c38a65b..772c464 100644
--- a/flameshot-once.cabal
+++ b/flameshot-once.cabal
@@ -1,5 +1,5 @@
 name: flameshot-once
-version: 1.0.0
+version: 1.0.1
 license: MIT
 author: tv <tv@krebsco.de>
 maintainer: tv <tv@krebsco.de>
@@ -11,9 +11,11 @@ executable flameshot-once
     async,
     base,
     blessings,
+    bytestring,
     dbus,
-    process,
     iso8601-time,
+    process,
+    random,
     text,
     time,
     unagi-chan,
diff --git a/src/Flameshot/Internal.hs b/src/Flameshot/Internal.hs
index 28b33cf..56a35b4 100644
--- a/src/Flameshot/Internal.hs
+++ b/src/Flameshot/Internal.hs
@@ -9,11 +9,17 @@ import Blessings.Text
 import Control.Concurrent.Async (race)
 import Control.Concurrent.Extended
 import Control.Exception
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
 import qualified Data.Char as C
 import Data.Function (on)
+import Data.Maybe (fromMaybe)
+import Data.Time.Clock
 import Data.Time.Clock.System
+import Data.Time.Format
 import Data.Time.ISO8601
 import DBus
+import DBus.Internal.Message
 import DBus.Socket
 import Data.Text (Text)
 import qualified Data.Text.Extended as T
@@ -25,6 +31,14 @@ blessBusName = Plain . T.pack . formatBusName
 blessMemberName :: MemberName -> Blessings Text
 blessMemberName = Plain . T.pack . formatMemberName
 
+blessMethodError :: MethodError -> Blessings Text
+blessMethodError err@MethodError{..} =
+    red . Plain $ fromMaybe (T.show err) msg
+  where
+    msg = if length methodErrorBody > 0
+            then fromVariant (methodErrorBody !! 0)
+            else Nothing
+
 blessShow :: Show a => a -> Blessings Text
 blessShow = Plain . T.show
 
@@ -94,3 +108,16 @@ showUnprintable =
     toEither p =
       map (\s -> if p (T.head s) then Right s else Left s)
       . T.groupBy ((==) `on` p)
+
+
+saveImage :: FilePath -> ByteString -> IO ()
+saveImage cGuiPath rawImage = do
+    t <- formatISO8601Seconds . systemToUTCTime <$> getSystemTime
+    let path = cGuiPath <> "/" <> baseName
+        baseName = t <> "_flameshot.png"
+    BS.writeFile path rawImage
+
+
+formatISO8601Seconds :: UTCTime -> String
+formatISO8601Seconds =
+    formatTime defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%SZ")
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 ())