{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module       : XMonad.Actions.SpawnOn
-- Copyright    : (c) Spencer Janssen
-- License      : BSD
--
-- Maintainer   : Spencer Janssen <spencerjanssen@gmail.com>
-- Stability    : unstable
-- Portability  : unportable
--
-- Provides a way to modify a window spawned by a command(e.g shift it to the workspace
-- it was launched on) by using the _NET_WM_PID property that most windows set on creation.
-- Hence this module won't work on applications that don't set this property.
--
-----------------------------------------------------------------------------

module XMonad.Actions.SpawnOn (
    -- * Usage
    -- $usage
    Spawner,
    manageSpawn,
    manageSpawnWithGC,
    spawnHere,
    spawnOn,
    spawnAndDo,
    shellPromptHere,
    shellPromptOn
) where

import Control.Exception (tryJust)
import Control.Monad (guard)
import Data.List (isInfixOf)
import Data.Maybe (isJust)
import System.IO.Error (isDoesNotExistError)
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Types (ProcessID)
import Text.Printf (printf)

import XMonad
import qualified XMonad.StackSet as W

import XMonad.Hooks.ManageHelpers
import XMonad.Prompt
import XMonad.Prompt.Shell
import qualified XMonad.Util.ExtensibleState as XS

-- $usage
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
--
-- >    import XMonad.Actions.SpawnOn
--
-- >    main = do
-- >      xmonad def {
-- >         ...
-- >         manageHook = manageSpawn <+> manageHook def
-- >         ...
-- >      }
--
-- To ensure that application appears on a workspace it was launched at, add keybindings like:
--
-- >  , ((mod1Mask,xK_o), spawnHere "urxvt")
-- >  , ((mod1Mask,xK_s), shellPromptHere def)
--
-- The module can also be used to apply other manage hooks to the window of
-- the spawned application(e.g. float or resize it).
--
-- For detailed instructions on editing your key bindings, see
-- "XMonad.Doc.Extending#Editing_key_bindings".

newtype Spawner = Spawner {Spawner -> [(ProcessID, ManageHook)]
pidsRef :: [(ProcessID, ManageHook)]} deriving Typeable

instance ExtensionClass Spawner where
    initialValue :: Spawner
initialValue = [(ProcessID, ManageHook)] -> Spawner
Spawner []


getPPIDOf :: ProcessID -> Maybe ProcessID
getPPIDOf :: ProcessID -> Maybe ProcessID
getPPIDOf pid :: ProcessID
pid =
    case IO (Either () String) -> Either () String
forall a. IO a -> a
unsafePerformIO (IO (Either () String) -> Either () String)
-> (Integer -> IO (Either () String))
-> Integer
-> Either () String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IOError -> Maybe ()) -> IO String -> IO (Either () String)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (IO String -> IO (Either () String))
-> (Integer -> IO String) -> Integer -> IO (Either () String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
readFile (String -> IO String)
-> (Integer -> String) -> Integer -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Integer -> String
forall r. PrintfType r => String -> r
printf "/proc/%d/stat" (Integer -> Either () String) -> Integer -> Either () String
forall a b. (a -> b) -> a -> b
$ ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid of
      Left _         -> Maybe ProcessID
forall a. Maybe a
Nothing
      Right contents :: String
contents -> case String -> [String]
lines String
contents of
                          []        -> Maybe ProcessID
forall a. Maybe a
Nothing
                          first :: String
first : _ -> case String -> [String]
words String
first of
                                         _ : _ : _ : ppid :: String
ppid : _ -> ProcessID -> Maybe ProcessID
forall a. a -> Maybe a
Just (ProcessID -> Maybe ProcessID) -> ProcessID -> Maybe ProcessID
forall a b. (a -> b) -> a -> b
$ Int -> ProcessID
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Int
forall a. Read a => String -> a
read String
ppid :: Int)
                                         _                    -> Maybe ProcessID
forall a. Maybe a
Nothing

getPPIDChain :: ProcessID -> [ProcessID]
getPPIDChain :: ProcessID -> [ProcessID]
getPPIDChain pid' :: ProcessID
pid' = ProcessID -> [ProcessID] -> [ProcessID]
ppid_chain ProcessID
pid' []
    where ppid_chain :: ProcessID -> [ProcessID] -> [ProcessID]
