initial commitv1.0.0-rc1

2 files changed, 185 insertions, 0 deletions

diff --git a/src/Flameshot/Internal.hs b/src/Flameshot/Internal.hs
new file mode 100644
index 0000000..28b33cf
--- /dev/null
+++ b/src/Flameshot/Internal.hs
@@ -0,0 +1,96 @@
+{-# 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 qualified Data.Char as C
+import Data.Function (on)
+import Data.Time.Clock.System
+import Data.Time.ISO8601
+import DBus
+import DBus.Socket
+import Data.Text (Text)
+import qualified Data.Text.Extended as T
+
+
+blessBusName :: BusName -> Blessings Text
+blessBusName = Plain . T.pack . formatBusName
+
+blessMemberName :: MemberName -> Blessings Text
+blessMemberName = Plain . T.pack . formatMemberName
+
+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)
diff --git a/src/Flameshot/Internal/Process.hs b/src/Flameshot/Internal/Process.hs
new file mode 100644
index 0000000..c435d48
--- /dev/null
+++ b/src/Flameshot/Internal/Process.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Flameshot.Internal.Process (run,Callbacks(..)) where
+
+import Control.Concurrent (forkIO,threadDelay)
+import Control.Concurrent.Async (race)
+import Control.Exception
+import Control.Monad.Extended (untilM_,unless)
+import Data.Text (Text)
+import qualified Data.Text.IO as T
+import System.Exit
+import System.IO (BufferMode(LineBuffering),hSetBuffering)
+import System.IO (Handle,hClose,hPutStr,hIsEOF)
+import System.IO.Error (catchIOError,isDoesNotExistError)
+import System.Process
+import System.Posix.Process (getProcessGroupIDOf)
+import System.Posix.Signals (Signal,signalProcessGroup,killProcess)
+import System.Posix.Types (ProcessGroupID)
+
+data Callbacks = Callbacks
+    { onOutLine :: Pid -> Text -> IO ()
+    , onErrLine :: Pid -> Text -> IO ()
+    , onError :: Pid -> SomeException -> IO ()
+    , onExit :: Pid -> ExitCode -> IO ()
+    , onStart :: Pid -> IO ()
+    }
+
+run :: FilePath
+     -> [String]
+     -> Maybe FilePath
+     -> Maybe [(String, String)]
+     -> String
+     -> Maybe Int
+     -> Callbacks
+     -> IO ()
+run path args cwd env input hTimeout Callbacks{..} =
+    f `catch` onError (-1)
+  where
+    f = withCreateProcess p $ \(Just inh) (Just outh) (Just errh) ph -> do
+      Just pid <- getPid ph
+      pgid <- getProcessGroupIDOf pid
+
+      onStart pid
+
+      mapM_ forkIO [
+          hPutStr inh input `finally` hClose inh,
+          hWithLines outh (onOutLine pid),
+          hWithLines errh (onErrLine pid)
+        ]
+
+      case hTimeout of
+        Just time ->
+          race (threadDelay time) (waitForProcess ph) >>= \case
+            Left () -> onError pid (SomeException (ErrorCall "timeout"))
+            Right code -> onExit pid code
+        Nothing ->
+          waitForProcess ph >>= onExit pid
+
+      killProcessGroup pgid
+
+    p = (proc path args)
+          { cwd = cwd
+          , env = env
+          , std_in = CreatePipe
+          , std_out = CreatePipe
+          , std_err = CreatePipe
+          , close_fds = True
+          , create_group = True
+          , new_session = True
+          }
+
+
+
+killProcessGroup :: ProcessGroupID -> IO ()
+killProcessGroup = signalProcessGroup' killProcess
+
+signalProcessGroup' :: Signal -> ProcessGroupID -> IO ()
+signalProcessGroup' sig pgid =
+    catchIOError
+      (signalProcessGroup sig pgid)
+      (\e -> unless (isDoesNotExistError e) $ ioError e)
+
+hWithLines :: Handle -> (Text -> IO ()) -> IO ()
+hWithLines h f = do
+    hSetBuffering h LineBuffering
+    untilM_ (hIsEOF h) (T.hGetLine h >>= f) `finally` hClose h