greenclip-3.2.0: src/Clipboard.hs
{-# 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