summaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Flameshot/Internal.hs27
-rw-r--r--src/main.hs102
2 files changed, 58 insertions, 71 deletions
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 ())