diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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
diff --git a/scripts/dbus.js b/scripts/dbus.js
--- a/scripts/dbus.js
+++ b/scripts/dbus.js
@@ -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
};
});
diff --git a/scripts/ibus.js b/scripts/ibus.js
new file mode 100644
--- /dev/null
+++ b/scripts/ibus.js
@@ -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($('![]()
')
+ .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;
+});
diff --git a/scripts/power.js b/scripts/power.js
--- a/scripts/power.js
+++ b/scripts/power.js
@@ -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();
});
diff --git a/scripts/socket.js b/scripts/socket.js
--- a/scripts/socket.js
+++ b/scripts/socket.js
@@ -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()
}
});
diff --git a/scripts/tianbar.js b/scripts/tianbar.js
--- a/scripts/tianbar.js
+++ b/scripts/tianbar.js
@@ -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
};
}
diff --git a/scripts/volume.js b/scripts/volume.js
--- a/scripts/volume.js
+++ b/scripts/volume.js
@@ -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;
});
diff --git a/scripts/weather.js b/scripts/weather.js
--- a/scripts/weather.js
+++ b/scripts/weather.js
@@ -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();
}
diff --git a/scripts/xmonad.js b/scripts/xmonad.js
--- a/scripts/xmonad.js
+++ b/scripts/xmonad.js
@@ -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 {
diff --git a/src/System/Tianbar.hs b/src/System/Tianbar.hs
--- a/src/System/Tianbar.hs
+++ b/src/System/Tianbar.hs
@@ -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
diff --git a/src/System/Tianbar/Callbacks.hs b/src/System/Tianbar/Callbacks.hs
--- a/src/System/Tianbar/Callbacks.hs
+++ b/src/System/Tianbar/Callbacks.hs
@@ -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)
diff --git a/src/System/Tianbar/Configuration.hs b/src/System/Tianbar/Configuration.hs
--- a/src/System/Tianbar/Configuration.hs
+++ b/src/System/Tianbar/Configuration.hs
@@ -3,15 +3,8 @@
appName :: String
appName = "tianbar"
-myScreen :: Int
-myScreen = 0
-
myMonitor :: Int
myMonitor = 0
barHeight :: Int
barHeight = 25
-
-widgetSpacing :: Int
-widgetSpacing = 0
-
diff --git a/src/System/Tianbar/Plugin.hs b/src/System/Tianbar/Plugin.hs
--- a/src/System/Tianbar/Plugin.hs
+++ b/src/System/Tianbar/Plugin.hs
@@ -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
diff --git a/src/System/Tianbar/Plugin/All.hs b/src/System/Tianbar/Plugin/All.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Tianbar/Plugin/All.hs
@@ -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)))))
diff --git a/src/System/Tianbar/Plugin/Combined.hs b/src/System/Tianbar/Plugin/Combined.hs
--- a/src/System/Tianbar/Plugin/Combined.hs
+++ b/src/System/Tianbar/Plugin/Combined.hs
@@ -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
diff --git a/src/System/Tianbar/Plugin/DBus.hs b/src/System/Tianbar/Plugin/DBus.hs
--- a/src/System/Tianbar/Plugin/DBus.hs
+++ b/src/System/Tianbar/Plugin/DBus.hs
@@ -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
diff --git a/src/System/Tianbar/Plugin/DBus/FromData.hs b/src/System/Tianbar/Plugin/DBus/FromData.hs
--- a/src/System/Tianbar/Plugin/DBus/FromData.hs
+++ b/src/System/Tianbar/Plugin/DBus/FromData.hs
@@ -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
diff --git a/src/System/Tianbar/Plugin/DBus/JSON.hs b/src/System/Tianbar/Plugin/DBus/JSON.hs
--- a/src/System/Tianbar/Plugin/DBus/JSON.hs
+++ b/src/System/Tianbar/Plugin/DBus/JSON.hs
@@ -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
diff --git a/src/System/Tianbar/Plugin/DataDirectory.hs b/src/System/Tianbar/Plugin/DataDirectory.hs
deleted file mode 100644
--- a/src/System/Tianbar/Plugin/DataDirectory.hs
+++ /dev/null
@@ -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
diff --git a/src/System/Tianbar/Plugin/ExecuteCommand.hs b/src/System/Tianbar/Plugin/ExecuteCommand.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Tianbar/Plugin/ExecuteCommand.hs
@@ -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
diff --git a/src/System/Tianbar/Plugin/FileSystem.hs b/src/System/Tianbar/Plugin/FileSystem.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Tianbar/Plugin/FileSystem.hs
@@ -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
diff --git a/src/System/Tianbar/Plugin/GSettings.hs b/src/System/Tianbar/Plugin/GSettings.hs
--- a/src/System/Tianbar/Plugin/GSettings.hs
+++ b/src/System/Tianbar/Plugin/GSettings.hs
@@ -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
-
diff --git a/src/System/Tianbar/Plugin/Socket.hs b/src/System/Tianbar/Plugin/Socket.hs
--- a/src/System/Tianbar/Plugin/Socket.hs
+++ b/src/System/Tianbar/Plugin/Socket.hs
@@ -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
diff --git a/src/System/Tianbar/RequestResponse.hs b/src/System/Tianbar/RequestResponse.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Tianbar/RequestResponse.hs
@@ -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
diff --git a/src/System/Tianbar/Server.hs b/src/System/Tianbar/Server.hs
--- a/src/System/Tianbar/Server.hs
+++ b/src/System/Tianbar/Server.hs
@@ -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
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
@@ -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_
diff --git a/src/System/Tianbar/Systray.hs b/src/System/Tianbar/Systray.hs
deleted file mode 100644
--- a/src/System/Tianbar/Systray.hs
+++ /dev/null
@@ -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)
diff --git a/src/System/Tianbar/Utils.hs b/src/System/Tianbar/Utils.hs
deleted file mode 100644
--- a/src/System/Tianbar/Utils.hs
+++ /dev/null
@@ -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
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
@@ -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
diff --git a/src/gdk_property_change_wrapper.c b/src/gdk_property_change_wrapper.c
deleted file mode 100644
--- a/src/gdk_property_change_wrapper.c
+++ /dev/null
@@ -1,28 +0,0 @@
-////////////////////////////////////////////////////////////////////////////
-// Copyright : (c) Jan Vornberger 2009
-// License : BSD3-style (see LICENSE)
-//
-// Maintainer : jan.vornberger@informatik.uni-oldenburg.de
-////////////////////////////////////////////////////////////////////////////-
-
-#include
-#include
-
-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);
-}
diff --git a/tianbar.cabal b/tianbar.cabal
--- a/tianbar.cabal
+++ b/tianbar.cabal
@@ -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