diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,6 +5,8 @@ using WebKit as its rendering engine, meaning that the entire look and feel is customizable using HTML, CSS and JavaScript. +![Screenshot - left part](tianbar.png) ![Screenshot - right part](tianbar2.png) + Usage ----- @@ -39,8 +41,7 @@ * HTML5 geolocation API does not work. A shim, which uses [freegeoip.net][freegeoip], is provided instead. * Interaction with the displayed Web page is limited. For example, text fields - are not active if there are other windows on the screen, and opening new - windows does not work. + are not active if there are other windows on the screen. Acknowledgements ---------------- diff --git a/scripts/dbus.js b/scripts/dbus.js new file mode 100644 --- /dev/null +++ b/scripts/dbus.js @@ -0,0 +1,29 @@ +/* + * A plugin to receive DBus events. + */ +define(['jquery'], function ($) { + return { + /** + * Listen for a particular DBus event. + * @param match {Object} DBus match conditions ('path', 'iface', 'member') + * @param handler {Function} The function to call upon receiving the event + */ + listen: function (match, handler) { + window.dbusCallbacks = window.dbusCallbacks || []; + var index = window.dbusCallbacks.push(handler) - 1; + var params = { + index: index + }; + for (var x in {'path': undefined, + 'iface': undefined, + 'member': undefined}) { + if (x in match) { + params[x] = match[x]; + } + } + $.ajax('dbus:listen', { + data: params + }); + } + }; +}); diff --git a/scripts/xmonad.js b/scripts/xmonad.js --- a/scripts/xmonad.js +++ b/scripts/xmonad.js @@ -5,27 +5,28 @@ * * The status appears in elements matching class 'widget-xmonad'. * + * The 'change' callback ($.Callbacks) object is fired whenever the + * status changes. + * * The plugin requires 'jquery' to be available through RequireJS. */ -define(['jquery'], function ($) { - function setStatus(st) { - $('.widget-xmonad').html(st); - } +define(['jquery', './dbus'], function ($, dbus) { + var change = $.Callbacks(); - // Currently, a check for this function (and if it doesn't exist, - // window.XMonadStatus) is hardcoded in Tianbar. A better solution - // would be to expose an interface for subscribing to DBus connections - // from JavaScript. - window.setXMonadStatus = function (st) { - window.XMonadStatus = undefined; - setStatus(st); - }; + dbus.listen( + { + path: '/org/xmonad/Log', + iface: 'org.xmonad.Log', + member: 'Update' + }, + function (signal, body) { + var st = body[0]; + $('.widget-xmonad').html(st); + change.fire(st); + } + ); - $(document).ready(function () { - window.setTimeout(function () { - if (window.XMonadStatus) { - window.setXMonadStatus(window.XMonadStatus); - } - }, 1000); - }); + return { + change: change + }; }); diff --git a/src/System/Tianbar.hs b/src/System/Tianbar.hs --- a/src/System/Tianbar.hs +++ b/src/System/Tianbar.hs @@ -35,7 +35,7 @@ box <- hBoxNew False widgetSpacing containerAdd window box - wk <- xmonadWebkitLogNew + wk <- tianbarWebkitNew boxPackStart box wk PackGrow 0 tray <- systrayNew diff --git a/src/System/Tianbar/StrutProperties.hs b/src/System/Tianbar/StrutProperties.hs --- a/src/System/Tianbar/StrutProperties.hs +++ b/src/System/Tianbar/StrutProperties.hs @@ -26,7 +26,7 @@ bottom_start_x, bottom_end_x) = do let ptrWin = unsafeCoerce gtkWindow :: ForeignPtr Window let fi = fromIntegral - withForeignPtr ptrWin $ \realPointer -> do + withForeignPtr ptrWin $ \realPointer -> 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) diff --git a/src/System/Tianbar/WebKit.hs b/src/System/Tianbar/WebKit.hs --- a/src/System/Tianbar/WebKit.hs +++ b/src/System/Tianbar/WebKit.hs @@ -1,56 +1,49 @@ +{-# Language OverloadedStrings #-} module System.Tianbar.WebKit where +import Control.Concurrent.MVar 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) +-- TODO: Move state to DBus override +import DBus.Client (connectSession, disconnect) -import Graphics.UI.Gtk hiding (Signal) +import Graphics.UI.Gtk hiding (disconnect, Signal, Variant) import Graphics.UI.Gtk.WebKit.NetworkRequest import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.WebKit.WebWindowFeatures +import Network.URI + import System.Environment.XDG.BaseDir import System.Process import System.Tianbar.Configuration +import System.Tianbar.DBus +import System.Tianbar.UriOverride import Paths_tianbar +-- GSettings URI override 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 -type UriOverride = String -> Maybe (IO String) - -withPrefix :: String -> (String -> IO String) -> UriOverride -withPrefix prefix func uri - | prefix `isPrefixOf` uri = Just $ func $ drop (length prefix) uri - | otherwise = Nothing - gsettingsUriOverride :: UriOverride -gsettingsUriOverride = withPrefix "gsettings:" $ \path -> do - let [schema, key] = splitOn "/" path +gsettingsUriOverride = withScheme "gsettings:" $ \uri -> do + let [schema, key] = splitOn "/" $ uriPath uri setting <- gsettingsGet schema key - return $ "data:text/plain," ++ setting + returnContent setting +-- Data directory override dataFileOverride :: UriOverride -dataFileOverride = withPrefix "tianbar:" $ \path -> do - liftM ("file://" ++) $ getDataFileName path - -uriOverrides :: [UriOverride] -uriOverrides = [gsettingsUriOverride, dataFileOverride] - -allOverrides :: UriOverride -allOverrides = foldr mplus Nothing . flip map uriOverrides . flip ($) +dataFileOverride = withScheme "tianbar:" $ \uri -> + liftM ("file://" ++) $ getDataFileName $ uriPath uri tianbarWebView :: IO WebView tianbarWebView = do @@ -61,7 +54,19 @@ set wsettings [webSettingsEnableUniversalAccessFromFileUris := True] webViewSetWebSettings wk wsettings + -- Connect DBus listener, and reconnect on reloads + dbus <- liftM DBusState $ connectSession >>= newMVar + + _ <- on wk loadStarted $ \_ -> + modifyMVar_ (dbusClient dbus) $ \client -> do + disconnect client + connectSession + -- Process the special overrides + let allOverrides = mergeOverrides [ gsettingsUriOverride + , dataFileOverride + , dbusOverride wk dbus + ] _ <- on wk resourceRequestStarting $ \_ _ nreq _ -> case nreq of Nothing -> return () (Just req) -> do @@ -109,42 +114,17 @@ return wk -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" - } - +loadIndexPage :: WebView -> IO () +loadIndexPage wk = do 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 +tianbarWebkitNew :: IO Widget +tianbarWebkitNew = do l <- tianbarWebView - _ <- on l realize $ setupWebkitLog l + _ <- on l realize $ loadIndexPage l Just disp <- displayGetDefault screen <- displayGetScreen disp myScreen diff --git a/src/System/Tianbar/XMonadLog.hs b/src/System/Tianbar/XMonadLog.hs --- a/src/System/Tianbar/XMonadLog.hs +++ b/src/System/Tianbar/XMonadLog.hs @@ -100,7 +100,7 @@ tianbarMarkup :: MarkupRenderer tianbarMarkup layout title workspaces _ _ = do H.span ! A.class_ (toValue "workspaces") $ - mapM_ wsHtml $ workspaces + mapM_ wsHtml workspaces H.span ! A.class_ (toValue "layout") $ toMarkup layout H.span ! A.class_ (toValue "title") $ toMarkup title where diff --git a/tianbar.cabal b/tianbar.cabal --- a/tianbar.cabal +++ b/tianbar.cabal @@ -1,5 +1,5 @@ name: tianbar -version: 0.3.0.0 +version: 0.3.1.0 synopsis: A desktop bar based on WebKit description: A desktop bar using WebKit for rendering as much as possible. @@ -14,6 +14,7 @@ cabal-version: >=1.10 data-files: README.md , scripts/location_shim.js + , scripts/dbus.js , scripts/time.js , scripts/weather.js , scripts/xmonad.js @@ -21,14 +22,18 @@ executable tianbar default-language: Haskell2010 build-depends: base >3 && <5 - , split ==0.2.* - , MissingH ==1.2.* + , aeson ==0.6.* + , containers ==0.5.* , dbus ==0.10.* , gtk ==0.12.* , gtk-traymanager ==0.1.* + , MissingH ==1.2.* + , network ==2.4.* + , process ==1.1.* + , split ==0.2.* + , text ==0.11.* , webkit ==0.12.* , xdg-basedir ==0.2.* - , process ==1.1.* pkgconfig-depends: gtk+-2.0 hs-source-dirs: src main-is: Main.hs