tianbar 0.3.2.0 → 0.3.3.0

raw patch · 2 files changed

+85/−1 lines, 2 files

Files

• src/System/Tianbar/DBus.hs +83/−0
• tianbar.cabal +2/−1

@@ -0,0 +1,83 @@+{-# Language OverloadedStrings #-}+module System.Tianbar.DBus where++import Control.Concurrent.MVar+import Control.Monad++import Data.Aeson+import Data.Int+import Data.List+import qualified Data.Map as M+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.Encoding as E+import Data.Word++import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk.WebKit.WebView++import DBus+import DBus.Client++import Network.URI++import System.Tianbar.UriOverride++-- DBus callback override+data DBusState = DBusState { dbusClient :: MVar Client+                           }++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 ++ ")"++instance ToJSON Signal where+    toJSON s = object [ "path"   .= toJSON (formatObjectPath $ signalPath s)+                      , "iface"  .= toJSON (formatInterfaceName $ signalInterface s)+                      , "member" .= toJSON (formatMemberName $ signalMember s)+                      ]++callback :: WebView -> Int -> Signal -> IO ()+callback wk index sig =+    Gtk.postGUIAsync $ webViewExecuteScript wk $ dbusCallback index sig++dbusCallback :: Int -> Signal -> String+dbusCallback index sig =+    "window.dbusCallbacks && "+        ++ "window.dbusCallbacks[" ++ indexStr ++ "](" ++ paramsStr ++ ")"+    where indexStr = show index+          paramsStr = intercalate "," $ map (T.unpack . E.decodeUtf8) [signalStr, bodyStr]+          signalStr = encode $ toJSON sig+          bodyStr = encode $ toJSON $ signalBody sig++dbusOverride :: WebView -> DBusState -> UriOverride+dbusOverride wk dbus = withScheme "dbus:" $ \uri -> do+    case uriPath uri of+        "listen" -> dbusListen wk dbus uri+        _ -> return ()+    returnContent ""+++dbusListen :: WebView -> DBusState -> URI -> IO ()+dbusListen wk dbus 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

@@ -1,5 +1,5 @@ name:                tianbar-version:             0.3.2.0+version:             0.3.3.0 synopsis:            A desktop bar based on WebKit description:   A desktop bar using WebKit for rendering as much as possible.@@ -39,6 +39,7 @@   main-is:             Main.hs   other-modules:       System.Tianbar                      , System.Tianbar.Configuration+                     , System.Tianbar.DBus                      , System.Tianbar.StrutProperties                      , System.Tianbar.Systray                      , System.Tianbar.UriOverride