diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Ilya Portnov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ilya Portnov nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Wacom/CLI.hs b/System/Wacom/CLI.hs new file mode 100644 --- /dev/null +++ b/System/Wacom/CLI.hs @@ -0,0 +1,57 @@ + +module System.Wacom.CLI where + +import System.Wacom.Types +import System.Wacom.Profiles + +-- | Supported commands +data Command = + Quit -- ^ quit + | SetProfile String -- ^ set name + | GetCurrentProfile -- ^ get + | SetRingMode Int -- ^ ring 1 + | ToggleRingMode -- ^ ring + + | GetRingMode -- ^ ring + | Map Int -- ^ map 0 + | GetMap -- ^ map + deriving (Eq, Show) + +-- | Implementation of command-line utility to control the daemon. +client :: WacomHandle -> IO () +client wh = do + cmd <- readCommand + rs <- run cmd + case rs of + Left err -> putStrLn $ "Error: " ++ err + Right r -> putStrLn $ "Done: " ++ r + case cmd of + Quit -> putStrLn "Client quit" + _ -> client wh + where + readCommand :: IO Command + readCommand = do + putStr "client> " + str <- getLine + case words str of + ["quit"] -> return Quit + ["set",profile] -> return $ SetProfile profile + ["get"] -> return GetCurrentProfile + ["ring"] -> return GetRingMode + ["ring","+"] -> return ToggleRingMode + ["ring",s] -> return $ SetRingMode (read s) + ["map"] -> return GetMap + ["map",s] -> return $ Map (read s) + _ -> do + putStrLn "Unknown command" + readCommand + + run :: Command -> IO (Result String) + run Quit = return $ Right "Quit" + run (SetProfile name) = setProfile wh name + run GetCurrentProfile = getProfileName wh + run GetRingMode = getRingMode wh + run (SetRingMode idx) = setRingMode wh idx + run ToggleRingMode = toggleRingMode wh + run GetMap = getMapArea wh + run (Map idx) = setMapArea wh idx + diff --git a/System/Wacom/Config.hs b/System/Wacom/Config.hs new file mode 100644 --- /dev/null +++ b/System/Wacom/Config.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances #-} + +module System.Wacom.Config + ( + Config (..), + Profile (..), + RingMode (..), + TabletAction (..), + Area, + dfltConfig, + buildProfiles + ) + where + +import Control.Applicative +import Data.Char (isDigit) +import qualified Data.Map as M +import qualified Data.HashMap.Strict as H +import Data.Aeson.Types (typeMismatch) +import Data.Yaml +import qualified Data.Text as T + +-- | Tablet configuration +data Config = Config { + tStylusKey :: String -- ^ Keyword to be used to detect Wacom Stylus device name. Default is @Pen@. + , tPadKey :: String -- ^ Keyword to be used to detect Wacom Pad device name. Default is @Pad@. + , tTouchKey :: String -- ^ Keyword to be used to detect Wacom Touch device name. Default is @Touch@. + , tTouch :: Bool -- ^ Whether to enable touchpad functionality (if supported by tablet). + , tMapAreas :: [Area] -- ^ List of predefined tablet mapping areas (for example, different monitors). + -- Specified in X11 Geometry format, for example @1920x1200+0+0@. + , tProfiles :: [(String, Profile)] -- ^ Map of named settings profiles. + } + deriving (Show) + +instance FromJSON Config where + parseJSON (Object v) = + Config + <$> v .:? "stylus-device-key" .!= "Pen" + <*> v .:? "pad-device-key" .!= "Pad" + <*> v .:? "touch-device-key" .!= "Touch" + <*> v .:? "enable-touch" .!= False + <*> v .:? "mapping-areas" .!= [] + <*> (buildProfiles <$> (v .: "profiles")) + parseJSON invalid = typeMismatch "Config" invalid + +type Area = String + +-- | Tablet settings profile +data Profile = Profile { + pName :: String -- ^ Profile name + , pRing :: [RingMode] -- ^ Ring modes (for Intuos Pro models) + , pButtons :: M.Map Int TabletAction -- ^ Tablet buttons bindings + } + deriving (Show) + +instance FromJSON (M.Map Int TabletAction) where + parseJSON (Object v) = do + let lst = H.toList v + lst' <- mapM go lst + return $ M.fromList lst' + where + go (key,val) = do + let keyStr = T.unpack key + keyInt <- if all isDigit keyStr + then return $ read keyStr + else fail $ "Invalid button number " ++ keyStr + val' <- parseJSON val + return (keyInt, val') + + +instance FromJSON Profile where + parseJSON (Object v) = + Profile + <$> v .: "name" + <*> v .:? "ring" .!= [] + <*> v .:? "buttons" .!= M.empty + parseJSON invalid = typeMismatch "Profile" invalid + +-- | Intuos Pro ring mode +data RingMode = RingMode { + rName :: String -- ^ Mode name + , ringUp :: TabletAction -- ^ Action to be toggled at scrolling ring counterclockwise + , ringDown :: TabletAction -- ^ Action to be toggled at scrolling ring clockwise + } + deriving (Show) + +instance FromJSON RingMode where + parseJSON (Object v) = + RingMode + <$> v .: "name" + <*> v .: "up" + <*> v .: "down" + parseJSON invalid = typeMismatch "RingMode" invalid + +-- | Supported actions for binding +data TabletAction = + Key String -- ^ Keyboard shortcut, for example @shift@, @ctrl z@ etc + | Click Int -- ^ Mouse button click + | DblClick Int -- ^ Mouse button double click + +instance FromJSON TabletAction where + parseJSON (String text) = + case words (T.unpack text) of + [] -> fail "empty tablet action" + ("key":ws) -> return $ Key $ unwords ws + ["button", s] -> + if all isDigit s + then return $ Click $ read s + else fail $ "Invalid button number " ++ s + ["dblclick", s] -> + if all isDigit s + then return $ DblClick $ read s + else fail $ "Invalid button number " ++ s + xs -> fail $ "Invalid tablet action specification: " ++ unwords xs + parseJSON invalid = typeMismatch "TabletAction" invalid + +instance Show TabletAction where + show (Key s) = "key " ++ s + show (Click b) = "button " ++ show b + show (DblClick b) = "dblclick " ++ show b + +-- | Default config +dfltConfig :: Config +dfltConfig = Config { + tStylusKey = "Pen", + tPadKey = "Pad", + tTouchKey = "Finger", + tMapAreas = [], + tTouch = False, + tProfiles = [] +} + +buildProfiles :: [Profile] -> [(String, Profile)] +buildProfiles lst = [(pName p, p) | p <- lst] + +readConfig :: FilePath -> IO (Either ParseException Config) +readConfig path = decodeFileEither path + diff --git a/System/Wacom/Daemon.hs b/System/Wacom/Daemon.hs new file mode 100644 --- /dev/null +++ b/System/Wacom/Daemon.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Wacom.Daemon + where + +import Control.Monad + +import Data.List + +import Control.Concurrent + +import System.UDev hiding (isEmpty) +import System.Posix.IO.Select +import System.Posix.IO.Select.Types hiding (Result) + +import System.Wacom.Types +import System.Wacom.Internal +import System.Wacom.Util +import System.Wacom.Profiles +import System.Wacom.Config + +-- | Detect tablet devices by using udev +detectAtStartup :: Config -> UDev -> IO (Maybe TabletDevice) +detectAtStartup cfg udev = do + list <- initEnumeration + deviceNames <- enumerateDevices list + let wacomDevices = filter isWacom $ map fromBS deviceNames + if null wacomDevices + then return Nothing + else do + let names = map (trim . trimQuotes) wacomDevices + stylus = pick (tStylusKey cfg) names + pad = pick (tPadKey cfg) names + touch = pick (tTouchKey cfg) names + dev = TabletDevice stylus pad touch + return $ Just dev + where + initEnumeration = do + enum <- newEnumerate udev + addMatchSubsystem enum "input" + scanDevices enum + list <- getListEntry enum + return list + + enumerateDevices list = iter list + + iter (Just list) = do + path <- getName list + dev <- newFromSysPath udev path + mbName <- getPropertyValue dev "NAME" + x <- getNext list + rest <- iter x + case mbName of + Nothing -> return rest + Just new -> do + -- C8.putStrLn $ "Device: " `B.append` new + return (new : rest) + iter Nothing = do + putStrLn "End." + return [] + + pick _ [] = Nothing + pick suffix (name : names) + | suffix `isSuffixOf` name = Just name + | otherwise = pick suffix names + +-- | To be called before starting udevMonitor. +initUdevMonitor :: WacomHandle -> IO () +initUdevMonitor wh@(WacomHandle tvar) = do + putStrLn "Udev monitor initing..." + return () + +-- | UDev device monitor daemon. +-- To be called in separate thread (by forkIO). +-- This daemon implements the following functionality: +-- +-- * Detects attached tablet at startup (via udev). +-- +-- * Detects tablet plugging while running (via udev). +-- +-- * Tracks selected settings profile and ring mode. +-- +-- * Applies selected settings by calling xsetwacom automatically +-- after tablet is attached. +-- +udevMonitor :: WacomHandle -> IO () +udevMonitor wh@(WacomHandle tvar) = withUDev $ \udev -> do + putStrLn "Udev monitor starting..." + + st <- readMVar tvar + let cfg = msConfig st + mbDev <- detectAtStartup cfg udev + case mbDev of + Just dev -> do + modifyMVar_ tvar $ \st -> + return st {msDevice = dev} + _ -> return () + + st <- readMVar tvar + onPlug (msConfig st) + monitor <- newFromNetlink udev UDevId + filterAddMatchSubsystemDevtype monitor "input" Nothing + enableReceiving monitor + fd <- getFd monitor + forever $ do + res <- select' [fd] [] [] Never + case res of + Just ([_], [], []) -> do + dev <- receiveDevice monitor + st <- readMVar tvar + handleDevice (msConfig st) dev + Nothing -> return () + return () + where + handleDevice :: Config -> Device -> IO () + handleDevice cfg dev = do + mbName <- getPropertyValue dev "NAME" + let mbAction = getAction dev + case (mbName, mbAction) of + (Just name, Just action) -> handle cfg action (trimQuotes $ trim $ fromBS name) + _ -> return () + + handle :: Config -> Action -> String -> IO () + handle cfg Add name + | isWacom name && (tStylusKey cfg) `isInfixOf` name = setStylus $ Just name + | isWacom name && (tPadKey cfg) `isInfixOf` name = setPad $ Just name + | isWacom name && (tTouchKey cfg) `isInfixOf` name = setTouch $ Just name + | otherwise = putStrLn $ "Add " ++ name + handle cfg Remove name + | isWacom name && (tStylusKey cfg) `isInfixOf` name = setStylus Nothing + | isWacom name && (tPadKey cfg) `isInfixOf` name = setPad Nothing + | isWacom name && (tTouchKey cfg) `isInfixOf` name = setTouch Nothing + | otherwise = putStrLn $ "Remove " ++ name + handle _ action name = + putStrLn $ show action ++ " " ++ name + + setStylus :: Maybe String -> IO () + setStylus x = do + putStrLn $ "Detected stylus: " ++ show x + modifyMVar_ tvar $ \st -> return $ st {msDevice = (msDevice st) {dStylus = x}} + st <- readMVar tvar + when (isFull $ msDevice st) $ onPlug (msConfig st) + when (isEmpty $ msDevice st) onUnplug + + setPad :: Maybe String -> IO () + setPad x = do + putStrLn $ "Detected pad: " ++ show x + modifyMVar_ tvar $ \st -> return $ st {msDevice = (msDevice st) {dPad = x}} + st <- readMVar tvar + when (isFull $ msDevice st) $ onPlug (msConfig st) + when (isEmpty $ msDevice st) onUnplug + + setTouch :: Maybe String -> IO () + setTouch x = do + putStrLn $ "Detected touch: " ++ show x + modifyMVar_ tvar $ \st -> return $ st {msDevice = (msDevice st) {dTouch = x}} + st <- readMVar tvar + when (isFull $ msDevice st) $ onPlug (msConfig st) + when (isEmpty $ msDevice st) onUnplug + + onPlug :: Config -> IO () + onPlug cfg = do + st <- readMVar tvar + let dev = msDevice st + putStrLn $ "Plugged " ++ show dev + let profile = msProfile st + rmode = msRingMode st + initRingControlFile wh + runProfile dev cfg profile (snd `fmap` rmode) + return () + + onUnplug :: IO () + onUnplug = do + d <- readMVar tvar + putStrLn $ "Unplugged " ++ show (msDevice d) + diff --git a/System/Wacom/Internal.hs b/System/Wacom/Internal.hs new file mode 100644 --- /dev/null +++ b/System/Wacom/Internal.hs @@ -0,0 +1,28 @@ + +module System.Wacom.Internal + ( + MonState (..), + WacomHandle (..) + ) + where + +import Control.Concurrent + +import System.Wacom.Types +import System.Wacom.Config +import qualified System.Wacom.Ring as Ring + +-- | UDev monitor internal state +data MonState = MonState { + msDevice :: TabletDevice -- ^ Currently attached tablet device + , msConfig :: Config -- ^ Configuration + , msArea :: Maybe Area -- ^ Currently selected mapping area + , msProfile :: Maybe Profile -- ^ Currently selected profile + , msRingMode :: Maybe (Int, RingMode) -- ^ Currently selected ring mode: index and definition + , msRingControl :: Maybe Ring.ControlFile -- ^ Ring control file + } + deriving (Show) + +-- | Abstract data type - handle to communicate with daemon. +newtype WacomHandle = WacomHandle (MVar MonState) + diff --git a/System/Wacom/Matching.hs b/System/Wacom/Matching.hs new file mode 100644 --- /dev/null +++ b/System/Wacom/Matching.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances, RecordWildCards #-} + +module System.Wacom.Matching where + +import Control.Applicative +import Data.Aeson.Types (typeMismatch) +import Data.Yaml +import qualified Data.Vector as V + +import qualified System.Wacom.Config as PC + +data Condition = Condition { + windowTitle :: Maybe String -- ^ Nothing - do not check + , windowClass :: Maybe String -- ^ Nothing - do not check + } deriving (Show) + +instance FromJSON Condition where + parseJSON (Object v) = + Condition + <$> v .:? "title" + <*> v .:? "class" + parseJSON invalid = typeMismatch "Condition" invalid + +ifTitle :: String -> Condition +ifTitle title = Condition (Just title) Nothing + +ifClass :: String -> Condition +ifClass cls = Condition Nothing (Just cls) + +-- | (Condition on window, corresponding profile name) +type Matchers = [(Condition, String)] + +instance FromJSON Matchers where + parseJSON (Array v) = mapM parseOne (V.toList v) + where + parseOne val@(Object obj) = do + cond <- parseJSON val + profile <- obj .: "profile" + return (cond, profile) + parseOne invalid = typeMismatch "Matching condition" invalid + parseJSON invalid = typeMismatch "Matching conditions list" invalid + +data KeyMapConfig = KeyMapConfig { + kmRingMode :: Maybe String, + kmMapAreas :: [String] + } deriving (Show) + +getHotkeys :: KeyMapConfig -> [String] +getHotkeys KeyMapConfig {..} = + kmMapAreas ++ case kmRingMode of + Nothing -> [] + Just key -> [key] + +instance FromJSON KeyMapConfig where + parseJSON val@(Object v) = do + ring <- v .:? "toggle-ring-mode" + areas <- v .: "mapping-areas" + return $ KeyMapConfig ring areas + parseJSON invalid = typeMismatch "Keymap config" invalid + +data Config = Config { + mcProfilesConfig :: PC.Config, + mcNotify :: Bool, + mcKeyMap :: KeyMapConfig, + mcMatching :: Matchers + } deriving (Show) + +instance FromJSON Config where + parseJSON val@(Object v) = do + profilesConfig <- parseJSON val + notify <- v .:? "notify" .!= True + keys <- v .: "hotkeys" + matching <- v .: "matching" + return $ Config profilesConfig notify keys matching + parseJSON invalid = typeMismatch "Configuration" invalid + +data WindowInfo = WindowInfo { + wiTitle :: String, + wiClass :: String + } deriving (Show) + +match :: WindowInfo -> Condition -> Bool +match wi cond = + let titleOk = case windowTitle cond of + Nothing -> True + Just ct -> ct == wiTitle wi + classOk = case windowClass cond of + Nothing -> True + Just cc -> cc == wiClass wi + in titleOk && classOk + +selectProfile :: Matchers -> WindowInfo -> String +selectProfile [] _ = "Default" +selectProfile ((cond, profile): xs) wi = + if match wi cond + then profile + else selectProfile xs wi + +readConfig :: FilePath -> IO (Either ParseException Config) +readConfig path = decodeFileEither path + diff --git a/System/Wacom/Notify.hs b/System/Wacom/Notify.hs new file mode 100644 --- /dev/null +++ b/System/Wacom/Notify.hs @@ -0,0 +1,11 @@ + +module System.Wacom.Notify where + +import Libnotify + +notify :: String -> String -> IO () +notify title text = do + display_ (category cat <> summary title <> body text) + where + cat = "Wacom Tablet" + diff --git a/System/Wacom/Profiles.hs b/System/Wacom/Profiles.hs new file mode 100644 --- /dev/null +++ b/System/Wacom/Profiles.hs @@ -0,0 +1,219 @@ + +module System.Wacom.Profiles + ( + WacomHandle, + + newWacomHandle, + setProfile, + getProfileName, + setRingMode, + toggleRingMode, + getRingMode, + getRingModeName, + syncRingMode, + initRingControlFile, + setMapArea, + getMapArea, + + emptyState, + + runProfile, + xsetwacom + ) + where + +import Control.Monad +import qualified Data.Map as M +import Text.Printf +import System.Process + +import Control.Concurrent + +import System.Wacom.Types +import System.Wacom.Config +import System.Wacom.Internal +import qualified System.Wacom.Ring as Ring + +emptyState :: Config -> MonState +emptyState cfg = MonState noDevice cfg Nothing Nothing Nothing Nothing + +-- | Create new handle to communicate with daemon. +newWacomHandle :: Config -> IO WacomHandle +newWacomHandle cfg = do + tvar <- newMVar $ emptyState cfg + let wh = WacomHandle tvar + return wh + +renderTouch :: TabletDevice -> Config -> [String] +renderTouch td cfg = + case dTouch td of + Just touch -> [printf "\"%s touch\" Touch %s" touch on] + Nothing -> [] + where + on | tTouch cfg = "on" + | otherwise = "off" + +renderRingMode :: TabletDevice -> RingMode -> [String] +renderRingMode td r = + case dPad td of + Just pad -> + [printf "\"%s pad\" AbsWheelDown \"%s\"" pad (show $ ringDown r), + printf "\"%s pad\" AbsWheelUp \"%s\"" pad (show $ ringUp r)] + Nothing -> [] + +renderButtons :: TabletDevice -> M.Map Int TabletAction -> [String] +renderButtons td m = + case dPad td of + Nothing -> [] + Just pad -> + [printf "\"%s pad\" Button %d \"%s\"" pad idx (show action) + | (idx,action) <- M.assocs m] + +renderMapArea :: TabletDevice -> String -> [String] +renderMapArea td area = + case dStylus td of + Nothing -> [] + Just stylus -> + [printf "\"%s stylus\" MapToOutput %s" stylus area] + +-- | Run xsetwacom to apply selected profile +runProfile :: TabletDevice -> Config -> Maybe Profile -> Maybe RingMode -> IO () +runProfile td cfg mbProfile mbMode = do + let rmode = case mbMode of + Nothing -> [] + Just ringMode -> renderRingMode td ringMode + prof = case mbProfile of + Nothing -> [] + Just profile -> renderButtons td (pButtons profile) + xsetwacom $ + renderTouch td cfg ++ + rmode ++ + prof + +-- | Run xsetwacom command with specified arguments +xsetwacom :: [String] -> IO () +xsetwacom cmds = do + forM_ cmds $ \cmd -> do + let command = "xsetwacom set " ++ cmd + putStrLn command + spawnCommand command + +-- | Set profile by name +setProfile :: WacomHandle -> String -> IO (Result String) +setProfile wh@(WacomHandle tvar) profileName = do + st <- readMVar tvar + let cfg = msConfig st + mbMode = msRingMode st + td = msDevice st + case lookup profileName (tProfiles cfg) of + Nothing -> return $ Left $ "Unknown profile " ++ profileName + Just profile -> do + putStrLn $ "Setting profile: " ++ profileName + runProfile td cfg (Just profile) (snd `fmap` mbMode) + modifyMVar_ tvar $ \st -> return $ st {msProfile = Just profile} + setRingMode wh 0 + return $ Right profileName + +-- | Set ring mode by index +setRingMode :: WacomHandle -> Int -> IO (Result String) +setRingMode (WacomHandle tvar) idx = do + st <- readMVar tvar + let cfg = msConfig st + td = msDevice st + case msProfile st of + Nothing -> return $ Left "No current profile, can't set ring mode" + Just profile -> + if (idx >= 0) && (idx < length (pRing profile)) + then do + let rmode = pRing profile !! idx + runProfile td cfg Nothing (Just rmode) + case msRingControl st of + Nothing -> putStrLn "No ring control file" + Just file -> Ring.setMode file idx + modifyMVar_ tvar $ \st -> return $ st {msRingMode = Just (idx, rmode)} + return $ Right $ show idx + else return $ Left $ "Invalid ring mode index" + +-- | Toggle ring mode: 0 -> 1 -> 2 -> 3 -> 0... +toggleRingMode :: WacomHandle -> IO (Result String) +toggleRingMode wh@(WacomHandle tvar) = do + st <- readMVar tvar + let mbMode = msRingMode st + case msProfile st of + Nothing -> return $ Left "No current profile, can't set ring mode" + Just profile -> + case mbMode of + Nothing -> return $ Left $ "No current ring mode, cannot toggle" + Just (idx, rmode) -> do + let n = length (pRing profile) + idx' = (idx + 1) `mod` n + setRingMode wh idx' + +-- | Obtain current ring mode index +getRingMode :: WacomHandle -> IO (Result String) +getRingMode (WacomHandle tvar) = do + st <- readMVar tvar + case msRingMode st of + Nothing -> return $ Left "No ring mode" + Just rmode -> return $ Right $ show $ fst rmode + +-- | Obtain current ring mode name +getRingModeName :: WacomHandle -> IO (Result String) +getRingModeName (WacomHandle tvar) = do + st <- readMVar tvar + case msRingMode st of + Nothing -> return $ Left "No ring mode" + Just rmode -> return $ Right $ rName $ snd rmode + +-- | Sync ring mode used by daemon with the mode indicated by tablet itself +syncRingMode :: WacomHandle -> IO (Result String) +syncRingMode wh@(WacomHandle tvar) = do + st <- readMVar tvar + case msRingControl st of + Nothing -> return $ Left "No ring control file" + Just file -> do + idx <- Ring.readMode file + setRingMode wh idx + +-- | Obtain currently selected profile name +getProfileName :: WacomHandle -> IO (Result String) +getProfileName (WacomHandle tvar) = do + st <- readMVar tvar + case msProfile st of + Nothing -> return $ Left "No current profile" + Just profile -> return $ Right $ pName profile + +-- | Return path of ring control file +initRingControlFile :: WacomHandle -> IO (Result String) +initRingControlFile (WacomHandle tvar) = do + r <- Ring.getControlFile + modifyMVar_ tvar $ \st -> return $ st {msRingControl = r} + case r of + Nothing -> return $ Left "No ring control file" + Just file -> return $ Right file + +-- | Set tablet mapping area by index +setMapArea :: WacomHandle -> Int -> IO (Result String) +setMapArea (WacomHandle tvar) idx = do + st <- readMVar tvar + let td = msDevice st + cfg = msConfig st + case tMapAreas cfg of + [] -> return $ Left $ "No map areas defined" + areas -> + if (idx >= 0) && (idx < length areas) + then do + let area = areas !! idx + xsetwacom $ renderMapArea td area + modifyMVar_ tvar $ \st -> return $ st {msArea = Just area} + return $ Right area + else return $ Left "Invalid map area index" + +-- | Return currenly selected mapping area +getMapArea :: WacomHandle -> IO (Result String) +getMapArea (WacomHandle tvar) = do + st <- readMVar tvar + case msArea st of + Nothing -> return $ Left "No current map area" + Just area -> return $ Right area + diff --git a/System/Wacom/Ring.hs b/System/Wacom/Ring.hs new file mode 100644 --- /dev/null +++ b/System/Wacom/Ring.hs @@ -0,0 +1,36 @@ + +module System.Wacom.Ring + ( + ControlFile, + getControlFile, + readMode, + setMode + ) + where + +import System.FilePath.Glob +import System.Directory + +type ControlFile = FilePath + +control_path_mask = "/sys/bus/usb/devices/*/*/wacom_led/status_led0_select" + +-- | Check whether file is writeable +isWritable :: FilePath -> IO Bool +isWritable path = writable `fmap` getPermissions path + +getControlFile :: IO (Maybe ControlFile) +getControlFile = do + files <- glob control_path_mask + if null files + then return Nothing + else return $ Just $ head files + +readMode :: ControlFile -> IO Int +readMode path = do + str <- readFile path + return $ read str + +setMode :: ControlFile -> Int -> IO () +setMode path idx = do + writeFile path (show idx) diff --git a/System/Wacom/Types.hs b/System/Wacom/Types.hs new file mode 100644 --- /dev/null +++ b/System/Wacom/Types.hs @@ -0,0 +1,23 @@ + +module System.Wacom.Types where + +data TabletDevice = TabletDevice { + dStylus :: Maybe String, + dPad :: Maybe String, + dTouch :: Maybe String + } + deriving (Show) + +noDevice :: TabletDevice +noDevice = TabletDevice Nothing Nothing Nothing + +isEmpty :: TabletDevice -> Bool +isEmpty (TabletDevice Nothing Nothing Nothing) = True +isEmpty _ = False + +isFull :: TabletDevice -> Bool +isFull (TabletDevice (Just _) (Just _) _) = True +isFull _ = False + +type Result a = Either String a + diff --git a/System/Wacom/Util.hs b/System/Wacom/Util.hs new file mode 100644 --- /dev/null +++ b/System/Wacom/Util.hs @@ -0,0 +1,36 @@ + +module System.Wacom.Util where + +import Data.Char +import Data.List +import qualified Data.ByteString as B + +-- | Trim spaces from right and left +trim :: String -> String +trim = \xs -> rtrim $ ltrim xs + where + ltrim = dropWhile isSpace + rtrim [] = [] + rtrim xs = if isSpace $ last xs + then rtrim $ init xs + else xs + +-- | Trim double quotes from right and left +trimQuotes :: String -> String +trimQuotes [] = [] +trimQuotes ('"' : xs) = rtrim xs + where + rtrim [] = [] + rtrim xs = case last xs of + '"' -> init xs + _ -> xs + +dropLastWord :: String -> String +dropLastWord = init . dropWhileEnd (not . isSpace) + +fromBS :: B.ByteString -> String +fromBS = map (chr . fromIntegral) . B.unpack + +isWacom :: String -> Bool +isWacom dev = "Wacom" `isInfixOf` dev + diff --git a/System/Wacom/X11.hs b/System/Wacom/X11.hs new file mode 100644 --- /dev/null +++ b/System/Wacom/X11.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE RecordWildCards #-} + +module System.Wacom.X11 + ( + ModeAction (..), + KeyMap, + getWindowInfo, + withDisplay, + getNumlockMask, + cleanMask, + parseShortcut, + grabHotkeys, + compileKeyMap + ) where + +import Control.Monad +import Control.Exception as E +import qualified Data.Map as M +import Data.Bits + +import Graphics.X11 +import Graphics.X11.Xlib.Extras + +import System.Wacom.Matching + +data ModeAction = + ToggleRingMode + | SetMappingArea Int + deriving (Eq, Show) + +type KeyMap = M.Map (KeyMask, KeySym) ModeAction + +getTitle :: Display -> Window -> IO String +getTitle d w = do + let getProp = + (internAtom d "_NET_WM_NAME" False >>= getTextProperty d w) + `E.catch` \(SomeException e) -> do + putStrLn (show e) + getTextProperty d w wM_NAME + extract prop = do l <- wcTextPropertyToTextList d prop + return $ if null l then "" else head l + bracket getProp (xFree . tp_value) extract `E.catch` \(SomeException e) -> return (show e) + +getWindow :: Display -> Atom -> Window -> IO (Maybe Window) +getWindow dpy atom root = do + r <- getWindowProperty32 dpy atom root + case r of + Just [w] -> return $ Just $ fromIntegral w + _ -> return Nothing + +-- | Obtain basic information about currently active window +getWindowInfo :: Display + -> Atom -- ^ _NET_ACTIVE_WINDOW atom + -> Window -- ^ X root window + -> IO (Maybe WindowInfo) +getWindowInfo dpy atom root = do + r <- getWindow dpy atom root + case r of + Nothing -> return Nothing + Just 0 -> return Nothing + Just window -> do + title <- getTitle dpy window + cls <- resName `fmap` getClassHint dpy window + return $ Just $ WindowInfo title cls + +withDisplay :: String -> (Display -> IO a) -> IO a +withDisplay str fn = do + dpy <- openDisplay str + res <- fn dpy + closeDisplay dpy + return res + +-- | Detect KeyMask corresponding to NumLock modifier +getNumlockMask :: Display -> IO KeyMask +getNumlockMask dpy = do + ms <- getModifierMapping dpy + xs <- sequence [ do + ks <- keycodeToKeysym dpy kc 0 + if ks == xK_Num_Lock + then return (setBit 0 (fromIntegral m)) + else return (0 :: KeyMask) + | (m, kcs) <- ms, kc <- kcs, kc /= 0] + return $ foldr (.|.) 0 xs + +-- | Strip numlock\/capslock from a mask +cleanMask :: KeyMask -> KeyMask -> KeyMask +cleanMask numlock km = + (complement (numlock .|. lockMask) .&. km) + +-- | Parse X11 KeyMask + KeySym from xsetwacom-style specification. +-- +-- Supported are strings like @F11@, @ctrl alt z@. +parseShortcut :: String -> Maybe (Modifier, KeySym) +parseShortcut str = do + let ws = words str + case ws of + [] -> Nothing + [w] -> do + k <- parseKey w + return (noModMask, k) + _ -> do + mods <- parseMods (init ws) + k <- parseKey (last ws) + return (mods, k) + where + parseKey :: String -> Maybe KeySym + parseKey key = + case stringToKeysym key of + 0 -> Nothing + k -> Just k + + parseMods :: [String] -> Maybe Modifier + parseMods mods = foldr (.|.) 0 `fmap` mapM parseMod mods + + parseMod :: String -> Maybe Modifier + parseMod "ctrl" = Just controlMask + parseMod "shift" = Just shiftMask + parseMod "alt" = Just mod1Mask + parseMod "mod1" = Just mod1Mask + parseMod "mod2" = Just mod2Mask + parseMod "mod3" = Just mod3Mask + parseMod "mod4" = Just mod4Mask + parseMod "mod5" = Just mod5Mask + parseMod _ = Nothing + +grabHotkey :: Display -> Window -> KeyMask -> String -> IO () +grabHotkey dpy rootw numlock keystr = do + case parseShortcut keystr of + Nothing -> fail $ "Unsupported shortcut: " ++ keystr + Just (mod, keysym) -> do + putStrLn $ "Grabbing hotkey: " ++ keystr + hotkey <- keysymToKeycode dpy keysym + -- Grab both mask+key and numlock+mask+key. + grabKey dpy hotkey mod rootw True grabModeAsync grabModeAsync + grabKey dpy hotkey (mod .|. numlock) rootw True grabModeAsync grabModeAsync + +grabHotkeys :: Display -> Window -> KeyMask -> [String] -> IO () +grabHotkeys dpy rootw numlock keys = do + forM_ keys $ \keystr -> + grabHotkey dpy rootw numlock keystr + +compileKeyMap :: Display -> KeyMapConfig -> IO KeyMap +compileKeyMap dpy KeyMapConfig {..} = do + ring <- case kmRingMode of + Nothing -> return [] + Just keystr -> do + key <- compile keystr + return [(key, ToggleRingMode)] + areas <- do + keys <- mapM compile kmMapAreas + return [(key, SetMappingArea i) | (i,key) <- zip [0..] keys] + return $ M.fromList $ ring ++ areas + where + compile :: String -> IO (KeyMask, KeySym) + compile keystr = do + case parseShortcut keystr of + Nothing -> fail $ "Unsupported shortcut: " ++ keystr + Just (mod, keysym) -> do + return (mod, keysym) + diff --git a/hswcmcli.hs b/hswcmcli.hs new file mode 100644 --- /dev/null +++ b/hswcmcli.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Concurrent + +import System.IO + +import System.Wacom.Daemon +import System.Wacom.CLI +import System.Wacom.Profiles + +import Config + +-- Simple command-line utility to select tablet profiles + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + wh <- newWacomHandle config + forkIO $ udevMonitor wh + setProfile wh "Default" + setRingMode wh 0 + print =<< setMapArea wh 0 + client wh + diff --git a/hswcmd.hs b/hswcmd.hs new file mode 100644 --- /dev/null +++ b/hswcmd.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE RecordWildCards #-} + +import Control.Monad +import qualified Data.Map as M +import Control.Exception as E +import Control.Concurrent +import Foreign +import Foreign.Ptr +import Data.Bits ((.|.)) +import Text.Printf + +import Graphics.X11 +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xlib.Atom + +import System.FilePath +import System.Environment + +import System.Wacom.Daemon +import System.Wacom.Profiles +import System.Wacom.X11 +import System.Wacom.Matching +import System.Wacom.Notify + +onCurrentWindowChange :: WacomHandle -> Config -> WindowInfo -> IO () +onCurrentWindowChange wh cfg wi = do + print wi + rOld <- getProfileName wh + let newProfile = selectProfile (mcMatching cfg) wi + case rOld of + Left err -> putStrLn $ "Cant get old profile: " ++ err + Right old -> do + putStrLn $ "Old profile: " ++ old + when (newProfile /= old) $ do + r <- setProfile wh newProfile + case r of + Right p -> do + putStrLn $ "Selecting profile: " ++ p + when (mcNotify cfg) $ + notify "Tablet profile" $ "New tablet profile selected: " ++ p + Left err -> putStrLn $ "Error: " ++ err + return () + +runModeAction :: WacomHandle -> Config -> ModeAction -> IO () +runModeAction wh cfg ToggleRingMode = do + r <- toggleRingMode wh + case r of + Left err -> putStrLn $ "Error: " ++ err + Right res -> do + putStrLn $ "Ring mode: " ++ res + when (mcNotify cfg) $ do + rm <- getRingModeName wh + case rm of + Left err -> putStrLn $ "Error: " ++ err + Right name -> notify "Ring Mode" $ "New ring mode selected: " ++ name +runModeAction wh _ (SetMappingArea idx) = do + setMapArea wh idx + return () + +getConfigFile :: IO FilePath +getConfigFile = do + home <- getEnv "HOME" + return $ home ".config" "hswcmd.yaml" + +main :: IO () +main = do + ecfg <- readConfig =<< getConfigFile + cfg <- case ecfg of + Left err -> fail $ show err + Right cfg -> return cfg + + wh <- newWacomHandle (mcProfilesConfig cfg) + forkIO $ udevMonitor wh + setProfile wh "Default" + setRingMode wh 0 + setMapArea wh 0 + + + withDisplay "" $ \dpy -> do + let rootw = defaultRootWindow dpy + numlock <- getNumlockMask dpy + grabHotkeys dpy rootw numlock $ getHotkeys (mcKeyMap cfg) + keymap <- compileKeyMap dpy $ mcKeyMap cfg + -- We need only PropertyEvent (toggled when active window is changed) + -- and KeyEvent (when keyboard key is pressed) + selectInput dpy rootw (propertyChangeMask .|. keyPressMask) + forever $ do + allocaXEvent $ \xptr -> do + nextEvent dpy xptr + ev <- getEvent xptr + case ev of + PropertyEvent {..} -> do + mbName <- getAtomName dpy ev_atom + case mbName of + -- We are interested only in such events - active window changed + Just "_NET_ACTIVE_WINDOW" -> do + mbWindow <- getWindowInfo dpy ev_atom ev_window + case mbWindow of + Just wi -> onCurrentWindowChange wh cfg wi + Nothing -> return () + _ -> return () + KeyEvent {..} -> do + -- Key pressed + when (ev_event_type == keyPress) $ do + keysym <- keycodeToKeysym dpy ev_keycode 0 + let mask = cleanMask numlock ev_state + case M.lookup (mask,keysym) keymap of + Nothing -> putStrLn $ "Unknown key " ++ show (mask,keysym) + Just action -> runModeAction wh cfg action + return () + _ -> putStrLn $ "Unexpected event: " ++ show ev + diff --git a/hswcmd.yaml b/hswcmd.yaml new file mode 100644 --- /dev/null +++ b/hswcmd.yaml @@ -0,0 +1,71 @@ +# Sample configuration file. +# To be put under ~/.config/hswcmd.yaml. +# +# Keyboard shortcuts and mouse actions are specified +# in xsetwacom format. + +# Tablet mapping areas. The first one will be used +# by default. +mapping-areas: ["1920x1200+0+0", "1920x1080+1920+0"] +# Whether to notify you (via libnotify) on tablet +# profile or ring mode switching. +notify: true +hotkeys: + # Hotkey to toggle Intuos Pro Express Ring modes. + # Optional. + toggle-ring-mode: ctrl alt shift F12 + mapping-areas: + - ctrl shift F1 # To switch to 1st area + - ctrl shift F2 # To switch to 2nd area +profiles: + # The profile with `Default' name is always used + # by default. + - name: Default + # Express Ring modes (up to 4) + ring: + - name: Scroll + up: button 5 + down: button 4 + # Tablet (pad) buttons mapping for this profile. + # Use xev to detect button numbers. + buttons: + 1: key ctrl alt shift F12 + 2: key ctrl + 3: key shift + 12: key Delete + 13: key ctrl z + + - name: Blender + ring: + - name: Scroll + up: button 5 + down: button 4 + - name: Brackets + up: "key [" + down: "key ]" + - name: Orbit left/right + up: key 4 + down: key 6 + buttons: + 1: key ctrl alt shift F12 + 2: key b + 3: key shift + 8: key 7 + 9: key 1 + 10: key 3 + 11: key 5 + 12: key Delete + 13: key ctrl z +# Rules to match windows with tablet profiles. +# Each rule can match windows by class (WM_CLASS) +# and/or title. +# The `Default' profile will be used if no rule +# matches for the window. +matching: + - class: "krita" + profile: "Krita" + - class: "Blender" + profile: "Blender" + - title: "My Graphical App" + profile: MyApp + diff --git a/wacom-daemon.cabal b/wacom-daemon.cabal new file mode 100644 --- /dev/null +++ b/wacom-daemon.cabal @@ -0,0 +1,123 @@ +-- Initial wacom-daemon.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: wacom-daemon +version: 0.1.0.0 +synopsis: Manage Wacom tablet settings profiles, including Intuos Pro ring modes +description: This package provides a daemon process and a simple API to manage Wacom tablet settings profiles. + Each profile is contains set of tablet settings: buttons mapping, touchpad configuration, etc. + Modes for Intuos Pro Express Ring are also supported. + + The daemon detects tablet plug/unplug via udev and applies settings via xsetwacom command line + utility. + + The API may be used to manage tablet settings from any haskell application, for example, XMonad. + + The package provides a daemon (hswcmd) which can manage tablet profiles for any lightweight + desktop environment (without KDE/GNOME). The daemon is configured via YAML config file. + + Simple utility to manage tablet settings from command line (hswcmcli) interface is also provided. +homepage: https://github.com/portnov/wacom-intuos-pro-scripts +license: BSD3 +license-file: LICENSE +author: Ilya Portnov +maintainer: portnov@iportnov.ru +-- copyright: +category: Desktop +build-type: Simple +extra-source-files: hswcmd.yaml +cabal-version: >=1.10 + +library + exposed-modules: System.Wacom.Util, + System.Wacom.Profiles, + System.Wacom.Ring, + System.Wacom.Config, + System.Wacom.Daemon, + System.Wacom.Notify, + System.Wacom.Types, + System.Wacom.CLI, + System.Wacom.X11, + System.Wacom.Matching + other-modules: System.Wacom.Internal + ghc-options: -fwarn-unused-imports + build-depends: base >=4.7 && <4.8, + containers >=0.5 && <0.6, + bytestring >=0.10 && <0.11, + process >=1.2 && <1.3, + Glob >=0.7 && <0.8, + directory >=1.2 && <1.3, + filepath >= 1.3.0, + udev >=0.1 && <0.2, + select >=0.4 && <0.5, + unordered-containers >= 0.2.5, + vector >= 0.10.12, + aeson >= 0.10, + yaml >= 0.8.15, + text >= 1.2.0.0, + X11 >= 1.6.1, + libnotify >= 0.1.1.0 + default-language: Haskell2010 + +executable hswchd + Main-Is: hswcmd.hs + other-modules: System.Wacom.Util, + System.Wacom.Profiles, + System.Wacom.Ring, + System.Wacom.Config, + System.Wacom.Daemon, + System.Wacom.Notify, + System.Wacom.Types, + System.Wacom.CLI, + System.Wacom.X11, + System.Wacom.Matching, + System.Wacom.Internal + build-depends: base >=4.7 && <4.8, + containers >=0.5 && <0.6, + bytestring >=0.10 && <0.11, + process >=1.2 && <1.3, + Glob >=0.7 && <0.8, + directory >=1.2 && <1.3, + filepath >= 1.3.0, + udev >=0.1 && <0.2, + select >=0.4 && <0.5, + unordered-containers >= 0.2.5, + vector >= 0.10.12, + aeson >= 0.10, + yaml >= 0.8.15, + text >= 1.2.0.0, + X11 >= 1.6.1, + libnotify >= 0.1.1.0 + default-language: Haskell2010 + +executable hswcmcli + Main-Is: hswcmcli.hs + other-modules: System.Wacom.Util, + System.Wacom.Profiles, + System.Wacom.Ring, + System.Wacom.Config, + System.Wacom.Daemon, + System.Wacom.Notify, + System.Wacom.Types, + System.Wacom.CLI, + System.Wacom.X11, + System.Wacom.Matching, + System.Wacom.Internal + build-depends: base >=4.7 && <4.8, + containers >=0.5 && <0.6, + bytestring >=0.10 && <0.11, + process >=1.2 && <1.3, + Glob >=0.7 && <0.8, + directory >=1.2 && <1.3, + filepath >= 1.3.0, + udev >=0.1 && <0.2, + select >=0.4 && <0.5, + unordered-containers >= 0.2.5, + vector >= 0.10.12, + aeson >= 0.10, + yaml >= 0.8.15, + text >= 1.2.0.0, + X11 >= 1.6.1, + libnotify >= 0.1.1.0 + default-language: Haskell2010 +