1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
{-# 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 Data.Int (Int32)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Maybe (fromMaybe)
import Data.Word (Word32)
import DBus
import DBus.Client
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
import System.Random
import Text.Read (readMaybe)
main :: IO ()
main =
bracket connectSession disconnect app
app :: Client -> IO ()
app client = do
(captureFinish, awaitCaptureFinish) <- newRelay
(daemonJoin, awaitDaemonJoin) <- newSemaphore
(daemonPart, awaitDaemonPart) <- newSemaphore
(daemonStop, awaitDaemonStop) <- newSemaphore
cGuiPath <- getEnv "FLAMESHOT_CAPTURE_PATH"
let
cLogTime = True
cLogHandle = stderr
cTimeout <-
let
def = 1000
err = error $ "failed to read integer from " <> var
var = "FLAMESHOT_ONCE_TIMEOUT"
in
(1000*) . maybe def (fromMaybe err . readMaybe) <$> lookupEnv var
hSetBuffering cLogHandle LineBuffering
logToTTY <- hIsTerminalDevice cLogHandle
(putLog0, takeLog) <- newChan
let
putLog1 = if cLogTime then (putLog0 =<<) . prefixTimestamp else putLog0
putLog2 = putLog1 . showUnprintable
putLog3 = if logToTTY then putLog2 else putLog2 . stripSGR
putLog = putLog3
_ <-
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.flameshot.Flameshot"))
, Variant (ValueAtom (AtomText _old_owner))
, Variant (ValueAtom (AtomText new_owner))
]
}
->
if new_owner /= ""
then daemonJoin
else daemonPart
Signal
{ signalPath = "/"
, signalInterface = "org.flameshot.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), Variant _geometry ] = rest
_sig ->
return ()
let
copyToClipboard mimetype input =
P.runAway "xclip" ["-selection", "clipboard", "-t", mimetype, "-i"]
Nothing Nothing input Nothing $
logger putLog "xclip"
runDaemon =
P.run "flameshot" [] Nothing Nothing "" Nothing $
logger putLog "daemon" <>
mempty
{ P.onError = \_ _ -> daemonStop
, P.onExit = \_ _ -> daemonStop
}
runLogPrinter =
forever $ takeLog >>= T.hPutStrLn stderr . pp
runWindowWaiter name onQuit = do
P.run "xwaitforwindow" ["-name", name] Nothing Nothing "" Nothing $
logger putLog ("xwaitforwindow(name=" <> T.pack (show name) <> ")") <>
mempty
{ P.onError = \_ _ -> onQuit
, P.onExit = \_ _ -> onQuit
}
waitForWindow name = do
(waiterStop, awaitWaiterStop) <- newSemaphore
withThread_ (runWindowWaiter name waiterStop) awaitWaiterStop
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 runDaemon $ \daemonThread -> do
withTimeout_ cTimeout awaitDaemonJoin "daemon" "join" $ do
callId <- getStdRandom random :: IO Word32
call client (methodCall "/" "" "graphicCapture")
{ methodCallDestination = Just "org.flameshot.Flameshot"
, methodCallInterface = Nothing
, methodCallBody =
[ toVariant cGuiPath
, toVariant (0 :: Int32)
, toVariant callId
]
} >>= \case
Right MethodReturn{} ->
awaitCaptureFinish >>= mapM_ (copyToClipboard "image/png")
Left err ->
putLog $ "capture failed: " <> blessMethodError err
-- sleep in order give the upload window a chance to appear
threadDelay cTimeout
waitForWindow "Upload to Imgur"
killThread daemonThread
withTimeout_ cTimeout awaitDaemonPart "daemon" "part" (return ())
withTimeout_ cTimeout awaitDaemonStop "daemon" "stop" (return ())
|
