diff --git a/src/System/Tianbar.hs b/src/System/Tianbar.hs new file mode 100644 --- /dev/null +++ b/src/System/Tianbar.hs @@ -0,0 +1,48 @@ +module System.Tianbar where + +import Graphics.UI.Gtk hiding (Signal) + +import System.Tianbar.Configuration +import System.Tianbar.Systray +import System.Tianbar.StrutProperties +import System.Tianbar.WebKit + +topStrut :: Rectangle -> StrutProperties +topStrut (Rectangle mX mY mW _) = (0, 0, h, 0, 0, 0, 0, 0, x, x + w, 0, 0) + where x = mX + w = mW - 1 + h = barHeight + mY + +main :: IO () +main = do + _ <- initGUI + + Just disp <- displayGetDefault + screen <- displayGetScreen disp myScreen + monitorSize <- screenGetMonitorGeometry screen myMonitor + + window <- windowNew + widgetSetName window appName + + let Rectangle x _ w _ = monitorSize + windowSetTypeHint window WindowTypeHintDock + windowSetScreen window screen + windowSetDefaultSize window w barHeight + windowMove window x 0 + _ <- onRealize window $ + setStrutProperties window $ topStrut monitorSize + + box <- hBoxNew False widgetSpacing + containerAdd window box + + wk <- xmonadWebkitLogNew + boxPackStart box wk PackGrow 0 + + tray <- systrayNew + boxPackEnd box tray PackNatural 0 + + widgetShow window + widgetShow box + + mainGUI + return () diff --git a/src/System/Tianbar/Configuration.hs b/src/System/Tianbar/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/System/Tianbar/Configuration.hs @@ -0,0 +1,17 @@ +module System.Tianbar.Configuration where + +appName :: String +appName = "tianbar" + +myScreen :: Int +myScreen = 0 + +myMonitor :: Int +myMonitor = 0 + +barHeight :: Int +barHeight = 25 + +widgetSpacing :: Int +widgetSpacing = 0 + diff --git a/src/System/Tianbar/StrutProperties.hs b/src/System/Tianbar/StrutProperties.hs new file mode 100644 --- /dev/null +++ b/src/System/Tianbar/StrutProperties.hs @@ -0,0 +1,35 @@ +module System.Tianbar.StrutProperties ( setStrutProperties + , StrutProperties ) where + +import Graphics.UI.Gtk + +import Foreign +import Foreign.C.Types +import Unsafe.Coerce ( unsafeCoerce ) + +type StrutProperties = (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int) + +foreign import ccall "set_strut_properties" + c_set_strut_properties :: Ptr Window -> CLong -> CLong -> CLong -> CLong + -> CLong -> CLong + -> CLong -> CLong + -> CLong -> CLong + -> CLong -> CLong + -> () + +-- | Reserve EWMH struts +setStrutProperties :: Window -> StrutProperties -> IO () +setStrutProperties gtkWindow (left, right, top, bottom, + left_start_y, left_end_y, + right_start_y, right_end_y, + top_start_x, top_end_x, + bottom_start_x, bottom_end_x) = do + let ptrWin = unsafeCoerce gtkWindow :: ForeignPtr Window + let fi = fromIntegral + withForeignPtr ptrWin $ \realPointer -> do + return $ c_set_strut_properties realPointer (fi left) (fi right) (fi top) (fi bottom) + (fi left_start_y) (fi left_end_y) + (fi right_start_y) (fi right_end_y) + (fi top_start_x) (fi top_end_x) + (fi bottom_start_x) (fi bottom_end_x) + diff --git a/src/System/Tianbar/Systray.hs b/src/System/Tianbar/Systray.hs new file mode 100644 --- /dev/null +++ b/src/System/Tianbar/Systray.hs @@ -0,0 +1,25 @@ +-- | This is a very basic system tray widget. That said, it works +-- very well since it is based on eggtraymanager. +module System.Tianbar.Systray ( systrayNew ) where + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Misc.TrayManager + +import System.Tianbar.Configuration + +systrayNew :: IO Widget +systrayNew = do + box <- hBoxNew False 5 + + trayManager <- trayManagerNew + Just screen <- screenGetDefault + _ <- trayManagerManageScreen trayManager screen + + _ <- on trayManager trayIconAdded $ \w -> do + widgetShowAll w + boxPackStart box w PackNatural 0 + + widgetSetSizeRequest box (-1) barHeight + + widgetShowAll box + return (toWidget box) diff --git a/src/System/Tianbar/WebKit.hs b/src/System/Tianbar/WebKit.hs new file mode 100644 --- /dev/null +++ b/src/System/Tianbar/WebKit.hs @@ -0,0 +1,92 @@ +module System.Tianbar.WebKit where + +import Control.Monad + +import Data.List +import Data.List.Split +import Data.List.Utils + +import DBus (fromVariant, Signal(..), parseObjectPath, parseInterfaceName, parseMemberName) +import DBus.Client (listen, matchAny, MatchRule(..), connectSession) + +import Graphics.UI.Gtk hiding (Signal) +import Graphics.UI.Gtk.WebKit.NetworkRequest +import Graphics.UI.Gtk.WebKit.WebView +import Graphics.UI.Gtk.WebKit.WebSettings + +import System.Environment.XDG.BaseDir + +import System.Process + +import System.Tianbar.Configuration + +gsettingsGet :: String -> String -> IO String +gsettingsGet schema key = do + output <- readProcess "gsettings" ["get", schema, key] [] + let len = length output + return $ drop 1 $ take (len - 2) output + +gsettingsPrefix :: String +gsettingsPrefix = "gsettings:" + +setupWebkitLog :: WebView -> IO () +setupWebkitLog wk = do + let matcher = matchAny { matchSender = Nothing + , matchDestination = Nothing + , matchPath = parseObjectPath "/org/xmonad/Log" + , matchInterface = parseInterfaceName "org.xmonad.Log" + , matchMember = parseMemberName "Update" + } + + wsettings <- webViewGetWebSettings wk + set wsettings [webSettingsEnableUniversalAccessFromFileUris := True] + webViewSetWebSettings wk wsettings + + _ <- on wk resourceRequestStarting $ \_ _ nreq _ -> case nreq of + Nothing -> return () + (Just req) -> do + uri_ <- networkRequestGetUri req + case uri_ of + Nothing -> return () + Just uri -> when (gsettingsPrefix `isPrefixOf` uri) $ do + let path = drop (length gsettingsPrefix) uri + let [schema, key] = splitOn "/" path + setting <- gsettingsGet schema key + networkRequestSetUri req $ + "data:text/plain," ++ setting + + htmlFile <- getUserConfigFile appName "index.html" + html <- readFile htmlFile + webViewLoadHtmlString wk html $ "file://" ++ htmlFile + + client <- connectSession + + listen client matcher $ callback wk + +escapeQuotes :: String -> String +escapeQuotes = replace "'" "\\'" . replace "\\" "\\\\" + +callback :: WebView -> Signal -> IO () +callback wk sig = do + let [bdy] = signalBody sig + Just status = fromVariant bdy + postGUIAsync $ webViewExecuteScript wk $ setStatus status + +setStatus :: String -> String +setStatus status = let statusStr = escapeQuotes status in + "window.setXMonadStatus ? window.setXMonadStatus('" ++ statusStr ++ "')" ++ + " : window.XMonadStatus = '" ++ statusStr ++ "'" + +xmonadWebkitLogNew :: IO Widget +xmonadWebkitLogNew = do + l <- webViewNew + + _ <- on l realize $ setupWebkitLog l + + Just disp <- displayGetDefault + screen <- displayGetScreen disp myScreen + (Rectangle _ _ sw _) <- screenGetMonitorGeometry screen myMonitor + _ <- on l sizeRequest $ return (Requisition (sw `div` 2) barHeight) + + widgetShowAll l + return (toWidget l) diff --git a/tianbar.cabal b/tianbar.cabal --- a/tianbar.cabal +++ b/tianbar.cabal @@ -1,5 +1,5 @@ name: tianbar -version: 0.1.2.0 +version: 0.1.3.0 synopsis: A desktop bar based on WebKit description: A desktop bar using WebKit for rendering as much as possible. @@ -15,7 +15,6 @@ executable tianbar default-language: Haskell2010 - main-is: Main.hs build-depends: base ==4.6.* , split ==0.2.* , MissingH ==1.2.* @@ -25,11 +24,17 @@ , webkit ==0.12.* , xdg-basedir ==0.2.* , process ==1.1.* - hs-source-dirs: src pkgconfig-depends: gtk+-2.0 - c-sources: src/gdk_property_change_wrapper.c - ghc-options: -Wall -rtsopts -threaded - ghc-prof-options: -auto-all + hs-source-dirs: src + main-is: Main.hs + other-modules: System.Tianbar + , System.Tianbar.Configuration + , System.Tianbar.StrutProperties + , System.Tianbar.Systray + , System.Tianbar.WebKit + c-sources: src/gdk_property_change_wrapper.c + ghc-options: -Wall -rtsopts -threaded + ghc-prof-options: -auto-all library default-language: Haskell2010