{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Clipboard where import Protolude hiding ((<&>)) import Unsafe (unsafeIndex) import Graphics.X11.Xlib import Graphics.X11.Xlib.Extras import Control.Concurrent (threadDelay) import Data.Binary (Binary) import qualified Data.ByteString as B import Lens.Micro import System.Directory (setCurrentDirectory) import System.IO (hClose, stderr, stdin, stdout) import System.Posix.Process (forkProcess) import Data.ByteString (unpack) 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 , mimesPriorities :: [Atom] , defaultMime :: 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 [Atom] 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 return $ fromMaybe mempty ret2 where 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 targetMime = chooseSelectionType mimes xConvertSelection display clipboard targetMime 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 targetMime clipboardContent } where chooseSelectionType mimes = let selectedMime = msum $ (\mime -> find (== mime) mimes) <$> mimesPriorities in fromMaybe defaultMime selectedMime mimeToSelectionType mimeTarget selContent = if mimeTarget == unsafeIndex mimesPriorities 0 then PNG selContent else if mimeTarget == unsafeIndex mimesPriorities 1 then JPEG selContent else if mimeTarget == unsafeIndex mimesPriorities 2 then BITMAP selContent else UTF8 $ 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 priorities <- traverse (\atomName -> internAtom display atomName False) ["image/png", "image/jpeg", "image/bmp", "UTF8_STRING", "TEXT"] defaultM <- internAtom display "UTF8_STRING" False return XorgContext { display = display , ownWindow = window , defaultClipboard = clipboard , primaryClipboard = pRIMARY , selectionTarget = selTarget , mimesPriorities = priorities , defaultMime = defaultM } 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 when (ev_event_type ev /= selectionNotify && not (ev_event_type ev == propertyNotify && ev_atom ev == selectionTarget && ev_propstate ev == 1)) (go display' window evPtr) waitForEvents display' = do nbEvs <- pending display' when (nbEvs == 0) $ threadDelay _10ms >> waitForEvents display' _10ms = 10000 setClipboardSelection :: Selection -> IO () setClipboardSelection sel = void $ forkProcess $ do mapM_ hClose [stdin, stdout, stderr] setCurrentDirectory "/" bracket getXorgContext destroyXorgContext $ \ctx@XorgContext{..} -> do let clipboards = [defaultClipboard, primaryClipboard] mapM_ (\atom -> xSetSelectionOwner display atom ownWindow currentTime) clipboards advertiseSelection ctx sel return () 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 nextEvent display evPtr ev <- getEvent evPtr case ev of SelectionRequest {..} -> do target' <- getAtomName display ev_target 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 SelectionClear{..} -> go (filter (/= ev_selection) clipboards) evPtr _ -> go clipboards evPtr 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 byteStringToCUChars :: ByteString -> [CUChar] byteStringToCUChars = map fromIntegral . unpack