greenclip 2.0.1 → 3.0.0
raw patch · 4 files changed
+479/−175 lines, 4 filesdep +bytestringdep +exceptionsdep +hashabledep −classy-preludedep −utf8-stringdep ~base
Dependencies added: bytestring, exceptions, hashable, protolude, wordexp
Dependencies removed: classy-prelude, utf8-string
Dependency ranges changed: base
Files
- README.md +49/−6
- greenclip.cabal +12/−7
- src/Clipboard.hs +254/−89
- src/Main.hs +164/−73
README.md view
@@ -11,36 +11,79 @@ Keeps track of your history of selections to quickly switch between them **Demo:** <a href="https://www.youtube.com/watch?v=Utk-9Gy8H3w">Video Link</a>+<br/>+<a href="https://www.youtube.com/watch?v=4IycORAdW9M">Video made by @gotbletu</a> **Features:** + Integrated with [rofi](https://github.com/DaveDavenport/rofi) + Permanently set some selections to added at the end (set `staticHistoryPath = your/file/with/static/entries` in the config file) + Merge X Primary selection with clipboard selection (set `usePrimarySelectionAsInput = True` in the config file) -**Installation:**+## Installation 1. It's a static binary so drop it anywhere in your $PATH env -```wget https://github.com/erebe/greenclip/releases/download/2.0/greenclip```+```wget https://github.com/erebe/greenclip/releases/download/3.0/greenclip``` Alternatively if you are using Archlinux you can install the package from AUR -``pacman -S greenclip``+``pacman -S rofi-greenclip`` PS: If you want, you can add a permanent list of selections to be added to your current history. Go see the config file -**Usage:**+## Usage Greenclip is intended to be used with [rofi](https://github.com/DaveDavenport/rofi) 1. Spawn the daemon ``` greenclip daemon ```-2. When ever you need to get your selections history ``` rofi -modi "clipboard:greenclip print" -show clipboard ```+2. When ever you need to get your selections history ``` rofi -modi "clipboard:greenclip print" -show clipboard -run-command '{cmd}' ``` 3. The entry that you have selected will be in your clipboard now 4. Configuration file can be found in ```.config/greenclip.cfg``` -**Compilation:**+## Migrating from 2.x version to 3.x one +1. Kill all greenclip process already running+2. Delete your old config file and old cache file (in ~/.cache/greenclip*)+3. Start the new version of greenclip++## Building the project+ 1. Get [stack](https://docs.haskellstack.org/en/stable/README/) for Haskell 2. stack init && stack install +or you can look at the .travis.yml file++## FAQ++Q. Greenclip does not copy selection !++A. Greenclip cannot run alongside other clipboard manager. If you have already one activated (there is one by default in KDE), you have first to disable it before trying to run greenclip++---------++Q. I cannot paste images !++A. You can only keep in your history small images (~ <500 kb). I disabled the support for bigger images as it will turn your CPU into a heater for winter.++----------++Q. I want to blacklist some applications !++A. There is in your config file a section for blacklisting applications.+ You can run greenclip daemon in a terminal to find what is the name of the application who has the current selection.+ Be aware that a lot of application does not name their clipboard process/window, so it will be empty most of the time.+ Be aware also, that if you use an electron application (like slack i.e) you will get a generic name like "Chromium clipboard"+ +----------++Q. I want to paste selection directly after selecting them !++A. This is not possible as when you invoke rofi, you lose focus of your current window and there is no way to find it back (from greenclip point of view)+ Nonetheless, you can emulate the feature with xdotool `rofi -modi "clipboard:greenclip print" -show clipboard -run-command '{cmd}' ; sleep 0.5; xdotool type (xclip -o -selection clipboard)`++----------++Q. I want to thank you for greenclip !++A. Give a star to this repository
greenclip.cabal view
@@ -1,11 +1,11 @@--- This file has been generated from package.yaml by hpack version 0.17.0.+-- This file has been generated from package.yaml by hpack version 0.18.1. -- -- see: https://github.com/sol/hpack name: greenclip-version: 2.0.1+version: 3.0.0 synopsis: Simple clipboard manager to be integrated with rofi-description: Please see README.md+description: Simple clipboard manager to be integrated with rofi - Please see README.md category: Linux Desktop homepage: https://github.com/erebe/greenclip#readme author: Erèbe - Romain GERARD@@ -25,18 +25,23 @@ src ghc-options: -Wall -O3 build-depends:- base >= 4.7 && < 5- , classy-prelude+ base >= 4 && < 5+ , protolude+ , exceptions+ , bytestring , text , vector+ , hashable , binary , microlens , microlens-mtl , directory- , X11 >= 1.6- , utf8-string , unix , directory+ , wordexp+ , X11 >= 1.6 other-modules: Clipboard default-language: Haskell2010+ default-extensions: Strict+ pkgconfig-depends: x11, xcb, xau, xdmcp
src/Clipboard.hs view
@@ -1,71 +1,244 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} -module Clipboard- ( getClipboardString- , setClipboardString- , getPrimaryClipboard- ) where+module Clipboard where -import Graphics.X11.Xlib-import Graphics.X11.Xlib.Extras-import System.Posix.Process (forkProcess)+import Protolude hiding ((<&>)) -import Codec.Binary.UTF8.String (decode, encode)-import Control.Monad-import Data.Maybe-import Foreign (peekByteOff)-import Foreign.C.Types (CChar, CUChar)-import Foreign.Marshal.Array (withArrayLen)-import System.Directory (setCurrentDirectory)-import System.IO (hClose, stderr, stdin, stdout)-import System.IO.Unsafe (unsafePerformIO)-import Data.IORef-import Control.Concurrent (threadDelay)+import Graphics.X11.Xlib+import Graphics.X11.Xlib.Extras -getClipboardString :: IO (Maybe String)-getClipboardString = do- (display, window, clipboards) <- readIORef initialSetup- inp <- internAtom display "clipboard_get" False- target <- internAtom display "UTF8_STRING" True- xConvertSelection display (head clipboards) target inp window currentTime- Just <$> clipboardInputWait display window inp+import Control.Concurrent (threadDelay)+import Data.Binary (Binary)+import qualified Data.ByteString as B+import Lens.Micro -getPrimaryClipboard :: IO (Maybe String)-getPrimaryClipboard = do- (display, window, clipboards) <- readIORef initialSetup- inp <- internAtom display "clipboard_get" False- target <- internAtom display "UTF8_STRING" True- xConvertSelection display (clipboards !! 1) target inp window currentTime- Just <$> clipboardInputWait display window inp+import System.Directory (setCurrentDirectory)+import System.IO (hClose, stderr, stdin, stdout)+import System.Posix.Process (forkProcess) -clipboardInputWait :: Display -> Window -> Atom -> IO String-clipboardInputWait display' window' inp' = allocaXEvent (go display' window' inp')+import Data.ByteString (unpack)+import qualified Data.Text as T+import Foreign (alloca, castPtr, peek, peekArray)+import Foreign.C.Types (CUChar)+import Foreign.Marshal.Array (withArrayLen)++data SelectionType = UTF8 Text+ | PNG ByteString+ | JPEG ByteString+ | BITMAP ByteString+ deriving (Show, Eq, Generic, Binary)++data Selection = Selection {+ appName :: Text+ , selection :: SelectionType+} deriving (Show, Eq, Generic, Binary)++data XorgContext = XorgContext {+ display :: Display+ , ownWindow :: Window+ , defaultClipboard :: Atom+ , primaryClipboard :: Atom+ , selectionTarget :: Atom+} deriving (Show)+++test :: IO ()+test =+ bracket getXorgContext destroyXorgContext $ \ctx -> do+ ret <- getPrimarySelection ctx+ print $! ret+ return ()++windowNameOfClipboardOwner :: XorgContext -> Atom -> IO Text+windowNameOfClipboardOwner XorgContext{..} clipboard = do++ window <- xGetSelectionOwner display clipboard++ if window > 0+ then fetchName display window <&> toS . fromMaybe mempty+ else return mempty+++isIncrementalTransfert :: XorgContext -> IO Bool+isIncrementalTransfert XorgContext{..} =+ alloca $ \actual_type_return ->+ alloca $ \actual_format_return ->+ alloca $ \nitems_return ->+ alloca $ \bytes_after_return ->+ alloca $ \prop_return -> do+ incr <- internAtom display "INCR" False+ ret <- xGetWindowProperty display ownWindow selectionTarget 0 0 False anyPropertyType+ actual_type_return+ actual_format_return+ nitems_return+ bytes_after_return+ prop_return++ if ret /= 0+ then return False+ else do+ actual_type <- peek actual_type_return <&> fromIntegral :: IO Atom+ _ <- peek prop_return >>= xFree+ return $ actual_type == incr++getSupportedMimes :: XorgContext -> Atom -> IO [Text]+getSupportedMimes ctx@XorgContext{..} clipboard =+ alloca $ \actual_type_return ->+ alloca $ \actual_format_return ->+ alloca $ \nitems_return ->+ alloca $ \bytes_after_return ->+ alloca $ \prop_return -> do+ targets <- internAtom display "TARGETS" False+ xConvertSelection display clipboard targets selectionTarget ownWindow currentTime+ _ <- waitNotify ctx+ ret <- xGetWindowProperty display ownWindow selectionTarget 0 0xFFFFFFFF False aTOM+ actual_type_return+ actual_format_return+ nitems_return+ bytes_after_return+ prop_return++ ret2 <- if ret /= 0+ then return Nothing+ else do+ prop_ptr <- peek prop_return+ actual_format <- peek actual_format_return <&> fromIntegral :: IO Atom+ nitems <- peek nitems_return <&> fromIntegral+ getprop prop_ptr nitems actual_format+ let atoms = filter (/= 0) $ fromMaybe mempty ret2+ fmap (fmap toS) (getAtomNames display atoms) where- go display window inp evPtr = do- waitForEvent display- nextEvent display evPtr+ getprop prop_ptr nitems actual_format+ | actual_format == 0 = return Nothing -- Property not found+ | otherwise = do+ retval <- peekArray nitems (castPtr prop_ptr)+ _ <- xFree prop_ptr+ return $ Just retval+++getClipboardSelection :: XorgContext -> IO (Maybe Selection)+getClipboardSelection ctx@XorgContext{..} =+ getSelection ctx defaultClipboard++getPrimarySelection :: XorgContext -> IO (Maybe Selection)+getPrimarySelection ctx@XorgContext{..} =+ getSelection ctx primaryClipboard++getSelection :: XorgContext -> Atom -> IO (Maybe Selection)+getSelection ctx@XorgContext{..} clipboard = do+ mimes <- getSupportedMimes ctx clipboard+ let selectedMime = chooseSelectionType mimes++ target <- internAtom display (toS selectedMime) True+ xConvertSelection display clipboard target selectionTarget ownWindow currentTime+ waitNotify ctx+ isIncremental <- isIncrementalTransfert ctx+ clipboardContent <- if isIncremental+ then return mempty -- Incremental use too much CPU, do not handle it+ else getWindowProperty8 display selectionTarget ownWindow+ <&> B.pack . map fromIntegral . fromMaybe mempty++ if clipboardContent == mempty+ then return Nothing+ else do+ windowName <- windowNameOfClipboardOwner ctx clipboard+ return $ Just Selection { appName = windowName+ , selection = mimeToSelectionType selectedMime clipboardContent+ }++ where+ priorities = ["image/png", "image/jpeg", "image/bmp", "UTF8_STRING", "TEXT"]++ chooseSelectionType mimes =+ let selectedMime = msum $ (\mime -> find (== mime) mimes) <$> priorities+ in fromMaybe "UTF8_STRING" selectedMime++ mimeToSelectionType "image/png" selContent = PNG selContent+ mimeToSelectionType "image/jpeg" selContent = JPEG selContent+ mimeToSelectionType "image/bmp" selContent = BITMAP selContent+ mimeToSelectionType _ selContent = UTF8 (T.strip $ toS selContent)++ -- getContentIncrementally acc = do+ -- _ <- xDeleteProperty display ownWindow selectionTarget+ -- flush display+ -- waitNotify ctx+ -- content <- getWindowProperty8 display selectionTarget ownWindow+ -- <&> B.pack . map fromIntegral . fromMaybe mempty+ -- if content == mempty+ -- then return acc+ -- else getContentIncrementally (acc <> content)+++getXorgContext :: IO XorgContext+getXorgContext = do+ display <- openDisplay mempty+ window <- createSimpleWindow display (defaultRootWindow display) 0 0 1 1 0 0 0+ -- selectInput display window propertyChangeMask++ clipboard <- internAtom display "CLIPBOARD" False+ selTarget <- internAtom display "GREENCLIP" False+ return XorgContext {+ display = display+ , ownWindow = window+ , defaultClipboard = clipboard+ , primaryClipboard = pRIMARY+ , selectionTarget = selTarget+ }++destroyXorgContext :: XorgContext -> IO ()+destroyXorgContext XorgContext{..} = do+ destroyWindow display ownWindow+ closeDisplay display++waitNotify :: XorgContext -> IO ()+waitNotify XorgContext{..} = allocaXEvent (go display ownWindow)+ where+ go display' window evPtr = do+ waitForEvents display'+ nextEvent display' evPtr ev <- getEvent evPtr- if ev_event_type ev == selectionNotify- then charsToString . fromMaybe mempty <$> getWindowProperty8 display inp window- else go display window inp evPtr- waitForEvent display = do- nbEvs <- pending display- when (nbEvs == 0) $ threadDelay 100000 >> waitForEvent display+ when (ev_event_type ev /= selectionNotify+ && not (ev_event_type ev == propertyNotify && ev_atom ev == selectionTarget && ev_propstate ev == 1))+ (go display' window evPtr) -charsToString :: [CChar] -> String-charsToString = decode . map fromIntegral+ waitForEvents display' = do+ nbEvs <- pending display'+ when (nbEvs == 0) $ threadDelay _10ms >> waitForEvents display' -setClipboardString :: String -> IO ()-setClipboardString str = void $ forkProcess $ do+ _10ms = 10000++++setClipboardSelection :: Selection -> IO ()+setClipboardSelection sel = void $ forkProcess $ do mapM_ hClose [stdin, stdout, stderr] setCurrentDirectory "/"- (display, window, clipboards) <- readIORef initialSetup- mapM_ (\atom -> xSetSelectionOwner display atom window currentTime) clipboards- advertiseSelection display clipboards (stringToChars str)- cleanup display window+ bracket getXorgContext destroyXorgContext $ \ctx@XorgContext{..} -> do+ let clipboards = [defaultClipboard, primaryClipboard]+ mapM_ (\atom -> xSetSelectionOwner display atom ownWindow currentTime) clipboards+ advertiseSelection ctx sel+ return () -advertiseSelection :: Display -> [Atom] -> [CUChar] -> IO ()-advertiseSelection display clipboards' str = allocaXEvent (go clipboards')++selectionTypeToMime :: SelectionType -> ByteString+selectionTypeToMime (PNG _) = "image/png"+selectionTypeToMime (JPEG _) = "image/jpeg"+selectionTypeToMime (BITMAP _) = "image/bmp"+selectionTypeToMime (UTF8 _) = "UTF8_STRING"++getContent :: SelectionType -> ByteString+getContent (PNG bytes) = bytes+getContent (JPEG bytes) = bytes+getContent (BITMAP bytes) = bytes+getContent (UTF8 txt) = toS txt++advertiseSelection :: XorgContext -> Selection -> IO ()+advertiseSelection ctx@XorgContext{..} sel = allocaXEvent (go [defaultClipboard, primaryClipboard]) where go [] _ = return () go clipboards evPtr = do@@ -74,46 +247,38 @@ case ev of SelectionRequest {..} -> do target' <- getAtomName display ev_target- res <- handleOutput display ev_requestor ev_property target' str- sendSelectionNotify display ev_requestor ev_selection ev_target res ev_time+ response <- case target' of+ Nothing -> return none+ Just atomName -> handleRequest ctx (selection sel) ev_requestor ev_property (toS atomName)++ sendSelectionNotify display ev_requestor ev_selection ev_target response ev_time go clipboards evPtr - _ | ev_event_type ev == selectionClear -> do- target <- peekByteOff evPtr 40 :: IO Atom- go (filter (/= target) clipboards) evPtr+ SelectionClear{..} -> go (filter (/= ev_selection) clipboards) evPtr _ -> go clipboards evPtr -handleOutput :: Display -> Window -> Atom -> Maybe String -> [CUChar] -> IO Atom-handleOutput display req prop (Just "UTF8_STRING") str = do- prop' <- getAtomName display prop- if isNothing prop' then handleOutput display req prop Nothing str else do- target <- internAtom display "UTF8_STRING" True- void $ withArrayLen str $ \len str' ->- xChangeProperty display req prop target 8 propModeReplace str'- (fromIntegral len)- return prop-handleOutput _ _ _ _ _ = return none+handleRequest :: XorgContext -> SelectionType -> Window -> Atom -> Text -> IO Atom+handleRequest XorgContext{..} sel requestorWindow selection "TARGETS" = do+ targets <- internAtom display "TARGETS" True+ target <- internAtom display (toS $ selectionTypeToMime sel) True+ changeProperty32 display requestorWindow selection aTOM propModeReplace [fromIntegral targets, fromIntegral target]+ return selection +handleRequest XorgContext{..} sel req prop targetStr =+ if targetStr == toS (selectionTypeToMime sel)+ then do+ target <- internAtom display (toS targetStr) True+ void $ withArrayLen (byteStringToCUChars $ getContent sel) $ \len bytes ->+ xChangeProperty display req prop target 8 propModeReplace bytes (fromIntegral len)+ return prop+ else return none+ sendSelectionNotify :: Display -> Window -> Atom -> Atom -> Atom -> Time -> IO () sendSelectionNotify display req sel target prop time = allocaXEvent $ \ev -> do- setEventType ev selectionNotify- setSelectionNotify ev req sel target prop time- sendEvent display req False 0 ev--stringToChars :: String -> [CUChar]-stringToChars = map fromIntegral . encode--initialSetup :: IORef (Display, Window, [Atom])-initialSetup = unsafePerformIO $ do- display <- openDisplay ""- window <- createSimpleWindow display (defaultRootWindow display)- 0 0 1 1 0 0 0- clipboards <- internAtom display "CLIPBOARD" False- newIORef (display, window, [clipboards, pRIMARY])-{-# NOINLINE initialSetup #-}+ setEventType ev selectionNotify+ setSelectionNotify ev req sel target prop time+ sendEvent display req False 0 ev -cleanup :: Display -> Window -> IO ()-cleanup display window = do- destroyWindow display window- closeDisplay display+byteStringToCUChars :: ByteString -> [CUChar]+byteStringToCUChars = map fromIntegral . unpack
src/Main.hs view
@@ -1,139 +1,230 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} + module Main where -import ClassyPrelude as CP hiding (readFile)-import Data.Binary (decode, encode)-import qualified Data.Text as T-import qualified Data.Vector as V+import Protolude hiding (readFile, to, (<&>), (&))++import Control.Monad.Catch (MonadCatch, catchAll)+import Data.Binary (decode, encode)+import qualified Data.ByteString as B+import Data.Hashable (hash)+import qualified Data.Text as T+import Data.Vector (Vector)+import qualified Data.Vector as V import Lens.Micro import Lens.Micro.Mtl-import qualified Clipboard as Clip-import qualified System.Directory as Dir-import System.Environment (lookupEnv)-import System.IO (IOMode (..), openFile)-import System.Timeout (timeout)+import qualified System.Directory as Dir+import System.Environment (lookupEnv)+import System.IO (IOMode (..), hClose, hGetContents,+ openFile)+import System.Timeout (timeout)+import System.Wordexp.Simple (wordexp) +import qualified Clipboard as Clip + data Command = DAEMON | PRINT | COPY Text | CLEAR | HELP deriving (Show, Read) data Config = Config { maxHistoryLength :: Int- , historyPath :: String- , staticHistoryPath :: String+ , historyPath :: Text+ , staticHistoryPath :: Text+ , imageCachePath :: Text , usePrimarySelectionAsInput :: Bool+ , blacklistedApps :: [Text] } deriving (Show, Read) -type ClipHistory = Vector Text+type ClipHistory = Vector Clip.Selection readFile :: FilePath -> IO ByteString readFile filepath = bracket (openFile filepath ReadMode) hClose $ \h -> do str <- hGetContents h- let !str' = str- return str'+ return $! toS str getHistory :: (MonadIO m, MonadReader Config m) => m ClipHistory getHistory = do- storePath <- view (to historyPath)- liftIO $ readH storePath `catchAnyDeep` const mempty+ storePath <- view $ to (toS . historyPath)+ liftIO $ readH storePath `catchAll` const mempty where- readH filePath = readFile filePath <&> fromList . decode . fromStrict+ readH filePath = B.readFile filePath <&> V.fromList . decode . toS + getStaticHistory :: (MonadIO m, MonadReader Config m) => m ClipHistory getStaticHistory = do- storePath <- view (to staticHistoryPath)- liftIO $ readH storePath `catchAnyDeep` const mempty+ storePath <- view $ to (toS . staticHistoryPath)+ liftIO $ readH storePath `catchAll` const mempty where- readH filePath = readFile filePath <&> fromList . T.lines . decodeUtf8+ readH filePath = readFile filePath <&> V.fromList . fmap toSelection . T.lines . toS+ toSelection txt = Clip.Selection "greenclip" (Clip.UTF8 txt) storeHistory :: (MonadIO m, MonadReader Config m) => ClipHistory -> m () storeHistory history = do- storePath <- view (to historyPath)- liftIO $ writeH storePath history `catchAnyDeep` const mempty+ storePath <- view $ to (toS . historyPath)+ liftIO $ writeH storePath history where- writeH storePath = writeFile storePath . toStrict . encode . toList+ writeH storePath = B.writeFile storePath . toS . encode . V.toList -appendToHistory :: (MonadIO m, MonadReader Config m) => Text -> ClipHistory -> m ClipHistory-appendToHistory sel history =- let selection = T.strip sel in- if selection == mempty || selection == fromMaybe mempty (headMay history)- then return history- else do- maxLen <- view (to maxHistoryLength)- return $ fst . V.splitAt maxLen . cons selection $ filter (/= selection) history +appendToHistory :: (MonadIO m, MonadReader Config m) => Clip.Selection -> ClipHistory -> m (ClipHistory, ClipHistory)+appendToHistory sel history' =+ case sel of+ Clip.Selection _ (Clip.UTF8 _) -> appendGeneric sel history'+ Clip.Selection _ (Clip.PNG bytes) -> appendImage Clip.PNG ".png" bytes+ Clip.Selection _ (Clip.JPEG bytes) -> appendImage Clip.JPEG ".jpeg" bytes+ Clip.Selection _ (Clip.BITMAP bytes) -> appendImage Clip.BITMAP ".bmp" bytes -runDaemon :: (MonadIO m, MonadReader Config m, MonadCatch m) => m ()-runDaemon = do- usePrimary <- view (to usePrimarySelectionAsInput)- let getSelections = (getSelectionFrom Clip.getClipboardString, mempty)- : [(getSelectionFrom Clip.getPrimaryClipboard, mempty) | usePrimary]- forever $ (getHistory >>= go getSelections) `catchAnyDeep` handleError+ where+ appendImage imgCtr extension bytes = do+ cachePth <- view (to imageCachePath)+ let imgHash = show $ hash bytes+ let imgPath = toS $ cachePth <> imgHash <> extension+ _ <- liftIO $ writeImage imgPath bytes+ appendGeneric (sel {Clip.selection = imgCtr $ toS imgHash}) history' + writeImage path bytes = do+ fileExist <- Dir.doesFileExist path+ if fileExist+ then return False+ else B.writeFile path bytes >> return True++ appendGeneric selection history =+ if maybe False (\sel' -> Clip.selection sel' == Clip.selection selection) (history V.!? 0)+ then return (history, mempty)+ else do+ maxLen <- view $ to maxHistoryLength+ return $ V.splitAt maxLen . V.cons selection $ V.filter (\ori -> Clip.selection ori /= Clip.selection selection) history++runDaemon:: (MonadIO m, MonadCatch m, MonadReader Config m) => m ()+runDaemon = forever $ go `catchAll` handleError where _0_5sec :: Int- _0_5sec = 5 * 10^(5::Int)+ _0_5sec = 5 * 100000 - getSelection [] = return ([], mempty)+ _5sec :: Int+ _5sec = 5000000++ go = do+ history <- getHistory+ usePrimary <- view $ to usePrimarySelectionAsInput+ cfg <- ask++ liftIO $ bracket Clip.getXorgContext Clip.destroyXorgContext $ \x11Context -> do+ let getSelections = (getSelectionFrom (Clip.getClipboardSelection x11Context), Nothing)+ : [(getSelectionFrom (Clip.getPrimarySelection x11Context), Nothing) | usePrimary]+ void $ runReaderT (innerloop getSelections history) cfg++ getSelection [] = return ([], Nothing) getSelection ((getSel, lastSel):getSels) = do selection <- liftIO getSel- if selection /= lastSel+ if fmap Clip.selection selection /= fmap Clip.selection lastSel then return ((getSel, selection) : getSels, selection)- else getSelection getSels >>= \(e, selection) -> return ((getSel, lastSel) : e, selection)+ else getSelection getSels >>= \(e, sel) -> return ((getSel, lastSel) : e, sel) - go getSelections history = do- (getSelections', selection) <- liftIO $ getSelection getSelections- history' <- appendToHistory selection history- when (history' /= history) (storeHistory history')+ innerloop :: (MonadIO m, MonadReader Config m) => [(IO (Maybe Clip.Selection), Maybe Clip.Selection)] -> ClipHistory -> m ClipHistory+ innerloop getSelections history = do+ -- Get selection from enabled clipboards+ (getSelections', sel) <- liftIO $ getSelection getSelections + -- Do not use selection coming from blacklisted app+ liftIO $ when (isJust sel) (print (Clip.appName <$> sel))+ blacklist <- view (to blacklistedApps)+ let selection = sel >>= \s -> if isJust $ find (== Clip.appName s) blacklist+ then Nothing+ else Just s++ -- Append current selection to history and get back entries needed to be purged+ (history', toBePurged) <- maybe (return (history, mempty)) (`appendToHistory` history) selection+ traverse_ purgeSelection toBePurged++ -- backup on disk history if it as changed seen last backup+ when (isJust selection && history' /= history) (storeHistory history')++ -- Getting some rest liftIO $ threadDelay _0_5sec- go getSelections' history'+ innerloop getSelections' history' - getSelectionFrom fn = timeout 1000000 fn <&> T.pack . fromMaybe mempty . join+ getSelectionFrom :: IO (Maybe Clip.Selection) -> IO (Maybe Clip.Selection)+ getSelectionFrom = fmap join . timeout _5sec + purgeSelection (Clip.Selection _ (Clip.PNG txt)) = purge (toS txt <> ".png")+ purgeSelection (Clip.Selection _ (Clip.JPEG txt)) = purge (toS txt <> ".jpeg")+ purgeSelection (Clip.Selection _ (Clip.BITMAP txt)) = purge (toS txt <> ".bmp")+ purgeSelection _ = return ()++ purge path = do+ cachePth <- view (to imageCachePath)+ liftIO $ Dir.removeFile (toS $ cachePth <> "/" <> path) `catchAll` const mempty+ handleError ex = do- let displayMissing = "openDisplay" `T.isInfixOf` tshow ex+ let displayMissing = "openDisplay" `T.isInfixOf` show ex if displayMissing- then error "X display not available. Please start Xorg before running greenclip"- else sayErrShow ex+ then panic "X display not available. Please start Xorg before running greenclip"+ else print ex+ liftIO $ threadDelay _0_5sec -toRofiStr :: Text -> Text-toRofiStr = T.map (\c -> if c == '\n' || c == '\r' then '\xA0' else c)+toRofiStr :: Clip.Selection -> Text+toRofiStr (Clip.Selection _ (Clip.UTF8 txt)) = T.map (\c -> if c == '\n' || c == '\r' then '\xA0' else c) txt+toRofiStr (Clip.Selection appName (Clip.PNG txt)) = "image/png " <> appName <> " " <> toS txt+toRofiStr (Clip.Selection appName (Clip.JPEG txt)) = "image/jpeg " <> appName <> " " <> toS txt+toRofiStr (Clip.Selection appName (Clip.BITMAP txt)) = "image/bmp " <> appName <> " " <> toS txt -fromRofiStr :: Text -> Text-fromRofiStr = T.map (\c -> if c == '\xA0' then '\n' else c)+fromRofiStr :: Text -> Text -> IO Clip.Selection+fromRofiStr cachePth txt@(T.isPrefixOf "image/png " -> True) = B.readFile (toS $ cachePth <> getHash txt <> ".png") <&> Clip.Selection "greenclip" . Clip.PNG+fromRofiStr cachePth txt@(T.isPrefixOf "image/jpeg " -> True) = B.readFile (toS $ cachePth <> getHash txt <> ".jpeg") <&> Clip.Selection "greenclip" . Clip.JPEG+fromRofiStr cachePth txt@(T.isPrefixOf "image/bmp " -> True) = B.readFile (toS $ cachePth <> getHash txt <> ".bmp") <&> Clip.Selection "greenclip" . Clip.BITMAP+fromRofiStr _ txt = return $ Clip.Selection "greenclip" (Clip.UTF8 (T.map (\c -> if c == '\xA0' then '\n' else c) txt)) +getHash :: Text -> Text+getHash = fromMaybe mempty . lastMay . T.split (== ' ')++ printHistoryForRofi :: (MonadIO m, MonadReader Config m) => m () printHistoryForRofi = do history <- mappend <$> getHistory <*> getStaticHistory _ <- traverse (putStrLn . toRofiStr) history return () -advertiseSelection :: Text -> IO ()-advertiseSelection = Clip.setClipboardString . T.unpack . fromRofiStr +advertiseSelection :: (MonadIO m, MonadReader Config m) => Text -> m ()+advertiseSelection txt = do+ cachePth <- view (to imageCachePath)+ selection <- liftIO $ fromRofiStr cachePth txt+ liftIO $ Clip.setClipboardSelection selection++ getConfig :: IO Config getConfig = do home <- Dir.getHomeDirectory- let cfgPath = home </> ".config/greenclip.cfg"+ let cfgPath = home <> "/.config/greenclip.cfg" - cfgStr <- (readFile cfgPath <&> T.strip . decodeUtf8) `catchAnyDeep` const mempty- let cfg = fromMaybe (defaultConfig home) (readMay cfgStr)+ cfgStr <- readFile cfgPath `catchAll` const mempty+ let unprettyCfg = cfgStr & T.strip . T.replace "\n" "" . toS+ let cfg = fromMaybe defaultConfig (readMaybe $ toS unprettyCfg)+ let prettyCfg = show cfg & T.replace "," ",\n" . T.replace "{" "{\n " . T.replace "}" "\n}"+ writeFile cfgPath prettyCfg - writeFile cfgPath (fromString $ show cfg)- return cfg+ historyPath' <- expandHomeDir $ cfg ^. to historyPath+ staticHistoryPath' <- expandHomeDir $ cfg ^. to staticHistoryPath+ imageCachePath' <- expandHomeDir $ cfg ^. to imageCachePath + return $ cfg { historyPath = historyPath'+ , staticHistoryPath = staticHistoryPath'+ , imageCachePath = imageCachePath'+ }+ where- defaultConfig home = Config 25 (home </> ".cache/greenclip.history") (home </> ".cache/greenclip.staticHistory") False+ defaultConfig = Config 50 "~/.cache/greenclip.history" "~/.cache/greenclip.staticHistory" "/tmp/" False []+ expandHomeDir str = (toS . fromMaybe (toS str) . listToMaybe <$> wordexp (toS str)) `catchAll` (\_ -> return $ toS str) parseArgs :: [Text] -> Command@@ -152,17 +243,17 @@ CLEAR -> runReaderT (storeHistory mempty) cfg -- Should rename COPY into ADVERTISE but as greenclip is already used I don't want to break configs -- of other people- COPY sel -> advertiseSelection sel- HELP -> putStrLn $ "greenclip v2.0 -- Recyle your clipboard selections\n\n" <>- "Available commands\n" <>- "daemon: Spawn the daemon that will listen to selections\n" <>- "print: Display all selections history\n" <>- "clear: Clear history\n" <>- "help: Display this message\n"+ COPY sel -> runReaderT (advertiseSelection sel) cfg+ HELP -> putText $ "greenclip v3.0 -- Recyle your clipboard selections\n\n" <>+ "Available commands\n" <>+ "daemon: Spawn the daemon that will listen to selections\n" <>+ "print: Display all selections history\n" <>+ "clear: Clear history\n" <>+ "help: Display this message\n" main :: IO () main = do displayPresent <- lookupEnv "DISPLAY" case displayPresent of- Nothing -> putStrLn "X display not available. Please start Xorg before running greenclip"- _ -> getArgs >>= run .parseArgs+ Nothing -> putText "X display not available. Please start Xorg before running greenclip"+ _ -> getArgs >>= run . parseArgs . fmap toS