summaryrefslogtreecommitdiffstats
path: root/XMonad/Stockholm/Shutdown.hs
blob: 373214e252fcf647b6f5c3ba4ed006a019bbfe3c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
{-# LANGUAGE LambdaCase #-}

module XMonad.Stockholm.Shutdown
    ( newShutdownEventHandler
    , shutdown
    )
  where

import Control.Concurrent (threadDelay)
import Control.Monad (forever, when)
import Data.Monoid (All(All))
import System.Exit (exitSuccess)
import System.FilePath ((</>))
import System.IO.Error (isDoesNotExistError, tryIOError)
import System.IO (hPutStrLn, stderr)
import System.Posix.Process (getProcessID)
import System.Posix.Signals (nullSignal, signalProcess)
import System.Posix.Types (ProcessID)
import XMonad

newShutdownEventHandler :: IO (Event -> X All)
newShutdownEventHandler = do
    writeProcessIDToFile
    return handleShutdownEvent

handleShutdownEvent :: Event -> X All
handleShutdownEvent = \case
  ClientMessageEvent { ev_message_type = mt } -> do
    isShutdownEvent <- (mt ==) <$> getAtom "XMONAD_SHUTDOWN"
    when isShutdownEvent $ do
      broadcastMessage ReleaseResources
      writeStateToFile
      io exitSuccess >> return ()
    return (All (not isShutdownEvent))
  _ ->
    return (All True)

sendShutdownEvent :: IO ()
sendShutdownEvent = do
    dpy <- openDisplay ""
    rw <- rootWindow dpy $ defaultScreen dpy
    a <- internAtom dpy "XMONAD_SHUTDOWN" False
    allocaXEvent $ \e -> do
        setEventType e clientMessage
        setClientMessageEvent e rw a 32 0 currentTime
        sendEvent dpy rw False structureNotifyMask e
    sync dpy False

shutdown :: IO ()
shutdown = do
    pid <- readProcessIDFromFile
    sendShutdownEvent
    hPutStrLn stderr ("waiting for: " <> show pid)
    result <- tryIOError (waitProcess pid)
    if isSuccess result
      then hPutStrLn stderr ("result: " <> show result <> " [AKA success^_^]")
      else hPutStrLn stderr ("result: " <> show result)
  where
    isSuccess = either isDoesNotExistError (const False)

waitProcess :: ProcessID -> IO ()
waitProcess pid = forever (signalProcess nullSignal pid >> threadDelay 10000)

--
-- PID file stuff
--

getProcessIDFileName :: (Functor m, MonadIO m) => m FilePath
getProcessIDFileName = (</> "xmonad.pid") <$> getXMonadDataDir

writeProcessIDToFile :: IO ()
writeProcessIDToFile = do
    pidFileName <- getProcessIDFileName
    pid <- getProcessID
    writeFile pidFileName (show pid)

readProcessIDFromFile :: IO ProcessID
readProcessIDFromFile = do
    pidFileName <- getProcessIDFileName
    read <$> readFile pidFileName