From fb5636483871fbafe9b286b377c339c8ddf8b4f8 Mon Sep 17 00:00:00 2001 From: tv Date: Thu, 7 Feb 2019 18:42:36 +0100 Subject: initial commit --- src/Flameshot/Internal.hs | 96 +++++++++++++++++++++++++++++++++++++++ src/Flameshot/Internal/Process.hs | 89 ++++++++++++++++++++++++++++++++++++ 2 files changed, 185 insertions(+) create mode 100644 src/Flameshot/Internal.hs create mode 100644 src/Flameshot/Internal/Process.hs (limited to 'src/Flameshot') 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 -- cgit v1.2.3