wacom-daemon (empty) → 0.1.0.0
raw patch · 17 files changed
+1347/−0 lines, 17 filesdep +Globdep +X11dep +aesonsetup-changed
Dependencies added: Glob, X11, aeson, base, bytestring, containers, directory, filepath, libnotify, process, select, text, udev, unordered-containers, vector, yaml
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- System/Wacom/CLI.hs +57/−0
- System/Wacom/Config.hs +138/−0
- System/Wacom/Daemon.hs +176/−0
- System/Wacom/Internal.hs +28/−0
- System/Wacom/Matching.hs +101/−0
- System/Wacom/Notify.hs +11/−0
- System/Wacom/Profiles.hs +219/−0
- System/Wacom/Ring.hs +36/−0
- System/Wacom/Types.hs +23/−0
- System/Wacom/Util.hs +36/−0
- System/Wacom/X11.hs +160/−0
- hswcmcli.hs +24/−0
- hswcmd.hs +112/−0
- hswcmd.yaml +71/−0
- wacom-daemon.cabal +123/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/Wacom/CLI.hs view
@@ -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+
+ System/Wacom/Config.hs view
@@ -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+
+ System/Wacom/Daemon.hs view
@@ -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)+
+ System/Wacom/Internal.hs view
@@ -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)+
+ System/Wacom/Matching.hs view
@@ -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+
+ System/Wacom/Notify.hs view
@@ -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"+
+ System/Wacom/Profiles.hs view
@@ -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+
+ System/Wacom/Ring.hs view
@@ -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)
+ System/Wacom/Types.hs view
@@ -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+
+ System/Wacom/Util.hs view
@@ -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+
+ System/Wacom/X11.hs view
@@ -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)+
+ hswcmcli.hs view
@@ -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+
+ hswcmd.hs view
@@ -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+
+ hswcmd.yaml view
@@ -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+
+ wacom-daemon.cabal view
@@ -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+