ppid_chain pid :: ProcessID
pid acc :: [ProcessID]
acc =
              if ProcessID
pid ProcessID -> ProcessID -> Bool
forall a. Eq a => a -> a -> Bool
== 0
              then [ProcessID]
acc
              else case ProcessID -> Maybe ProcessID
getPPIDOf ProcessID
pid of
                     Nothing   -> [ProcessID]
acc
                     Just ppid :: ProcessID
ppid -> ProcessID -> [ProcessID] -> [ProcessID]
ppid_chain ProcessID
ppid (ProcessID
ppid ProcessID -> [ProcessID] -> [ProcessID]
forall a. a -> [a] -> [a]
: [ProcessID]
acc)

-- | Get the current Spawner or create one if it doesn't exist.
modifySpawner :: ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X ()
modifySpawner :: ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X ()
modifySpawner f :: [(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]
f = (Spawner -> Spawner) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ([(ProcessID, ManageHook)] -> Spawner
Spawner ([(ProcessID, ManageHook)] -> Spawner)
-> (Spawner -> [(ProcessID, ManageHook)]) -> Spawner -> Spawner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]
f ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)])
-> (Spawner -> [(ProcessID, ManageHook)])
-> Spawner
-> [(ProcessID, ManageHook)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Spawner -> [(ProcessID, ManageHook)]
pidsRef)

-- | Provides a manage hook to react on process spawned with
-- 'spawnOn', 'spawnHere' etc.
manageSpawn :: ManageHook
manageSpawn :: ManageHook
manageSpawn = ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)])
-> ManageHook
manageSpawnWithGC ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)])
-> ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)])
-> [(ProcessID, ManageHook)]
-> X [(ProcessID, ManageHook)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]
forall a. Int -> [a] -> [a]
take 20)

manageSpawnWithGC :: ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)])
        -- ^ function to stop accumulation of entries for windows that never set @_NET_WM_PID@
       -> ManageHook
manageSpawnWithGC :: ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)])
-> ManageHook
manageSpawnWithGC garbageCollect :: [(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)]
garbageCollect = do
    Spawner pids :: [(ProcessID, ManageHook)]
pids <- X Spawner -> Query Spawner
forall a. X a -> Query a
liftX X Spawner
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
    Maybe ProcessID
mp <- Query (Maybe ProcessID)
pid
    let ppid_chain :: [ProcessID]
ppid_chain = case Maybe ProcessID
mp of
                       Just winpid :: ProcessID
winpid -> ProcessID
winpid ProcessID -> [ProcessID] -> [ProcessID]
forall a. a -> [a] -> [a]
: ProcessID -> [ProcessID]
getPPIDChain ProcessID
winpid
                       Nothing     -> []
        known_window_handlers :: [ManageHook]
known_window_handlers = [ ManageHook
mh
                                | ProcessID
ppid <- [ProcessID]
ppid_chain
                                , let mpid :: Maybe ManageHook
mpid = ProcessID -> [(ProcessID, ManageHook)] -> Maybe ManageHook
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ProcessID
ppid [(ProcessID, ManageHook)]
pids
                                , Maybe ManageHook -> Bool
forall a. Maybe a -> Bool
isJust Maybe ManageHook
mpid
                                , let (Just mh :: ManageHook
mh) = Maybe ManageHook
mpid ]
    case [ManageHook]
known_window_handlers of
        [] -> ManageHook
forall m. Monoid m => m
idHook
        (mh :: ManageHook
mh:_)  -> do
            Maybe ProcessID -> (ProcessID -> Query ()) -> Query ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe ProcessID
mp ((ProcessID -> Query ()) -> Query ())
-> (ProcessID -> Query ()) -> Query ()
forall a b. (a -> b) -> a -> b
$ \p :: ProcessID
p -> X () -> Query ()
forall a. X a -> Query a
liftX (X () -> Query ()) -> X () -> Query ()
forall a b. (a -> b) -> a -> b
$ do
                [(ProcessID, ManageHook)]
ps <- (Spawner -> [(ProcessID, ManageHook)])
-> X [(ProcessID, ManageHook)]
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets Spawner -> [(ProcessID, ManageHook)]
pidsRef
                Spawner -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (Spawner -> X ())
