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
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Flameshot.Internal where
import Blessings.Text
import Control.Concurrent.Async (race)
import Control.Concurrent.Extended
import Control.Exception
import Data.ByteString (ByteString)
import qualified Data.Char as C
import Data.Function (on)
import Data.Maybe (fromMaybe)
import Data.Time.Clock.System
import Data.Time.ISO8601
import DBus
import DBus.Internal.Message
import DBus.Socket
import Data.Text (Text)
import qualified Data.Text.Extended as T
import qualified Flameshot.Internal.Process as P
import System.Exit
blessBusName :: BusName -> Blessings Text
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
blessTime :: Int -> Blessings Text
blessTime = Plain . (<>"μs") . T.show
red :: Blessings Text -> Blessings Text
red = SGR [31]
withThread :: IO () -> (ThreadId -> IO a) -> IO a
withThread tf wtf =
bracket (forkIO tf) killThread wtf
withThread_ :: IO () -> IO a -> IO a
withThread_ tf wtf =
bracket (forkIO tf) killThread (const wtf)
timeout :: Int -> IO a -> IO (Either Int a)
timeout time io =
race (threadDelay time) io >>= \case
Right x -> return (Right x)
Left () -> return (Left time)
dbusInterface :: InterfaceName
dbusInterface = "org.freedesktop.DBus"
withSocket :: Address -> (Socket -> IO a) -> IO a
withSocket addr = bracket (open addr) close
getTimestamp :: IO String
getTimestamp =
formatISO8601Micros . systemToUTCTime <$> getSystemTime
prefixTimestamp :: Blessings Text -> IO (Blessings Text)
prefixTimestamp s =
(<> s) . (<>" ") . SGR [38,5,239] . Plain . T.pack <$> getTimestamp
showUnprintable :: Blessings Text -> Blessings Text
showUnprintable =
fmap' showU
where
showU :: Text -> Blessings Text
showU =
mconcat
. map (either Plain (hi . Plain . showLitChars))
. toEither (not . C.isPrint)
-- like Blessings' fmap, but don't wrap the Plain case in another Plain
fmap' :: (Text -> Blessings Text) -> Blessings Text -> Blessings Text
fmap' f = \case
Append t1 t2 -> Append (fmap' f t1) (fmap' f t2)
Plain s -> f s
SGR pm t -> SGR pm (fmap' f t)
Empty -> Empty
hi = SGR [38,5,79]
showLitChars :: Text -> Text
showLitChars = T.concatMap (T.pack . flip C.showLitChar "")
toEither :: (Char -> Bool) -> Text -> [Either Text Text]
toEither p =
map (\s -> if p (T.head s) then Right s else Left s)
. T.groupBy ((==) `on` p)
copyToClipboard :: String -> ByteString -> IO ()
copyToClipboard mimetype =
P.writeDaemon "xclip" ["-selection", "clipboard", "-t", mimetype, "-i"]
logger :: (Blessings Text -> IO ()) -> Text -> P.Callbacks
logger putLog name =
P.Callbacks
{ P.onOutLine = \pid s ->
putLog' pid $ "stdout: " <> Plain s
, P.onErrLine = \pid s ->
putLog' pid $ "stderr: " <> red (Plain s)
, P.onError = \pid err ->
putLog' pid $ "error: " <> blessShow err
, P.onExit = \pid status ->
case status of
ExitSuccess ->
putLog' pid $ "exited"
ExitFailure code ->
putLog' pid $ "exited with code " <> red (blessShow code)
, P.onStart = \pid ->
putLog' pid "started"
}
where
putLog' pid s = putLog $ Plain name <> "[" <> blessShow pid <> "] " <> s
|
