summaryrefslogtreecommitdiffstats
path: root/src/Flameshot/Internal.hs
blob: fc561fe6a9986e4cb904708f88dd82fcca2bc5ae (plain)
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