-> ([(ProcessID, ManageHook)] -> Spawner)
-> [(ProcessID, ManageHook)]
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ProcessID, ManageHook)] -> Spawner
Spawner ([(ProcessID, ManageHook)] -> X ())
-> X [(ProcessID, ManageHook)] -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)]
garbageCollect (((ProcessID, ManageHook) -> Bool)
-> [(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ProcessID -> ProcessID -> Bool
forall a. Eq a => a -> a -> Bool
/= ProcessID
p) (ProcessID -> Bool)
-> ((ProcessID, ManageHook) -> ProcessID)
-> (ProcessID, ManageHook)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProcessID, ManageHook) -> ProcessID
forall a b. (a, b) -> a
fst) [(ProcessID, ManageHook)]
ps)
            ManageHook
mh

mkPrompt :: (String -> X ()) -> XPConfig -> X ()
mkPrompt :: (String -> X ()) -> XPConfig -> X ()
mkPrompt cb :: String -> X ()
cb c :: XPConfig
c = do
    [String]
cmds <- IO [String] -> X [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [String] -> X [String]) -> IO [String] -> X [String]
forall a b. (a -> b) -> a -> b
$ IO [String]
getCommands
    Shell -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
forall p.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
mkXPrompt Shell
Shell XPConfig
c ([String] -> Predicate -> ComplFunction
getShellCompl [String]
cmds (Predicate -> ComplFunction) -> Predicate -> ComplFunction
forall a b. (a -> b) -> a -> b
$ XPConfig -> Predicate
searchPredicate XPConfig
c) String -> X ()
cb

-- | Replacement for Shell prompt ("XMonad.Prompt.Shell") which launches
-- application on current workspace.
shellPromptHere :: XPConfig -> X ()
shellPromptHere :: XPConfig -> X ()
shellPromptHere = (String -> X ()) -> XPConfig -> X ()
mkPrompt String -> X ()
spawnHere

-- | Replacement for Shell prompt ("XMonad.Prompt.Shell") which launches
-- application on given workspace.
shellPromptOn :: WorkspaceId -> XPConfig -> X ()
shellPromptOn :: String -> XPConfig -> X ()
shellPromptOn ws :: String
ws = (String -> X ()) -> XPConfig -> X ()
mkPrompt (String -> String -> X ()
spawnOn String
ws)

-- | Replacement for 'spawn' which launches
-- application on current workspace.
spawnHere :: String -> X ()
spawnHere :: String -> X ()
spawnHere cmd :: String
cmd = (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \ws :: WindowSet
ws -> String -> String -> X ()
spawnOn (WindowSet -> String
forall i l a s sd. StackSet i l a s sd -> i
W.currentTag WindowSet
ws) String
cmd

-- | Replacement for 'spawn' which launches
-- application on given workspace.
spawnOn :: WorkspaceId -> String -> X ()
spawnOn :: String -> String -> X ()
spawnOn ws :: String
ws cmd :: String
cmd = ManageHook -> String -> X ()
spawnAndDo (String -> ManageHook
doShift String
ws) String
cmd

-- | Spawn an application and apply the manage hook when it opens.
spawnAndDo :: ManageHook -> String -> X ()
spawnAndDo :: ManageHook -> String -> X ()
spawnAndDo mh :: ManageHook
mh cmd :: String
cmd = do
    ProcessID
p <- String -> X ProcessID
forall (m :: * -> *). MonadIO m => String -> m ProcessID
spawnPID (String -> X ProcessID) -> String -> X ProcessID
forall a b. (a -> b) -> a -> b
$ String -> String
mangle String
cmd
    ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X ()
modifySpawner (([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X ())
-> ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X ()
forall a b. (a -> b) -> a -> b
$ ((ProcessID
p,ManageHook
mh) (ProcessID, ManageHook)
-> [(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]
forall a. a -> [a] -> [a]
:)
 where
    -- TODO this is silly, search for a better solution
    mangle :: String -> String
mangle xs :: String
xs | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
metaChars) String
xs Bool -> Bool -> Bool
|| "exec" Predicate
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
xs = String
xs
              | Bool
otherwise = "exec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
xs
    metaChars :: String
metaChars = "&|;"