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