tianbar 0.4.8.0 → 1.0.0.0
raw patch · 31 files changed
+944/−441 lines, 31 filesdep +bytestringdep +filepathdep +gi-gdkdep −gtkdep −gtk-traymanagerdep −happstack-serverdep ~aesondep ~blaze-htmldep ~blaze-markup
Dependencies added: bytestring, filepath, gi-gdk, gi-gio, gi-glib, gi-gtk, gi-webkit2, haskell-gi-base, http-types, lens, mime-types, mtl
Dependencies removed: gtk, gtk-traymanager, happstack-server, network-uri, webkit
Dependency ranges changed: aeson, blaze-html, blaze-markup, containers, dbus, directory, network, process, random, split, text, transformers, utf8-string, xdg-basedir
Files
- README.md +6/−2
- scripts/dbus.js +54/−9
- scripts/ibus.js +80/−0
- scripts/power.js +7/−4
- scripts/socket.js +3/−6
- scripts/tianbar.js +10/−9
- scripts/volume.js +24/−3
- scripts/weather.js +4/−2
- scripts/xmonad.js +12/−8
- src/System/Tianbar.hs +41/−24
- src/System/Tianbar/Callbacks.hs +75/−19
- src/System/Tianbar/Configuration.hs +0/−7
- src/System/Tianbar/Plugin.hs +74/−3
- src/System/Tianbar/Plugin/All.hs +18/−0
- src/System/Tianbar/Plugin/Combined.hs +15/−7
- src/System/Tianbar/Plugin/DBus.hs +95/−55
- src/System/Tianbar/Plugin/DBus/FromData.hs +7/−9
- src/System/Tianbar/Plugin/DBus/JSON.hs +2/−1
- src/System/Tianbar/Plugin/DataDirectory.hs +0/−20
- src/System/Tianbar/Plugin/ExecuteCommand.hs +24/−0
- src/System/Tianbar/Plugin/FileSystem.hs +40/−0
- src/System/Tianbar/Plugin/GSettings.hs +4/−6
- src/System/Tianbar/Plugin/Socket.hs +36/−33
- src/System/Tianbar/RequestResponse.hs +93/−0
- src/System/Tianbar/Server.hs +20/−55
- src/System/Tianbar/StrutProperties.hs +64/−20
- src/System/Tianbar/Systray.hs +0/−25
- src/System/Tianbar/Utils.hs +0/−6
- src/System/Tianbar/WebKit.hs +101/−54
- src/gdk_property_change_wrapper.c +0/−28
- tianbar.cabal +35/−26
README.md view
@@ -5,13 +5,13 @@ using WebKit as its rendering engine, meaning that the entire look and feel is customizable using HTML, CSS and JavaScript. - + Usage ----- Tianbar will show `index.html` from its [XDG configuration directory][xdg]-(usually `$HOME/.config/taffybar`). It it up to you to create that, add styles,+(usually `$HOME/.config/tianbar`). It it up to you to create that, add styles, widgets and other behavior. A small collection of widgets written in JavaScript is bundled with Tianbar,@@ -21,6 +21,10 @@ For an example of RequireJS configuration, see the [example index.html](index.html).++### IBus++Displays the status of IBus input method. ### Power
scripts/dbus.js view
@@ -19,19 +19,16 @@ * 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- * @returns {Event} A Tianbar event object+ * @returns {Deferred} Promise to be fulfilled with a Tianbar event object */ listen: function (match) {- var evt = tianbar.createEvent();- var data = {- index: evt.index- };+ var data = {}; copyProperties(['path', 'iface', 'member'], match, data);- $.ajax('tianbar:///dbus/' + busName + '/listen', {+ return $.ajax('tianbar:///dbus/' + busName + '/listen', { data: data+ }).then(tianbar.createEvent).then(function (evt) {+ return evt.callback; });-- return evt.callback; }, /**@@ -72,10 +69,54 @@ }); return deferred;+ },++ /**+ * Get an object property.+ * @param destination {String} Destination+ * @param path {String} Path+ * @param object {String} Object to get the property of+ * @param property {String} Property to get+ * @return {Deferred} A promise to be fulfilled or rejected with the+ * result+ */+ getProperty: function (destination, path, object, property) {+ return this.call({+ 'destination': destination,+ 'path': path,+ 'iface': 'org.freedesktop.DBus.Properties',+ 'member': 'Get',+ 'body': [+ 'string:' + object,+ 'string:' + property+ ]+ }).then(function (result) {+ return result.body[0];+ }); } }; } + /**+ * Connect to an arbitrary bus.+ * @param address {String} Bus address+ * 'destination', 'body')+ * @return {Deferred} A promise to be fulfilled with the bus object+ */+ function connectBus(address) {+ // random name+ var name = new Date().getTime();++ return $.ajax('tianbar:///dbus/connect', {+ data: {+ name: name,+ address: address+ }+ }).then(function () {+ return bus(name);+ });+ }+ return { /** * Session bus.@@ -84,6 +125,10 @@ /** * System bus. */- system: bus('system')+ system: bus('system'),+ /**+ * Connect an arbitrary bus.+ */+ connect: connectBus }; });
+ scripts/ibus.js view
@@ -0,0 +1,80 @@+/*+ * A plugin to show status of IBus.+ *+ * Requires 'jquery' to be available through RequireJS.+ */+define(['jquery', './dbus'], function ($, dbus) {+ "use strict";++ var self = {};++ self.widget = function () {+ return $('.widget-ibus');+ };++ self.updated = $.Callbacks();++ // IBus DBus connection+ var bus;++ // Display the status of the input method+ function display() {+ var widget = self.widget();++ bus.getProperty(+ 'org.freedesktop.IBus',+ '/org/freedesktop/IBus',+ 'org.freedesktop.IBus',+ 'GlobalEngine'+ ).then(function (result) {+ var imeName = result[3];+ var languageCode = result[5];+ var imeIcon = result[8];+ var imeSymbol = result[12];++ widget.empty();++ if (imeSymbol) {+ widget.text(imeSymbol);+ } else if (imeIcon) {+ if (!/\//.test(imeIcon)) {+ imeIcon = '/usr/share/icons/hicolor/scalable/apps/' + imeIcon + '.svg';+ }+ widget.append($('<img/>')+ .attr('src', 'tianbar:///root/' + imeIcon)+ .css({'height': '20px'}));+ } else {+ widget.text(languageCode);+ }++ widget+ .attr('title', imeName)+ .css({+ 'display': 'inline-block',+ 'vertical-align': 'middle',+ 'width': '25px'+ });++ self.updated.fire();+ });+ }++ $(document).ready(function () {+ $.ajax('tianbar:///execute', {+ data: {+ command: 'ibus address'+ }+ }).then(function (address) {+ address = address.trim();+ dbus.connect(address).then(function (connectedBus) {+ bus = connectedBus;+ display();+ bus.listen({ member: 'GlobalEngineChanged' }).then(function (evt) {+ evt.add(display);+ });+ });+ });+ });++ return self;+});
scripts/power.js view
@@ -239,10 +239,11 @@ $.each(devices, function(_, device) { dbus.system.listen( { path: device }- ).add(function() {+ ).then(function (evt) {+ evt.add(function() { self.refreshDevice(device);- }- );+ });+ }); self.refreshDevice(device); }); });@@ -268,7 +269,9 @@ $(document).ready(function () { dbus.system.listen( { path: '/org/freedesktop/UPower' }- ).add(self.refresh);+ ).then(function (evt) {+ evt.add(self.refresh);+ }); self.refresh(); });
scripts/socket.js view
@@ -11,15 +11,12 @@ * @return {Object} A socket object */ return function (path) {- var evt = tianbar.createEvent();- return $.ajax('tianbar:///socket/connect', { data: {- callbackIndex: evt.index, path: path, random: new Date().getTime() }- }).then(function () {+ }).then(tianbar.createEvent).then(function (evt) { return { /** * Send data to a socket.@@ -28,7 +25,7 @@ send: function (data) { $.ajax('tianbar:///socket/send', { data: {- callbackIndex: evt.index,+ callbackIndex: evt.callbackIndex, data: data, random: new Date().getTime() }@@ -44,7 +41,7 @@ close: function () { $.ajax('tianbar:///socket/close', { data: {- callbackIndex: evt.index,+ callbackIndex: evt.callbackIndex, random: new Date().getTime() } });
scripts/tianbar.js view
@@ -4,21 +4,22 @@ * Requires 'jquery' to be available through RequireJS. */ define(['jquery'], function ($) {- /**- * Create a new server event.- * @return {Object} 'index' for the event index to supply to Tianbar; 'callback' for the jQuery callback object- */ "use strict"; var events = window.tianbarEvents = window.tianbarEvents || []; - function createEvent() {- var evt = $.Callbacks();+ /**+ * Create a new server event.+ * @param response {Object} Server response with the callback index+ * @returns {Object} 'callback' for the jQuery callback object; 'callbackIndex' for the event index to supply to Tianbar+ */+ function createEvent(response) {+ var callbackIndex = JSON.parse(response).callbackIndex; - var index = events.push(evt) - 1;+ var evt = events[callbackIndex] = $.Callbacks(); return {- index: index,- callback: evt+ callback: evt,+ callbackIndex: callbackIndex }; }
scripts/volume.js view
@@ -15,16 +15,27 @@ var WAVES = 5; + var self = {};++ self.settings_command = 'gnome-control-center sound &';+ function uid() {- return $.ajax('/proc/self/status')+ return $.ajax('tianbar:///root/proc/self/status') .then(function (result) { return +UID_RE.exec(result)[1]; }); } - uid().then(function (uid) {+ $.when(+ $.ajax('tianbar:///execute', {+ data: {+ command: 'pacmd load-module module-cli-protocol-unix'+ }+ }),+ uid()+ ).then(function (_, uid) { return socket('/var/run/user/' + uid + '/pulse/cli');- }).done(function (pulseSocket) {+ }).then(function (pulseSocket) { pulseSocket.recv.add(function (dump) { var mute = MUTE_RE.exec(dump)[1] === "yes"; var volume = parseInt(VOLUME_RE.exec(dump)[1], 16) / MAX_VOLUME;@@ -77,6 +88,14 @@ widget.attr('title', percentage + '%'); window.setTimeout(requestDump, 1000);++ widget.click(function () {+ $.ajax('tianbar:///execute', {+ data: {+ command: 'gnome-control-center sound &'+ }+ });+ }); }); function requestDump () {@@ -85,4 +104,6 @@ requestDump(); });++ return self; });
scripts/weather.js view
@@ -82,9 +82,11 @@ forecastWindow = window.open('about:blank', 'forecast', [ 'left=' + offset.left,- 'top=' + offset.top,+ 'top=' + $(window).height(),+ 'width=200',+ 'height=200', ''- ].join(';'));+ ].join(',')); } else { forecastWindow.close(); }
scripts/xmonad.js view
@@ -14,14 +14,18 @@ "use strict"; var change = $.Callbacks(); - dbus.session.listen({- path: '/org/xmonad/Log',- iface: 'org.xmonad.Log',- member: 'Update'- }).add(function (ev) {- var st = ev.body[0];- $('.widget-xmonad').html(st);- change.fire(st);+ $(document).ready(function () {+ dbus.session.listen({+ path: '/org/xmonad/Log',+ iface: 'org.xmonad.Log',+ member: 'Update'+ }).then(function (evt) {+ evt.add(function (ev) {+ var st = ev.body[0];+ $('.widget-xmonad').html(st);+ change.fire(st);+ });+ }); }); return {
src/System/Tianbar.hs view
@@ -1,48 +1,65 @@ module System.Tianbar where -import Graphics.UI.Gtk hiding (Signal)+import qualified Data.Text as T +import GI.Gdk.Enums hiding (WindowTypeToplevel)+import GI.Gdk.Objects.Display+import GI.Gdk.Objects.Screen+import GI.Gdk.Structs.Rectangle++import GI.Gtk.Enums+import qualified GI.Gtk.Functions as GtkFunctions+import GI.Gtk.Objects.Box+import GI.Gtk.Objects.Container+import GI.Gtk.Objects.Widget+import GI.Gtk.Objects.Window++import System.Environment (getArgs, getProgName)+ 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+topStrut :: Rectangle -> IO StrutProperties+topStrut rect = do+ mX <- rectangleReadX rect+ mY <- rectangleReadY rect+ mW <- rectangleReadWidth rect+ let x = fromIntegral mX+ w = fromIntegral mW - 1+ h = barHeight + fromIntegral mY+ in return (0, 0, h, 0, 0, 0, 0, 0, x, x + w, 0, 0) main :: IO () main = do- _ <- initGUI+ progName <- getProgName+ args <- getArgs+ _ <- GtkFunctions.init $ Just $ map T.pack (progName : args) Just disp <- displayGetDefault- screen <- displayGetScreen disp myScreen- monitorSize <- screenGetMonitorGeometry screen myMonitor+ screen <- displayGetDefaultScreen disp+ monitorSize <- screenGetMonitorGeometry screen (fromIntegral myMonitor) - window <- windowNew- widgetSetName window appName+ window <- windowNew WindowTypeToplevel+ widgetSetName window $ T.pack appName - let Rectangle x _ w _ = monitorSize+ monitorX <- rectangleReadX monitorSize+ monitorW <- rectangleReadWidth monitorSize windowSetTypeHint window WindowTypeHintDock windowSetScreen window screen- windowSetDefaultSize window w barHeight- windowMove window x 0- _ <- onRealize window $- setStrutProperties window $ topStrut monitorSize+ windowSetDefaultSize window (fromIntegral monitorW) (fromIntegral barHeight)+ strut <- topStrut monitorSize+ windowMove window monitorX 0+ _ <- onWidgetRealize window $+ setStrutProperties window strut - box <- hBoxNew False widgetSpacing+ box <- boxNew OrientationHorizontal 0 containerAdd window box wk <- tianbarWebkitNew- boxPackStart box wk PackGrow 0-- tray <- systrayNew- boxPackEnd box tray PackNatural 0+ boxPackStart box wk True True 0 widgetShow window widgetShow box - mainGUI- return ()+ GtkFunctions.main
src/System/Tianbar/Callbacks.hs view
@@ -1,33 +1,89 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-} module System.Tianbar.Callbacks (- callback,- callbacks,+ Callback, Callbacks,+ CallbackIndex,+ CallbackHost,+ callbacks,+ callbackResponse,+ newCallbackT, ) where +import Control.Lens hiding ((.=))++import Control.Monad+import Control.Monad.State+ import Data.Aeson+import Data.Monoid -import Graphics.UI.Gtk-import Graphics.UI.Gtk.WebKit.WebView+import GI.Gio.Objects.Cancellable -import qualified Data.Text.Lazy as T+import GI.WebKit2.Objects.WebView++import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as E -newtype Callbacks = Callbacks WebView+import Text.Read (readMaybe) -callbacks :: WebView -> Callbacks-callbacks = Callbacks+import System.Tianbar.RequestResponse -callback :: (ToJSON i, ToJSON p) => Callbacks -> i -> p -> IO ()-callback (Callbacks wk) index param =- postGUIAsync $ webViewExecuteScript wk $ callbackScript index param+newtype CallbackIndex = CallbackIndex Int+ deriving (Eq, Ord) -callbackScript :: (ToJSON i, ToJSON p) => i -> p -> String-callbackScript index param =- "window.tianbarEvents && " ++ eventStr ++ " && "- ++ eventStr ++ ".fire.apply(" ++ eventStr ++ ", " ++ paramStr ++ ")"- where eventStr = "window.tianbarEvents[" ++ indexStr ++ "]"- indexStr = showJSON index+instance FromData CallbackIndex where+ fromData = do+ idxStr <- look "callbackIndex"+ case readMaybe idxStr of+ Just idx -> return $ CallbackIndex idx+ Nothing -> mzero++type Callback r = r -> IO ()++class CallbackHost h where+ callback :: (ToJSON i, ToJSON r) => h -> i -> Callback r++instance CallbackHost WebView where+ callback wk idx param =+ webViewRunJavascript wk+ (TL.toStrict $ callbackScript idx param)+ noCancellable+ Nothing++callbackScript :: (ToJSON i, ToJSON r) => i -> r -> TL.Text+callbackScript idx param =+ "window.tianbarEvents && " <> eventStr <> " && "+ <> eventStr <> ".fire.apply(" <> eventStr <> ", " <> paramStr <> ")"+ where eventStr = "window.tianbarEvents[" <> indexStr <> "]"+ indexStr = showJSON idx paramStr = showJSON param -showJSON :: ToJSON a => a -> String-showJSON = T.unpack . E.decodeUtf8 . encode . toJSON+showJSON :: ToJSON a => a -> TL.Text+showJSON = E.decodeUtf8 . encode++type CallbackHostFunc = Int -> Callback Value++data Callbacks = Callbacks { _cbHost :: CallbackHostFunc+ , _cbNextIndex :: Int+ }++cbHost :: Getter Callbacks CallbackHostFunc+cbHost inj (Callbacks h i) = flip Callbacks i <$> inj h++cbNextIndex :: Lens' Callbacks Int+cbNextIndex inj (Callbacks h i) = Callbacks h <$> inj i++callbacks :: CallbackHost h => h -> Callbacks+callbacks h = Callbacks (callback h) 0++callbackResponse :: Monad m => CallbackIndex -> m Response+callbackResponse (CallbackIndex idx) = jsonResponse $ object [ "callbackIndex" .= show idx ]++newCallbackT :: (MonadState Callbacks m, ToJSON r) => m (Callback r, CallbackIndex)+newCallbackT = do+ host <- use cbHost+ newIndex <- use cbNextIndex+ cbNextIndex += 1+ return (host newIndex . toJSON, CallbackIndex newIndex)
src/System/Tianbar/Configuration.hs view
@@ -3,15 +3,8 @@ appName :: String appName = "tianbar" -myScreen :: Int-myScreen = 0- myMonitor :: Int myMonitor = 0 barHeight :: Int barHeight = 25--widgetSpacing :: Int-widgetSpacing = 0-
src/System/Tianbar/Plugin.hs view
@@ -1,15 +1,86 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-} module System.Tianbar.Plugin (+ ServerPart, Plugin (..),+ Response (..),+ FromData (..),+ URI (..),+ dir,+ look,+ looks,+ newCallback,+ nullDir,+ parseURI,+ path,+ runHandler,+ runPlugin,+ runWithLens,+ withData, ) where -import Happstack.Server+import qualified Control.Lens as L +import Control.Monad+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Maybe++import Data.Aeson+import qualified Data.Text as T+ import System.Tianbar.Callbacks+import System.Tianbar.RequestResponse +type ServerPart s t = MaybeT (StateT s (ReaderT URI (StateT Callbacks IO))) t++runHandler :: MonadIO m => ServerPart p t -> p -> URI -> Callbacks -> m ((Maybe t, p), Callbacks)+runHandler h p uri cb = liftIO $ runStateT (runReaderT (runStateT (runMaybeT h) p) uri) cb++runWithLens :: L.Lens' p q -> ServerPart q Response -> ServerPart p Response+runWithLens l = mapMaybeT $ \act -> do+ p <- L.use l+ (res, p') <- lift $ runStateT act p+ L.assign l p'+ return res++runWithUri :: URI -> ServerPart p t -> ServerPart p t+runWithUri uri = mapMaybeT $ mapStateT $ local $ const uri++path :: (String -> ServerPart p t) -> ServerPart p t+path h = do+ uri <- ask+ let segments = uriPathSegments uri+ guard (not $ null segments)++ let uri' = uri { uriPathSegments = tail segments }+ runWithUri uri' $ h (T.unpack $ head segments)++dir :: String -> ServerPart p t -> ServerPart p t+dir name h = path $ \name' -> guard (name == name') >> h++nullDir :: ServerPart p ()+nullDir = do+ segments <- asks uriPathSegments+ guard $ null segments++withData :: FromData a => (a -> ServerPart p r) -> ServerPart p r+withData h = do+ d <- fromData+ h d+ class Plugin p where- initialize :: Callbacks -> IO p+ initialize :: IO p destroy :: p -> IO () destroy _ = return () - handler :: p -> ServerPartT IO Response+ handler :: ServerPart p Response++runPlugin :: (Plugin p, MonadIO m) => p -> URI -> Callbacks -> m ((Maybe Response, p), Callbacks)+runPlugin = runHandler handler++newCallback :: ToJSON r => ServerPart p (Callback r, CallbackIndex)+newCallback = lift $ lift $ lift newCallbackT
+ src/System/Tianbar/Plugin/All.hs view
@@ -0,0 +1,18 @@+module System.Tianbar.Plugin.All (+ AllPlugins+) where++import System.Tianbar.Plugin.Combined+import System.Tianbar.Plugin.DBus+import System.Tianbar.Plugin.ExecuteCommand+import System.Tianbar.Plugin.FileSystem+import System.Tianbar.Plugin.GSettings+import System.Tianbar.Plugin.Socket++type AllPlugins =+ Combined DBusPlugin (+ Combined ExecuteCommand (+ Combined FileSystem (+ Combined GSettings (+ Combined SocketPlugin (+ Combined EmptyPlugin EmptyPlugin)))))
src/System/Tianbar/Plugin/Combined.hs view
@@ -1,19 +1,27 @@+{-# LANGUAGE RankNTypes #-} module System.Tianbar.Plugin.Combined where -import Control.Applicative+import Control.Lens+ import Control.Monad import System.Tianbar.Plugin data Combined p q = Combined p q +combined1 :: Lens' (Combined p q) p+combined1 inj (Combined p q) = flip Combined q <$> inj p++combined2 :: Lens' (Combined p q) q+combined2 inj (Combined p q) = Combined p <$> inj q+ instance (Plugin p, Plugin q) => Plugin (Combined p q) where- initialize wk = Combined <$> initialize wk <*> initialize wk+ initialize = Combined <$> initialize <*> initialize destroy (Combined p q) = destroy p >> destroy q- handler (Combined p q) = handler p `mplus` handler q+ handler = runWithLens combined1 handler `mplus` runWithLens combined2 handler -data Empty = Empty+data EmptyPlugin = EmptyPlugin -instance Plugin Empty where- initialize _ = return Empty- handler _ = mzero+instance Plugin EmptyPlugin where+ initialize = return EmptyPlugin+ handler = mzero
src/System/Tianbar/Plugin/DBus.hs view
@@ -1,95 +1,135 @@+{-# LANGUAGE RankNTypes #-} module System.Tianbar.Plugin.DBus (DBusPlugin) where -- DBus connectivity -import Control.Applicative-import Control.Concurrent+import Control.Lens hiding (index)+ import Control.Monad import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe -import Data.Aeson (encode) import qualified Data.Map as M -import Happstack.Server--import DBus.Client+import DBus (parseAddress)+import DBus.Client ( Client+ , SignalHandler+ , addMatch+ , call+ , connect+ , connectSystem+ , connectSession+ , disconnect+ , removeMatch+ ) import System.Tianbar.Callbacks import System.Tianbar.Plugin import System.Tianbar.Plugin.DBus.JSON () import System.Tianbar.Plugin.DBus.FromData ()+import System.Tianbar.RequestResponse -data Bus = Bus { busClient :: Client- , busSignals :: MVar (M.Map String SignalHandler)++type SignalMap = M.Map CallbackIndex SignalHandler++data Bus = Bus { _busClient :: Client+ , _busSignals :: SignalMap } +busClient :: Getter Bus Client+busClient inj (Bus c s) = flip Bus s <$> inj c++busSignals :: Lens' Bus SignalMap+busSignals inj (Bus c s) = Bus c <$> inj s+ busNew :: IO Client -> IO Bus-busNew conn = Bus <$> conn <*> newMVar M.empty+busNew conn = Bus <$> conn <*> pure M.empty busDestroy :: Bus -> IO ()--- TODO: remove signals?-busDestroy = disconnect . busClient--busAddListener :: (MonadIO m) => Bus -> String -> SignalHandler -> m ()-busAddListener bus index listener = liftIO $ modifyMVar_ (busSignals bus) $ \listeners ->- return $ M.insert index listener listeners+busDestroy bus = do+ let clnt = bus ^. busClient+ forM_ (bus ^. busSignals) $ removeMatch clnt+ disconnect clnt -busPopListener :: (MonadIO m) => Bus -> String -> m (Maybe SignalHandler)-busPopListener bus index = liftIO $ modifyMVar (busSignals bus) $ \listeners -> do- let listener = M.lookup index listeners- let listeners' = M.delete index listeners- return (listeners', listener)+type BusMap = M.Map String Bus -data DBusPlugin = DBusPlugin { dbusHost :: Callbacks- , dbusSession :: Bus- , dbusSystem :: Bus+data DBusPlugin = DBusPlugin { _dbusMap :: BusMap } -busNameMap :: [(String, DBusPlugin -> Bus)]-busNameMap = [ ("session", dbusSession)- , ("system", dbusSystem)- ]+dbusMap :: Lens' DBusPlugin BusMap+dbusMap inj (DBusPlugin m) = DBusPlugin <$> inj m instance Plugin DBusPlugin where- initialize c = do+ initialize = do session <- busNew connectSession system <- busNew connectSystem- return $ DBusPlugin c session system+ let busMap = M.fromList [ ("session", session)+ , ("system", system)+ ]+ return $ DBusPlugin busMap - destroy plugin = mapM_ busDestroy [dbusSession plugin, dbusSystem plugin]+ destroy plugin = forM_ (plugin ^. dbusMap) busDestroy - handler plugin = dir "dbus" $ msum [ busHandler plugin busName (bus plugin)- | (busName, bus) <- busNameMap- ]+ handler = dir "dbus" $ msum [ busesHandler+ , connectBusHandler+ ] -busHandler :: DBusPlugin -> String -> Bus -> ServerPartT IO Response-busHandler plugin busName bus = dir busName $ msum [ mzero- , listenHandler plugin bus- , stopHandler plugin bus- , callHandler plugin bus- ]+connectBusHandler :: ServerPart DBusPlugin Response+connectBusHandler = dir "connect" $ do+ nullDir+ name <- look "name"+ addressStr <- look "address"+ address <- MaybeT $ return $ parseAddress addressStr+ bus <- liftIO $ busNew $ connect address+ dbusMap . at name .= Just bus+ okResponse -listenHandler :: DBusPlugin -> Bus -> ServerPartT IO Response-listenHandler plugin bus = dir "listen" $ withData $ \matcher -> do+type BusReference = Lens' DBusPlugin Bus++unsafeMaybeLens :: Lens' (Maybe a) a+unsafeMaybeLens inj (Just v) = Just <$> inj v+unsafeMaybeLens _ Nothing = error "unsafeMaybeLens applied to Nothing"++busesHandler :: ServerPart DBusPlugin Response+busesHandler = path $ \busName -> do+ let busRef :: Lens' DBusPlugin (Maybe Bus)+ busRef = dbusMap . at busName+ bus <- use busRef+ case bus of+ Just _ -> busHandler $ busRef . unsafeMaybeLens+ Nothing -> mzero++busHandler :: BusReference -> ServerPart DBusPlugin Response+busHandler plugin = msum [ listenHandler plugin+ , stopHandler plugin+ , callHandler plugin+ ]++listenHandler :: BusReference -> ServerPart DBusPlugin Response+listenHandler busRef = dir "listen" $ withData $ \matcher -> do nullDir- index <- look "index"- listener <- liftIO $ addMatch (busClient bus) matcher $ \sig -> callback (dbusHost plugin) index [sig]- busAddListener bus index listener- return $ toResponse ("ok" :: String)+ clnt <- use $ busRef . busClient+ (callback, index) <- newCallback+ listener <- liftIO $ addMatch clnt matcher $ \sig -> callback [sig]+ busRef . busSignals . at index .= Just listener+ callbackResponse index -stopHandler :: DBusPlugin -> Bus -> ServerPartT IO Response-stopHandler _ bus = dir "stop" $ do+stopHandler :: BusReference -> ServerPart DBusPlugin Response+stopHandler busRef = dir "stop" $ do nullDir- index <- look "index"- listener <- busPopListener bus index+ index <- fromData+ listener <- use (busRef . busSignals . at index) case listener of Just l -> do- liftIO $ removeMatch (busClient bus) l- return $ toResponse ("ok" :: String)+ busRef . busSignals . at index .= Nothing+ clnt <- use $ busRef . busClient+ liftIO $ removeMatch clnt l+ callbackResponse index Nothing -> mzero -callHandler :: DBusPlugin -> Bus -> ServerPartT IO Response-callHandler _ bus = dir "call" $ withData $ \mcall -> do+callHandler :: BusReference -> ServerPart DBusPlugin Response+callHandler busRef = dir "call" $ withData $ \mcall -> do nullDir- res <- liftIO $ call (busClient bus) mcall- return $ toResponse $ encode res+ clnt <- use $ busRef . busClient+ res <- liftIO $ call clnt mcall+ jsonResponse res
src/System/Tianbar/Plugin/DBus/FromData.hs view
@@ -1,15 +1,13 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module System.Tianbar.Plugin.DBus.FromData () where -import Control.Monad- import Data.List.Split import Data.Maybe import DBus import DBus.Client -import Happstack.Server+import System.Tianbar.Plugin instance FromData MatchRule where fromData = do@@ -28,7 +26,7 @@ callPath <- fromData iface <- fromData member <- fromData- callBody <- liftM (map variantFromString) $ looks "body[]"+ callBody <- map variantFromString <$> looks "body[]" dest <- fromData let setBodyDest mcall = mcall { methodCallBody = callBody , methodCallDestination = dest@@ -36,18 +34,18 @@ return $ setBodyDest $ methodCall callPath iface member instance FromData ObjectPath where- fromData = liftM (fromJust . parseObjectPath) $ look "path"+ fromData = fromJust . parseObjectPath <$> look "path" instance FromData InterfaceName where- fromData = liftM (fromJust . parseInterfaceName) $ look "iface"+ fromData = fromJust . parseInterfaceName <$> look "iface" instance FromData MemberName where- fromData = liftM (fromJust . parseMemberName) $ look "member"+ fromData = fromJust . parseMemberName <$> look "member" instance FromData BusName where- fromData = liftM (fromJust . parseBusName) $ look "destination"+ fromData = fromJust . parseBusName <$> look "destination" variantFromString :: String -> Variant variantFromString param = case splitOn ":" param of ["string", str] -> toVariant str- _ -> error "Invalid variant string"+ _ -> error $ "Invalid variant string: " ++ show param
src/System/Tianbar/Plugin/DBus/JSON.hs view
@@ -5,6 +5,7 @@ import Data.Aeson hiding (Array) import Data.Int import qualified Data.Map as M+import qualified Data.Text as T import Data.Word import DBus@@ -20,7 +21,7 @@ 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+ TypeString -> let Just s = fromVariant v :: Maybe T.Text in toJSON s TypeSignature -> let Just s = fromVariant v :: Maybe Signature in toJSON $ formatSignature s
− src/System/Tianbar/Plugin/DataDirectory.hs
@@ -1,20 +0,0 @@-module System.Tianbar.Plugin.DataDirectory where---- Serve files from the data directory--import Control.Monad.IO.Class--import Happstack.Server--import System.Tianbar.Plugin--import Paths_tianbar--data DataDirectory = DataDirectory--instance Plugin DataDirectory where- initialize _ = return DataDirectory-- handler _ = dir "data" $ uriRest $ \filePath -> do- dataFile <- liftIO $ getDataFileName filePath- serveFile (guessContentTypeM mimeTypes) dataFile
+ src/System/Tianbar/Plugin/ExecuteCommand.hs view
@@ -0,0 +1,24 @@+module System.Tianbar.Plugin.ExecuteCommand where++-- Execute arbitrary commands++import Control.Monad.Trans++import System.Process++import System.Tianbar.Plugin+import System.Tianbar.RequestResponse++data ExecuteCommand = ExecuteCommand++instance Plugin ExecuteCommand where+ initialize = return ExecuteCommand++ handler = dir "execute" executeHandler++executeHandler :: ServerPart ExecuteCommand Response+executeHandler = do+ nullDir+ command <- look "command"+ output <- liftIO $ readCreateProcess (shell command) ""+ stringResponse output
+ src/System/Tianbar/Plugin/FileSystem.hs view
@@ -0,0 +1,40 @@+module System.Tianbar.Plugin.FileSystem where++-- Serve files from the data directory++import Control.Monad+import Control.Monad.Reader++import qualified Data.List as L+import qualified Data.Text as T++import System.Environment.XDG.BaseDir++import System.Tianbar.Configuration+import System.Tianbar.Plugin+import System.Tianbar.RequestResponse++import Paths_tianbar++data FileSystem = FileSystem++getUserFileName :: String -> IO FilePath+getUserFileName = getUserConfigFile appName++getRootFileName :: String -> IO FilePath+getRootFileName filePath = return $ "/" ++ filePath++instance Plugin FileSystem where+ initialize = return FileSystem++ handler = msum [ dir "data" $ directoryHandler getDataFileName+ , dir "user" $ directoryHandler getUserFileName+ , dir "root" $ directoryHandler getRootFileName+ ]++directoryHandler :: (String -> IO FilePath) -> ServerPart FileSystem Response+directoryHandler getFileName = do+ uri <- ask+ let filePath = L.intercalate "/" $ map T.unpack $ uriPathSegments uri+ dataFile <- liftIO $ getFileName filePath+ serveFile dataFile
src/System/Tianbar/Plugin/GSettings.hs view
@@ -4,27 +4,25 @@ import Control.Monad.IO.Class -import Happstack.Server- import System.Process import System.Tianbar.Plugin+import System.Tianbar.RequestResponse data GSettings = GSettings instance Plugin GSettings where- initialize _ = return GSettings+ initialize = return GSettings - handler _ = dir "gsettings" $+ handler = dir "gsettings" $ path $ \schema -> path $ \key -> do nullDir setting <- liftIO $ gsettingsGet schema key- return $ toResponse setting+ stringResponse setting 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-
src/System/Tianbar/Plugin/Socket.hs view
@@ -1,71 +1,74 @@+{-# LANGUAGE FlexibleContexts #-} module System.Tianbar.Plugin.Socket where -- Socket connectivity import Control.Concurrent+import Control.Lens hiding (index) import Control.Monad import Control.Monad.IO.Class+import Control.Monad.State+import Control.Monad.Trans.Maybe import qualified Data.Map as M -import Happstack.Server- import Network.Socket import System.Tianbar.Callbacks import System.Tianbar.Plugin -data SocketPlugin = SocketPlugin { spHost :: Callbacks- , spSock :: MVar (M.Map String Socket)+type SocketMap = M.Map CallbackIndex Socket++data SocketPlugin = SocketPlugin { _spSock :: SocketMap } +spSock :: Lens' SocketPlugin SocketMap+spSock inj (SocketPlugin m) = SocketPlugin <$> inj m+ instance Plugin SocketPlugin where- initialize c = do- socks <- newMVar M.empty- return $ SocketPlugin c socks+ initialize = return $ SocketPlugin M.empty - destroy sp = withMVar (spSock sp) $ mapM_ close . M.elems+ destroy = mapM_ close . M.elems . view spSock - handler plugin = dir "socket" $ msum $ map (\act -> act plugin) acts- where acts = [connectHandler, sendHandler, closeHandler]+ handler = dir "socket" $ msum [connectHandler, sendHandler, closeHandler] -connectHandler :: SocketPlugin -> ServerPartT IO Response-connectHandler sp = dir "connect" $ do+connectHandler :: ServerPart SocketPlugin Response+connectHandler = dir "connect" $ do nullDir- callbackIndex <- look "callbackIndex" socketPath <- look "path" sock <- liftIO $ do s <- socket AF_UNIX Stream defaultProtocol connect s $ SockAddrUnix socketPath return s+ (callback, index) <- newCallback _ <- liftIO $ forkIO $ void $ forever $ do- response <- recv sock 4096- callback (spHost sp) callbackIndex [response]- liftIO $ modifyMVar_ (spSock sp) $ return . M.insert callbackIndex sock- return $ toResponse "ok"+ sockData <- recv sock 4096+ liftIO $ callback [sockData]+ return ()+ spSock . at index .= Just sock+ callbackResponse index -sendHandler :: SocketPlugin -> ServerPartT IO Response-sendHandler sp = dir "send" $ do+sendHandler :: ServerPart SocketPlugin Response+sendHandler = dir "send" $ do nullDir- callbackIndex <- look "callbackIndex"- -- TODO: Maybe- Just sock <- withSocket sp callbackIndex+ index <- fromData+ sock <- MaybeT $ getSocket index dataToSend <- look "data" -- TODO: resend until done _ <- liftIO $ send sock dataToSend- return $ toResponse "ok"+ callbackResponse index -closeHandler :: SocketPlugin -> ServerPartT IO Response-closeHandler sp = dir "close" $ do+closeHandler :: ServerPart SocketPlugin Response+closeHandler = dir "close" $ do nullDir- callbackIndex <- look "callbackIndex"- sock <- withSocket sp callbackIndex+ index <- fromData+ sock <- getSocket index case sock of Nothing -> return ()- Just sock' -> liftIO $ do- close sock'- modifyMVar_ (spSock sp) $ return . M.delete callbackIndex- return $ toResponse "ok"+ Just sock' -> do+ liftIO $ close sock'+ spSock . at index .= Nothing+ callbackResponse index -withSocket :: MonadIO m => SocketPlugin -> String -> m (Maybe Socket)-withSocket sp callbackIndex = liftIO $ withMVar (spSock sp) $ return . M.lookup callbackIndex+getSocket :: MonadState SocketPlugin m => CallbackIndex -> m (Maybe Socket)+getSocket callbackIndex = use $ spSock . at callbackIndex
+ src/System/Tianbar/RequestResponse.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+module System.Tianbar.RequestResponse (+ URI (..),+ FromData (..),+ Response (..),+ bytestringResponse,+ jsonResponse,+ look,+ looks,+ okResponse,+ parseURI,+ serveFile,+ stringResponse,+ textResponse,+) where++import Control.Monad.IO.Class+import Control.Monad.Reader++import Data.Aeson++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.ByteString.UTF8 as U++import Data.Maybe++import qualified Data.Text as T+import qualified Data.Text.Encoding as TE++import Network.HTTP.Types (Query, decodePath)+import Network.Mime (defaultMimeLookup)++import System.FilePath+++data URI = URI { uriPathSegments :: [T.Text]+ , uriQuery :: Query+ }+ deriving (Show)++parseURI :: T.Text -> URI+parseURI str = URI segments query+ where (segments, query) = decodePath uriPath+ uriPath = extractPath $ TE.encodeUtf8 str+ prefix = U.fromString "tianbar://"+ extractPath uri | prefix `B.isPrefixOf` uri = B.drop (B.length prefix) uri+ | otherwise = uri++data Response = Response { content :: B.ByteString+ , mimeType :: Maybe String+ }++stringResponse :: Monad m => String -> m Response+stringResponse = bytestringResponse . U.fromString++textResponse :: Monad m => T.Text -> m Response+textResponse = bytestringResponse . TE.encodeUtf8++bytestringResponse :: Monad m => B.ByteString -> m Response+bytestringResponse str = return $ Response str (Just "text/plain")++okResponse :: Monad m => m Response+okResponse = bytestringResponse "ok"++jsonResponse :: (Monad m, ToJSON v) => v -> m Response+jsonResponse = bytestringResponse . LBS.toStrict . encode++serveFile :: MonadIO m => FilePath -> m Response+serveFile filePath = do+ contents <- liftIO $ B.readFile filePath+ let fileType = defaultMimeLookup $ T.pack $ takeFileName filePath+ -- FIXME: Guess the MIME type+ return $ Response contents (Just $ U.toString fileType)++look :: (MonadPlus m, MonadReader URI m) => String -> m String+look param = looks param >>= \values -> case values of+ [value] -> return value+ _ -> mzero++looks :: (MonadPlus m, MonadReader URI m) => String -> m [String]+looks param = asks uriQuery >>= \params -> do+ let paramTxt = U.fromString param+ let isParam (p, value) | p == paramTxt = fmap U.toString value+ | otherwise = Nothing+ return $ mapMaybe isParam params++class FromData a where+ fromData :: (MonadPlus m, MonadReader URI m) => m a++instance FromData a => FromData (Maybe a) where+ fromData = fmap Just fromData `mplus` return Nothing
src/System/Tianbar/Server.hs view
@@ -1,69 +1,34 @@ module System.Tianbar.Server (- Server (..),- startServer+ Server,+ handleURI,+ startServer,+ stopServer, ) where -- Server to handle JS callbacks import Control.Concurrent-import Control.Monad -import Happstack.Server--import Network.Socket-import Network.URI--import System.Random+import GI.WebKit2.Objects.WebView import System.Tianbar.Callbacks import System.Tianbar.Plugin-import System.Tianbar.Plugin.Combined-import System.Tianbar.Plugin.DataDirectory-import System.Tianbar.Plugin.DBus-import System.Tianbar.Plugin.GSettings-import System.Tianbar.Plugin.Socket--data Server = Server { serverOverrideURI :: URI -> URI- , stopServer :: IO ()- }--localhost :: String-localhost = "127.0.0.1"--startServer :: Callbacks -> IO Server-startServer c = do- sock <- bindIPv4 localhost $ fromIntegral aNY_PORT- prefix <- replicateM 20 $ randomRIO ('a', 'z')- plugins <- initialize c :: IO AllPlugins- thread <- forkIO $ runServer sock prefix plugins- portNum <- socketPort sock- return $ Server (handleURI portNum prefix) (killServer thread plugins)+import System.Tianbar.Plugin.All -type AllPlugins =- Combined DataDirectory (- Combined DBusPlugin (- Combined GSettings (- Combined SocketPlugin (- Combined Empty Empty))))+newtype Server = Server { serverState :: MVar (Callbacks, AllPlugins) } -runServer :: Plugin p => Socket -> String -> p -> IO ()-runServer sock prefix plugin = do- portNum <- socketPort sock- let conf = nullConf { port = fromIntegral portNum }- simpleHTTPWithSocket sock conf $ dir prefix $ handler plugin+startServer :: WebView -> IO Server+startServer wk = do+ plugins <- initialize+ pluginsVar <- newMVar (callbacks wk, plugins)+ return $ Server pluginsVar -killServer :: Plugin p => ThreadId -> p -> IO ()-killServer thread p = do- destroy p- killThread thread+handleURI :: Server -> URI -> IO (Maybe Response)+handleURI server uri = modifyMVar (serverState server) $ \(cb, plugins) -> do+ ((resp, plugins'), cb') <- runPlugin plugins uri cb+ return ((cb', plugins'), resp) -handleURI :: PortNumber -> String -> URI -> URI-handleURI portNum prefix uri | uriScheme uri == "tianbar:" = uri'- | otherwise = uri- where uri' = uri { uriScheme = "http:"- , uriAuthority = Just URIAuth { uriUserInfo = ""- , uriRegName = localhost- , uriPort = ':' : show portNum- }- , uriPath = "/" ++ prefix ++ uriPath uri- }+stopServer :: Server -> IO ()+stopServer server = do+ (_, plugins) <- takeMVar $ serverState server+ destroy plugins
src/System/Tianbar/StrutProperties.hs view
@@ -1,35 +1,79 @@+{-# LANGUAGE OverloadedStrings #-} module System.Tianbar.StrutProperties ( setStrutProperties , StrutProperties ) where -import Graphics.UI.Gtk+import Control.Monad+import Control.Monad.IO.Class +import Data.GI.Base.ShortPrelude++import qualified GI.Gtk as Gtk++import GI.Gdk.Types+import GI.Gdk.Structs.Atom+ 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- -> ()+foreign import ccall "gdk_property_change" gdk_property_change ::+ Ptr Window -> -- window : TInterface "Gdk" "Window"+ Ptr Atom -> -- property : TInterface "Gdk" "Atom"+ Ptr Atom -> -- type : TInterface "Gdk" "Atom"+ Int32 -> -- format+ CULong -> -- mode : GdkPropMode+ Ptr () -> -- data+ Int32 -> -- nelements+ IO () ++propertyChange ::+ (MonadIO m, WindowK a, Storable d) =>+ a -- window+ -> Atom -- property+ -> Atom -- type_+ -> Int32 -- format+ -> PropMode -- mode+ -> [d] -- elements+ -> m ()+propertyChange window property type_ format mode elements = liftIO $ do+ let window' = unsafeManagedPtrCastPtr window+ let property' = unsafeManagedPtrGetPtr property+ let type_' = unsafeManagedPtrGetPtr type_+ let nelements = length elements+ let mode' = fromIntegral $ fromEnum mode+ data_ <- allocBytes (sizeOf (head elements) * nelements) :: IO (Ptr d)+ forM_ (zip [0..] elements) $ uncurry $ pokeElemOff data_+ gdk_property_change window' property' type_' format mode' (castPtr data_) (fromIntegral nelements)+ touchManagedPtr window+ touchManagedPtr property+ touchManagedPtr type_+ freeMem data_++ -- | Reserve EWMH struts-setStrutProperties :: Window -> StrutProperties -> IO ()-setStrutProperties gtkWindow (left, right, top, bottom,+setStrutProperties :: Gtk.Window -> StrutProperties -> IO ()+setStrutProperties window (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 ->- 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)-+ let data_ :: [CULong]+ data_ = map fromIntegral [ 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+ ]+ prop <- atomIntern "_NET_WM_STRUT_PARTIAL" False+ type_ <- atomIntern "CARDINAL" False+ Just gdkWindow <- Gtk.widgetGetWindow window+ propertyChange gdkWindow prop type_ 32 PropModeReplace data_
− src/System/Tianbar/Systray.hs
@@ -1,25 +0,0 @@--- | 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)
− src/System/Tianbar/Utils.hs
@@ -1,6 +0,0 @@-module System.Tianbar.Utils where--import Control.Monad.Trans.Maybe--liftMT :: Monad m => Maybe a -> MaybeT m a-liftMT = MaybeT . return
src/System/Tianbar/WebKit.hs view
@@ -2,81 +2,98 @@ module System.Tianbar.WebKit where import Control.Concurrent+import Control.Exception import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Maybe -import Graphics.UI.Gtk hiding (disconnect, Signal, Variant)-import Graphics.UI.Gtk.WebKit.GeolocationPolicyDecision-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 qualified Data.Text as T+import Data.GI.Base -import Network.URI+import GI.Gdk.Flags+import GI.Gdk.Objects.Display+import GI.Gdk.Objects.Screen+import GI.Gdk.Structs.Geometry+import GI.Gdk.Structs.Rectangle +import GI.Gio.Objects.MemoryInputStream++import GI.GLib.Callbacks+import GI.GLib.Functions hiding (getUserConfigDir)++import GI.Gtk hiding (main)++import GI.WebKit2.Callbacks+import GI.WebKit2.Interfaces.PermissionRequest (permissionRequestAllow)+import GI.WebKit2.Objects.SecurityManager+import GI.WebKit2.Objects.Settings+import GI.WebKit2.Objects.URISchemeRequest+import GI.WebKit2.Objects.WebContext+import GI.WebKit2.Objects.WebView+import GI.WebKit2.Objects.WindowProperties+ import System.Directory import System.Environment.XDG.BaseDir -import System.Tianbar.Callbacks+import System.Tianbar.Plugin import System.Tianbar.Configuration import System.Tianbar.Server-import System.Tianbar.Utils import Paths_tianbar + tianbarWebView :: IO WebView tianbarWebView = do wk <- webViewNew - -- Enable AJAX access to all domains- wsettings <- webViewGetWebSettings wk- set wsettings [webSettingsEnableUniversalAccessFromFileUris := True]- webViewSetWebSettings wk wsettings+ -- Debugging settings+ wsettings <- webViewGetSettings wk+ settingsSetEnableWriteConsoleMessagesToStdout wsettings True+ settingsSetEnableDeveloperExtras wsettings True+ webViewSetSettings wk wsettings -- Enable geolocation- _ <- on wk geolocationPolicyDecisionRequested $ \_ decision -> do- geolocationPolicyAllow decision+ _ <- onWebViewPermissionRequest wk $ \request -> do+ -- TODO: This should only match geolocation permission requests+ permissionRequestAllow request return True -- Initialize plugins, and re-initialize on reloads- server <- startServer (callbacks wk) >>= newMVar- _ <- on wk loadStarted $ \_ -> modifyMVar_ server $ \oldServer -> do- stopServer oldServer- startServer (callbacks wk)+ server <- startServer wk >>= newMVar+ -- TODO: Destroy server (stopServer) on destroying the WebView - -- Process the special overrides- _ <- on wk resourceRequestStarting $ \_ _ nreq _ -> void $ runMaybeT $ do- req <- liftMT nreq- uriStr <- MaybeT $ networkRequestGetUri req- uri <- liftMT $ parseURI uriStr- override <- liftIO $ withMVar server $ return . serverOverrideURI- let uri' = override uri- liftIO $ networkRequestSetUri req $ show uri'+ -- All Tianbar plugins are served under tianbar://, allow it for CORS and+ -- register its handler+ ctx <- webViewGetContext wk+ sec <- webContextGetSecurityManager ctx+ securityManagerRegisterUriSchemeAsCorsEnabled sec "tianbar"+ webContextRegisterUriScheme ctx "tianbar" (handleRequest server) -- Handle new window creation- _ <- on wk createWebView $ \_ -> do+ _ <- onWebViewCreate wk $ \_ -> do nwk <- tianbarWebView - window <- windowNew+ window <- windowNew WindowTypeToplevel+ windowSetDecorated window False containerAdd window nwk - _ <- on nwk webViewReady $ do- wfeat <- webViewGetWindowFeatures nwk+ _ <- onWebViewReadyToShow nwk $ do+ wprop <- webViewGetWindowProperties nwk+ Just wgeom <- getWindowPropertiesGeometry wprop - [wx, wy, ww, wh] <- mapM (get wfeat) [ webWindowFeaturesX- , webWindowFeaturesY- , webWindowFeaturesWidth- , webWindowFeaturesHeight- ]+ [wx, wy, ww, wh] <- mapM ($ wgeom) [ rectangleReadX+ , rectangleReadY+ , rectangleReadWidth+ , rectangleReadHeight+ ] + geomHint <- newZeroGeometry+ geometryWriteMinWidth geomHint ww+ geometryWriteMinHeight geomHint wh+ geometryWriteMaxWidth geomHint ww+ geometryWriteMaxHeight geomHint wh windowSetGeometryHints window- (Nothing :: Maybe Window)- (Just (ww, wh))- (Just (ww, wh))- Nothing- Nothing- Nothing+ noWidget+ (Just geomHint)+ [WindowHintsMinSize, WindowHintsMaxSize] widgetShow window widgetShow nwk@@ -85,13 +102,40 @@ windowSetKeepAbove window True windowStick window - return False+ return () - return nwk+ toWidget nwk return wk +handleRequest :: MVar Server -> URISchemeRequestCallback+handleRequest server ureq = do+ uriStr <- uRISchemeRequestGetUri ureq+ let uri = parseURI uriStr+ response <- catch+ (fmap Right $ withMVar server $ \srv -> handleURI srv uri)+ (\e -> return $ Left (e :: SomeException))+ case response of+ Left exc -> do+ putStrLn $ "Error on URI: " ++ T.unpack uriStr+ err <- tianbarError 500 (show exc)+ uRISchemeRequestFinishError ureq err+ Right Nothing -> do+ putStrLn $ "URI invalid: " ++ T.unpack uriStr+ err <- tianbarError 404 "Invalid tianbar: URI"+ uRISchemeRequestFinishError ureq err+ Right (Just resp') -> do+ stream <- memoryInputStreamNewFromData (content resp') noDestroyNotify+ uRISchemeRequestFinish ureq stream (-1) (T.pack <$> mimeType resp')+++tianbarError :: Int -> String -> IO GError+tianbarError code message = do+ errDomain <- quarkFromString (Just $ T.pack "Tianbar")+ gerrorNew errDomain (fromIntegral code) (T.pack message)++ loadIndexPage :: WebView -> IO () loadIndexPage wk = do htmlFile <- getUserConfigFile appName "index.html"@@ -104,18 +148,21 @@ exampleHtml <- getDataFileName "index.html" copyFile exampleHtml htmlFile - webViewLoadUri wk $ "file://" ++ htmlFile+ webViewLoadUri wk $ T.pack "tianbar:///user/index.html" + tianbarWebkitNew :: IO Widget tianbarWebkitNew = do- l <- tianbarWebView+ wv <- tianbarWebView - _ <- on l realize $ loadIndexPage l+ _ <- onWidgetRealize wv $ loadIndexPage wv Just disp <- displayGetDefault- screen <- displayGetScreen disp myScreen- (Rectangle _ _ sw _) <- screenGetMonitorGeometry screen myMonitor- _ <- on l sizeRequest $ return (Requisition (sw `div` 2) barHeight)+ screen <- displayGetDefaultScreen disp+ monitorSize <- screenGetMonitorGeometry screen (fromIntegral myMonitor)+ monitorW <- rectangleReadWidth monitorSize - widgetShowAll l- return (toWidget l)+ widgetSetSizeRequest wv (monitorW `div` 2) (fromIntegral barHeight)++ widgetShowAll wv+ toWidget wv
− src/gdk_property_change_wrapper.c
@@ -1,28 +0,0 @@-////////////////////////////////////////////////////////////////////////////-// Copyright : (c) Jan Vornberger 2009-// License : BSD3-style (see LICENSE)-//-// Maintainer : jan.vornberger@informatik.uni-oldenburg.de-////////////////////////////////////////////////////////////////////////////---#include <gtk/gtk.h>-#include <gdk/gdk.h>--void set_strut_properties(GtkWindow *window,- long left, long right, long top, long bottom,- long left_start_y, long left_end_y,- long right_start_y, long right_end_y,- long top_start_x, long top_end_x,- long bottom_start_x, long bottom_end_x) {- gulong data[12] = {0};- data[0] = left; data[1] = right; data[2] = top; data[3] = bottom;- data[4] = left_start_y; data[5] = left_end_y;- data[6] = right_start_y; data[7] = right_end_y;- data[8] = top_start_x; data[9] = top_end_x;- data[10] = bottom_start_x; data[11] = bottom_end_x;-- gdk_property_change(GTK_WIDGET(window)->window,- gdk_atom_intern("_NET_WM_STRUT_PARTIAL", FALSE),- gdk_atom_intern ("CARDINAL", FALSE),- 32, GDK_PROP_MODE_REPLACE, (unsigned char *)data, 12);-}
tianbar.cabal view
@@ -1,5 +1,5 @@ name: tianbar-version: 0.4.8.0+version: 1.0.0.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 , index.html , scripts/dbus.js+ , scripts/ibus.js , scripts/power.js , scripts/socket.js , scripts/tianbar.js@@ -29,23 +30,31 @@ executable tianbar default-language: Haskell2010 build-depends: base >3 && <5- , aeson >=0.6- , containers >=0.5- , directory >=1.2- , dbus >=0.10.10- , gtk >=0.12- , gtk-traymanager >=0.1- , happstack-server >= 7.3- , network >=2.6- , network-uri >=2.6- , process >=1.2- , random >=1.0- , split >=0.2- , text >=0.11- , transformers >=0.3- , webkit >=0.12.6.1- , xdg-basedir >=0.2- pkgconfig-depends: gtk+-2.0+ , aeson+ , bytestring+ , containers+ , directory+ , dbus+ , filepath+ , haskell-gi-base+ , http-types+ , gi-gdk+ , gi-gio+ , gi-glib+ , gi-gtk+ , gi-webkit2+ , lens+ , mime-types+ , mtl+ , network+ , process+ , random+ , split+ , text+ , transformers+ , utf8-string+ , xdg-basedir+ pkgconfig-depends: gtk+-3.0 hs-source-dirs: src main-is: Main.hs other-modules: System.Tianbar@@ -53,18 +62,18 @@ , System.Tianbar.Configuration , System.Tianbar.Server , System.Tianbar.StrutProperties- , System.Tianbar.Systray , System.Tianbar.Plugin+ , System.Tianbar.Plugin.All , System.Tianbar.Plugin.Combined- , System.Tianbar.Plugin.DataDirectory+ , System.Tianbar.Plugin.FileSystem+ , System.Tianbar.Plugin.ExecuteCommand , System.Tianbar.Plugin.DBus , System.Tianbar.Plugin.DBus.FromData , System.Tianbar.Plugin.DBus.JSON , System.Tianbar.Plugin.GSettings , System.Tianbar.Plugin.Socket- , System.Tianbar.Utils+ , System.Tianbar.RequestResponse , System.Tianbar.WebKit- c-sources: src/gdk_property_change_wrapper.c ghc-options: -Wall -rtsopts -threaded library@@ -73,12 +82,12 @@ , dbus , xmonad , xmonad-contrib- , utf8-string >=0.3- , blaze-html >=0.5- , blaze-markup >=0.5+ , utf8-string+ , blaze-html+ , blaze-markup hs-source-dirs: src exposed-modules: System.Tianbar.XMonadLog- ghc-options: -Wall -rtsopts+ ghc-options: -Wall source-repository head type: git