packages feed

tianbar 0.3.3.0 → 0.3.4.0

raw patch · 8 files changed

+297/−75 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

scripts/dbus.js view
@@ -2,28 +2,69 @@  * A plugin to receive DBus events.  */ define(['jquery'], function ($) {+  function copyProperties(properties, from, to) {+    $.each(properties, function(_, x) {+      if (x in from) {+        to[x] = from[x];+      }+    });+  }++  function bus(busName) {+    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 data = {+          index: index+        };+        copyProperties(['path', 'iface', 'member'], match, data);+        $.ajax('dbus:' + busName + '/listen', {+          data: data+        });+      },++      /**+       * Call a DBus method.+       * @param params {Object} Method call details ('path', 'iface', 'member',+       * 'destination', 'body')+       * @return {Deferred} A promise to be fulfilled or rejected with the result+       */+      call: function (params) {+        var data = {};+        copyProperties(+            ['path', 'iface', 'member', 'destination', 'body'], params, data);+        var deferred = $.Deferred();++        $.ajax('dbus:' + busName + '/call', {+          data: data+        }).done(function (result) {+          result = JSON.parse(result);+          if (result.Right) {+            deferred.resolve(result.Right);+          } else {+            deferred.reject(result.Left);+          }+        });++        return deferred;+      }+    };+  }+   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+     * Session bus.      */-    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-      });-    }+    session: bus('session'),+    /**+     * System bus.+     */+    system: bus('system')   }; });
+ scripts/power.js view
@@ -0,0 +1,63 @@+/*+ * A plugin to show the power (e.g. battery) state through UPower.+ *+ * Requires 'jquery' to be available through RequireJS.+ */+define(['jquery', './dbus'], function ($, dbus) {+  var self = {+    /**+     * Format an HTML element displaying the device status.+     * @param st {Object} The device status, as returned by UPower+     */+    formatDevice: function (st) {+      // TODO: better default formatting+      return st.Percentage;+    }+  };++  function updatePower() {+    dbus.system.call({+      'destination': 'org.freedesktop.UPower',+      'path': '/org/freedesktop/UPower',+      'iface': 'org.freedesktop.UPower',+      'member': 'EnumerateDevices',+      'body': [+      ]+    }).done(function (devices) {+      devices = devices.body[0];+      var queries = $.map(devices, function(device) {+        return dbus.system.call({+          'destination': 'org.freedesktop.UPower',+          'path': device,+          'iface': 'org.freedesktop.DBus.Properties',+          'member': 'GetAll',+          'body': [+            'string:org.freedesktop.UPower.Device',+          ]+        });+      });+      $.when.apply($, queries).then(function (results) {+        results = Array.prototype.slice.call(arguments, 0);++        var widget = $('.widget-power');+        widget.empty();+        // TODO: externalize styling+        $.each(results, function (_, st) {+          st = st.body[0];+          // Do not show AC power+          if (st.Type === 1) {+            return;+          }+          widget.append(self.formatDevice(st));+        });+      });+    });+  }++  $(document).ready(function () {+    updatePower();+    setInterval(updatePower, 10000);+  });++  return self;+});
scripts/weather.js view
@@ -11,14 +11,10 @@ define(['jquery', 'moment'], function ($, moment) {   var APPID = '41fff6331bf67509b73740427d14c562'; -  var DETAILED_FORECAST = 4;-   var SECOND = 1000; // ms   var MINUTE = 60 * SECOND;   var HOUR = 60 * MINUTE; -  var NEWLINE = '
';-   var coords;   var weather;   var forecast;@@ -112,7 +108,6 @@     if (forecastWindow !== null && !forecastWindow.closed) {       var forecastBody = $(forecastWindow.document.body);       forecastBody.empty();-      var forecastHtml = [];       if (forecast) {         // Split forecast by days         var days = [];
scripts/xmonad.js view
@@ -13,13 +13,13 @@ define(['jquery', './dbus'], function ($, dbus) {   var change = $.Callbacks(); -  dbus.listen(+  dbus.session.listen(     {       path: '/org/xmonad/Log',       iface: 'org.xmonad.Log',       member: 'Update'     },-    function (signal, body) {+    function (_, body) {       var st = body[0];       $('.widget-xmonad').html(st);       change.fire(st);
src/System/Tianbar/DBus.hs view
@@ -4,9 +4,10 @@ import Control.Concurrent.MVar import Control.Monad -import Data.Aeson+import Data.Aeson hiding (Array) import Data.Int import Data.List+import Data.List.Split import qualified Data.Map as M import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Encoding as E@@ -23,31 +24,105 @@ import System.Tianbar.UriOverride  -- DBus callback override-data DBusState = DBusState { dbusClient :: MVar Client++type DBusClient = MVar Client++data DBusState = DBusState { dbusSession :: DBusClient+                           , dbusSystem :: DBusClient                            } +initDBusState :: IO DBusState+initDBusState = do+    session <- connectSession >>= newMVar+    system <- connectSystem >>= newMVar+    return $ DBusState session system++reloadDBusState :: DBusState -> IO ()+reloadDBusState dbus = do+    modifyMVar_ (dbusSession dbus) $ \client -> do+        disconnect client+        connectSession+    modifyMVar_ (dbusSystem dbus) $ \client -> do+        disconnect client+        connectSystem+ instance ToJSON Variant where-    toJSON v = let t = variantType v in-        case t of-            TypeBoolean -> let Just b = fromVariant v :: Maybe Bool in toJSON b-            TypeString -> let Just s = fromVariant v :: Maybe String in toJSON s-            TypeWord8 -> let Just i = fromVariant v :: Maybe Word8 in toJSON i-            TypeWord16 -> let Just i = fromVariant v :: Maybe Word16 in toJSON i-            TypeWord32 -> let Just i = fromVariant v :: Maybe Word32 in toJSON i-            TypeWord64 -> let Just i = fromVariant v :: Maybe Word64 in toJSON i-            TypeInt16 -> let Just i = fromVariant v :: Maybe Int16 in toJSON i-            TypeInt32 -> let Just i = fromVariant v :: Maybe Int32 in toJSON i-            TypeInt64 -> let Just i = fromVariant v :: Maybe Int64 in toJSON i-            -- TODO: more types-            _ -> error $ "Variant type not supported: "-                      ++ show v ++ " (type: " ++ show t ++ ")"+    toJSON v = case variantType v of+        TypeBoolean -> let Just b = fromVariant v :: Maybe Bool in toJSON b+        TypeWord8 -> let Just i = fromVariant v :: Maybe Word8 in toJSON i+        TypeWord16 -> let Just i = fromVariant v :: Maybe Word16 in toJSON i+        TypeWord32 -> let Just i = fromVariant v :: Maybe Word32 in toJSON i+        TypeWord64 -> let Just i = fromVariant v :: Maybe Word64 in toJSON i+        TypeInt16 -> let Just i = fromVariant v :: Maybe Int16 in toJSON i+        TypeInt32 -> let Just i = fromVariant v :: Maybe Int32 in toJSON i+        TypeInt64 -> let Just i = fromVariant v :: Maybe Int64 in toJSON i+        TypeDouble -> let Just i = fromVariant v :: Maybe Double in toJSON i+        TypeString -> let Just s = fromVariant v :: Maybe String in toJSON s +        TypeSignature -> let Just s = fromVariant v :: Maybe Signature in+            toJSON $ formatSignature s+        TypeObjectPath -> let Just p = fromVariant v :: Maybe ObjectPath in+            toJSON $ formatObjectPath p++        TypeVariant -> let Just n = fromVariant v :: Maybe Variant in toJSON n+        TypeArray _ -> let Just a = fromVariant v :: Maybe Array in+            toJSON $ arrayItems a+        TypeDictionary _ _ -> let Just d = fromVariant v :: Maybe Dictionary in+            toJSON $ M.fromList $ map variantStringKey $ dictionaryItems d+        TypeStructure _ -> let Just a = fromVariant v :: Maybe Structure in+            toJSON $ structureItems a++variantString :: Variant -> String+variantString v = s+    where Just s = case variantType v of+                       TypeString -> fromVariant v+                       TypeVariant -> Just $ variantString v'+                           where Just v' = fromVariant v+                       _ -> Just $ show v++variantStringKey :: (Variant, Variant) -> (String, Variant)+variantStringKey (k, v) = (variantString k, v)++instance ToJSON ObjectPath where+    toJSON = toJSON . formatObjectPath++instance ToJSON InterfaceName where+    toJSON = toJSON . formatInterfaceName++instance ToJSON MemberName where+    toJSON = toJSON . formatMemberName+ instance ToJSON Signal where-    toJSON s = object [ "path"   .= toJSON (formatObjectPath $ signalPath s)-                      , "iface"  .= toJSON (formatInterfaceName $ signalInterface s)-                      , "member" .= toJSON (formatMemberName $ signalMember s)+    toJSON s = object [ "path"   .= toJSON (signalPath s)+                      , "iface"  .= toJSON (signalInterface s)+                      , "member" .= toJSON (signalMember s)                       ] +instance ToJSON ErrorName where+    toJSON = toJSON . formatErrorName++instance ToJSON Serial where+    toJSON = toJSON . serialValue++instance ToJSON BusName where+    toJSON = toJSON . formatBusName++instance ToJSON MethodError where+    toJSON e = object [ "name"        .= toJSON (methodErrorName e)+                      , "serial"      .= toJSON (methodErrorSerial e)+                      , "sender"      .= toJSON (methodErrorSender e)+                      , "destination" .= toJSON (methodErrorDestination e)+                      , "body"        .= toJSON (methodErrorBody e)+                      , "message"     .= toJSON (methodErrorMessage e)+                      ]++instance ToJSON MethodReturn where+    toJSON r = object [ "serial"      .= toJSON (methodReturnSerial r)+                      , "sender"      .= toJSON (methodReturnSender r)+                      , "destination" .= toJSON (methodReturnDestination r)+                      , "body"        .= toJSON (methodReturnBody r)+                      ]+ callback :: WebView -> Int -> Signal -> IO () callback wk index sig =     Gtk.postGUIAsync $ webViewExecuteScript wk $ dbusCallback index sig@@ -61,23 +136,61 @@           signalStr = encode $ toJSON sig           bodyStr = encode $ toJSON $ signalBody sig +returnJSON :: (ToJSON a) => a -> IO String+returnJSON = returnContent . T.unpack . E.decodeUtf8 . encode . toJSON+ dbusOverride :: WebView -> DBusState -> UriOverride dbusOverride wk dbus = withScheme "dbus:" $ \uri -> do-    case uriPath uri of-        "listen" -> dbusListen wk dbus uri-        _ -> return ()-    returnContent ""-+    let [busName, busCall] = splitOn "/" (uriPath uri)+    let bus = uriBus busName dbus+    withMVar bus $ \client -> case busCall of+        "listen" -> do+            dbusListen wk client uri+            returnContent ""+        "call" -> do+            result <- dbusCall wk client uri+            returnJSON result+        _ -> returnContent "" -dbusListen :: WebView -> DBusState -> URI -> IO ()-dbusListen wk dbus uri = do+dbusListen :: WebView -> Client -> URI -> IO ()+dbusListen wk client uri = do     let params = parseQuery uri-    let matcher = matchAny { matchSender = Nothing-                           , matchDestination = Nothing-                           , matchPath = M.lookup "path" params >>= parseObjectPath-                           , matchInterface = M.lookup "iface" params >>= parseInterfaceName-                           , matchMember = M.lookup "member" params >>= parseMemberName-                           }-    let (Just index) = liftM read $ M.lookup "index" params-    withMVar (dbusClient dbus) $ \client ->-        listen client matcher $ callback wk index+    let matcher = matchRuleUri uri+    let (Just index) = liftM read $ lookupQueryParam "index" params+    _ <- addMatch client matcher $ callback wk index+    return ()++dbusCall :: WebView -> Client -> URI -> IO (Either MethodError MethodReturn)+dbusCall _ client uri = do+    let mcall = methodCallUri uri+    call client mcall++uriBus :: String -> DBusState -> MVar Client+uriBus "session" = dbusSession+uriBus "system" = dbusSystem+uriBus _ = error "Unknown bus"++matchRuleUri :: URI -> MatchRule+matchRuleUri uri = matchAny { matchSender = Nothing+                            , matchDestination = Nothing+                            , matchPath = lookupQueryParam "path" params >>= parseObjectPath+                            , matchInterface = lookupQueryParam "iface" params >>= parseInterfaceName+                            , matchMember = lookupQueryParam "member" params >>= parseMemberName+                            }+    where params = parseQuery uri++variantFromString :: String -> Variant+variantFromString param = case splitOn ":" param of+    ["string", str] -> toVariant str+    _ -> error "Invalid variant string"++methodCallUri :: URI -> MethodCall+methodCallUri uri = (methodCall callPath iface member) { methodCallBody = body+                                                       , methodCallDestination = dest+                                                       }+    where params = parseQuery uri+          (Just callPath) = parseObjectPath $ getQueryParam "path" params+          (Just iface) = parseInterfaceName $ getQueryParam "iface" params+          (Just member) = parseMemberName $ getQueryParam "member" params+          body = map variantFromString $ getQueryParams "body[]" params+          dest = lookupQueryParam "destination" params >>= parseBusName
src/System/Tianbar/UriOverride.hs view
@@ -4,6 +4,7 @@  import Data.List.Split import qualified Data.Map as M+import Data.Maybe  import Network.URI @@ -18,12 +19,27 @@ mergeOverrides :: [UriOverride] -> UriOverride mergeOverrides overrides = foldr mplus Nothing . flip map overrides . flip ($) -parseQuery :: URI -> M.Map String String-parseQuery = M.fromList-           . map ((\[a, b] -> (a, unEscapeString b)) . splitOn "=")+multiMap :: [(String, String)] -> M.Map String [String]+multiMap = foldr addElement M.empty+    where addElement (k, v) = M.insertWith (++) k [v]++parseQuery :: URI -> M.Map String [String]+parseQuery = multiMap+           . map ((\[a, b] -> (a, b)) . map unEscapeString . splitOn "=")            . splitOn "&"            . tail            . uriQuery++lookupQueryParam :: String -> M.Map String [String] -> Maybe String+lookupQueryParam key queryMap = M.lookup key queryMap >>= \value -> case value of+    [v] -> Just v+    _ -> Nothing++getQueryParam :: String -> M.Map String [String] -> String+getQueryParam key = fromJust . lookupQueryParam key++getQueryParams :: String -> M.Map String [String] -> [String]+getQueryParams key = fromMaybe [] . M.lookup key  returnContent :: String -> IO String returnContent content = return $ "data:text/plain," ++ content
src/System/Tianbar/WebKit.hs view
@@ -1,14 +1,10 @@ {-# Language OverloadedStrings #-} module System.Tianbar.WebKit where -import Control.Concurrent.MVar import Control.Monad  import Data.List.Split --- TODO: Move state to DBus override-import DBus.Client (connectSession, disconnect)- import Graphics.UI.Gtk hiding (disconnect, Signal, Variant) import Graphics.UI.Gtk.WebKit.NetworkRequest import Graphics.UI.Gtk.WebKit.WebSettings@@ -55,12 +51,9 @@     webViewSetWebSettings wk wsettings      -- Connect DBus listener, and reconnect on reloads-    dbus <- liftM DBusState $ connectSession >>= newMVar-+    dbus <- initDBusState     _ <- on wk loadStarted $ \_ ->-        modifyMVar_ (dbusClient dbus) $ \client -> do-            disconnect client-            connectSession+        reloadDBusState dbus      -- Process the special overrides     let allOverrides = mergeOverrides [ gsettingsUriOverride
tianbar.cabal view
@@ -1,5 +1,5 @@ name:                tianbar-version:             0.3.3.0+version:             0.3.4.0 synopsis:            A desktop bar based on WebKit description:   A desktop bar using WebKit for rendering as much as possible.@@ -15,6 +15,7 @@ data-files:          README.md                    , scripts/location_shim.js                    , scripts/dbus.js+                   , scripts/power.js                    , scripts/time.js                    , scripts/weather.js                    , scripts/xmonad.js