tianbar 0.3.0.0 → 0.3.1.0

raw patch · 8 files changed

+97/−81 lines, 8 filesdep +aesondep +containersdep +network

Dependencies added: aeson, containers, network, text

Files

• README.md +3/−2
• scripts/dbus.js +29/−0
• scripts/xmonad.js +20/−19
• src/System/Tianbar.hs +1/−1
• src/System/Tianbar/StrutProperties.hs +1/−1
• src/System/Tianbar/WebKit.hs +33/−53
• src/System/Tianbar/XMonadLog.hs +1/−1
• tianbar.cabal +9/−4

@@ -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 ----------------

@@ -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+      });+    }+  };+});

@@ -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+  }; });

@@ -35,7 +35,7 @@     box <- hBoxNew False widgetSpacing     containerAdd window box -    wk <- xmonadWebkitLogNew+    wk <- tianbarWebkitNew     boxPackStart box wk PackGrow 0      tray <- systrayNew

@@ -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)

@@ -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

@@ -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

@@ -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