diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Flameshot/Internal.hs | 27 | ||||
| -rw-r--r-- | src/main.hs | 102 |
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 ()) |