xmonad.hs

   1 import Control.OldException(catchDyn,try)
   2 import XMonad.Util.Run
   3 import Control.Concurrent
   4 import DBus
   5 import DBus.Connection
   6 import DBus.Message
   7 import System.Cmd
   8 import XMonad
   9 import XMonad.Config.Gnome
  10 import XMonad.Hooks.DynamicLog
  11 import XMonad.Layout.Accordion
  12 import XMonad.Layout.Grid
  13 import XMonad.ManageHook
  14 import XMonad.Prompt
  15 import XMonad.Util.EZConfig
  16
  17 main = withConnection Session $ \ dbus -> do
  18   getWellKnownName dbus
  19   xmonad $ gnomeConfig {
  20     focusedBorderColor = "DarkBlue"
  21   , borderWidth        = 3
  22   , manageHook         = manageHook gnomeConfig <+> composeAll managementHooks
  23   , logHook            = dynamicLogWithPP (myPrettyPrinter dbus)
  24   , startupHook        = startupHook gnomeConfig >> liftIO startNitrogen
  25   , layoutHook         = layoutHook gnomeConfig ||| Accordion ||| Grid
  26   }
  27     `removeKeysP`     ["M-p"]
  28     `additionalKeysP` [("M-m",runRDeskPrompt defaultXPConfig)]
  29
  30
  31 -- -----------------------------------------------------------------------------
  32
  33 myPrettyPrinter :: Connection -> PP
  34 myPrettyPrinter dbus = defaultPP {
  35     ppOutput  = outputThroughDBus dbus
  36   , ppTitle   = pangoColor "#003366" . shorten 50 . pangoSanitize
  37   , ppCurrent = pangoColor "#006666" . wrap "[" "]" . pangoSanitize
  38   , ppVisible = pangoColor "#663366" . wrap "(" ")" . pangoSanitize
  39   , ppHidden  = wrap " " " "
  40   , ppUrgent  = pangoColor "red"
  41   }
  42
  43 managementHooks :: [ManageHook]
  44 managementHooks = [
  45     resource  =? "Do"        --> doIgnore
  46   , className =? "rdesktop"  --> doFloat
  47   ]
  48
  49 -- -----------------------------------------------------------------------------
  50
  51 data RDesk = RDesk
  52
  53 instance XPrompt RDesk where
  54   showXPrompt     RDesk = "Remote desktop to:"
  55   commandToComplete _ c = c
  56   nextCompletion      _ = getNextCompletion
  57
  58 runRDeskPrompt :: XPConfig -> X ()
  59 runRDeskPrompt c = mkXPrompt RDesk c (mkComplFunFromList targs) run
  60  where
  61   targs = ["pane.galois.com","porthole.galois.com"]
  62   run s = spawn ("/usr/bin/rdesktop -u GALOIS\\\\awick -g 1250x750 " ++ s)
  63
  64 -- This retry is really awkward, but sometimes DBus won't let us get our
  65 -- name unless we retry a couple times.
  66 getWellKnownName :: Connection -> IO ()
  67 getWellKnownName dbus = tryGetName `catchDyn` (\ (DBus.Error _ _) ->
  68                                                 getWellKnownName dbus)
  69  where
  70   tryGetName = do
  71     namereq <- newMethodCall serviceDBus pathDBus interfaceDBus "RequestName"
  72     addArgs namereq [String "org.xmonad.Log", Word32 5]
  73     sendWithReplyAndBlock dbus namereq 0
  74     return ()
  75
  76 outputThroughDBus :: Connection -> String -> IO ()
  77 outputThroughDBus dbus str = do
  78   let str' = "<span font=\"Terminus 9 Bold\">" ++ str ++ "</span>"
  79   msg <- newSignal "/org/xmonad/Log" "org.xmonad.Log" "Update"
  80   addArgs msg [String str']
  81   send dbus msg 0 `catchDyn` (\ (DBus.Error _ _ ) -> return 0)
  82   return ()
  83
  84 pangoColor :: String -> String -> String
  85 pangoColor fg = wrap left right
  86  where
  87   left  = "<span foreground=\"" ++ fg ++ "\">"
  88   right = "</span>"
  89
  90 pangoSanitize :: String -> String
  91 pangoSanitize = foldr sanitize ""
  92  where
  93   sanitize '>'  acc = "&gt;" ++ acc
  94   sanitize '<'  acc = "&lt;" ++ acc
  95   sanitize '\"' acc = "&quot;" ++ acc
  96   sanitize '&'  acc = "&amp;" ++ acc
  97   sanitize x    acc = x:acc
  98
  99 startNitrogen :: IO ()
 100 startNitrogen = do
 101   threadDelay (5 * 1000 * 1000)
 102   try_ $ rawSystem "nitrogen" ["--restore"]
 103
 104 try_ :: MonadIO m => IO a -> m ()
 105 try_ action = liftIO $ try action >> return ()