{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Clipboard where import Protolude hiding ((<&>)) import Protolude.Unsafe (unsafeIndex) import qualified Protolude.Conv as StrConvOld import Graphics.X11.Xlib import Graphics.X11.Xlib.Extras import Data.Binary (Binary) import qualified Data.ByteString as B import qualified Data.Text as T import Lens.Micro import System.Directory (setCurrentDirectory) import System.IO (hClose) 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) selectionLength :: Selection -> Int selectionLength (Selection _ (UTF8 a)) = T.length a selectionLength (Selection _ (PNG a)) = B.length a selectionLength (Selection _ (JPEG a)) = B.length a selectionLength (Selection _ (BITMAP a)) = B.length a 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 True 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 -> Bool -> IO (Maybe Selection) getClipboardSelection ctx@XorgContext{..} enableImage = getSelection ctx enableImage defaultClipboard getPrimarySelection :: XorgContext -> Bool -> IO (Maybe Selection) getPrimarySelection ctx@XorgContext{..} enableImage = getSelection ctx enableImage primaryClipboard getSelection :: XorgContext -> Bool -> Atom -> IO (Maybe Selection) getSelection ctx@XorgContext{..} enableImage clipboard = do mimes <- if enableImage then getSupportedMimes ctx clipboard else return [defaultMime] 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 $ decodeUtf8 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) = encodeUtf8 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 (StrConvOld.toS $ selectionTypeToMime sel) True changeProperty32 display requestorWindow selection aTOM propModeReplace [fromIntegral targets, fromIntegral target] return selection handleRequest XorgContext{..} sel req prop targetStr = if targetStr == decodeUtf8 (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