tianbar 0.3.6.0 → 0.4.0.0
raw patch · 20 files changed
+618/−326 lines, 20 filesdep +happstack-serverdep +randomdep +transformers
Dependencies added: happstack-server, random, transformers
Files
- README.md +26/−7
- scripts/dbus.js +9/−7
- scripts/socket.js +53/−0
- scripts/tianbar.js +26/−0
- scripts/volume.js +86/−0
- scripts/xmonad.js +9/−12
- src/System/Tianbar/Callbacks.hs +33/−0
- src/System/Tianbar/DBus.hs +0/−115
- src/System/Tianbar/DBus/JSON.hs +0/−87
- src/System/Tianbar/Plugin.hs +15/−0
- src/System/Tianbar/Plugin/Basic.hs +20/−0
- src/System/Tianbar/Plugin/Combined.hs +19/−0
- src/System/Tianbar/Plugin/DBus.hs +58/−0
- src/System/Tianbar/Plugin/DBus/JSON.hs +88/−0
- src/System/Tianbar/Plugin/Socket.hs +71/−0
- src/System/Tianbar/Server.hs +63/−0
- src/System/Tianbar/UriOverride.hs +0/−50
- src/System/Tianbar/Utils.hs +6/−0
- src/System/Tianbar/WebKit.hs +18/−42
- tianbar.cabal +18/−6
README.md view
@@ -18,16 +18,34 @@ ------- A small collection of widgets written in JavaScript is bundled with Tianbar,-see `scripts` directory. To include them on your page, use `tianbar:` URL-scheme, e.g. `tianbar:scripts/time.js`.+see `scripts` directory. To include them on your page, use+`tianbar:///data/` prefix, e.g. `tianbar:///data/scripts/time.js`. -Currently widgets require [jQuery][jquery] and [RequireJS][requirejs], and-neither of those is distributed with Tianbar -- you will have to obtain them-manually.+Most widgets require third-party libraries such as [jQuery][jquery] and+[RequireJS][requirejs], and neither of those is distributed with Tianbar --+see individual widget documentation and obtain the libraries manually. -XMonad integration-------------------+### Power +Displays the battery status for all the batteries reporting through UPower.++### Time++Displays the time and date.++### Volume++Displays the current PulseAudio volume. Note that `module-cli-protocol-unix`+is required to be loaded.++### Weather++Displays the weather at current location through+[OpenWeatherMap][openweathermap]. HTML geolocation API is required to determine+the current location, see [Quirks](#quirks) below.++### XMonad+ XMonad status widget works by listening on DBus for messages sent by the provided `logHook`, see `System.Tianbar.XMonadLog` documentation for details. @@ -52,6 +70,7 @@ [freegeoip]: http://freegeoip.net/ [jquery]: http://jquery.com/+[openweathermap]: http://openweathermap.org/ [requirejs]: http://requirejs.org/ [taffybar]: https://github.com/travitch/taffybar [xdg]: http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
scripts/dbus.js view
@@ -1,7 +1,7 @@ /* * A plugin to receive DBus events. */-define(['jquery'], function ($) {+define(['jquery', './tianbar'], function ($, tianbar) { "use strict"; function copyProperties(properties, from, to) { $.each(properties, function(_, x) {@@ -17,17 +17,19 @@ * 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 {Callbacks} A jQuery callback object */- listen: function (match, handler) {- window.dbusCallbacks = window.dbusCallbacks || [];- var index = window.dbusCallbacks.push(handler) - 1;+ listen: function (match) {+ var evt = tianbar.createEvent(); var data = {- index: index+ index: evt.index }; copyProperties(['path', 'iface', 'member'], match, data);- $.ajax('dbus:' + busName + '/listen', {+ $.ajax('tianbar:///dbus/' + busName + '/listen', { data: data });++ return evt.callback; }, /**@@ -44,7 +46,7 @@ data.random = new Date().getTime(); var deferred = $.Deferred(); - $.ajax('dbus:' + busName + '/call', {+ $.ajax('tianbar:///dbus/' + busName + '/call', { data: data }).done(function (result) { result = JSON.parse(result);
+ scripts/socket.js view
@@ -0,0 +1,53 @@+/*+ * A plugin to connect to UNIX domain sockets.+ */+define(['jquery', './tianbar'], function ($, tianbar) {+ "use strict";+ /**+ * Connect to a UNIX domain socket.+ * @param path {String} Socket path+ * @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 () {+ return {+ /**+ * Send data to a socket.+ * @param data {String} The data to send.+ */+ send: function (data) {+ $.ajax('tianbar:///socket/send', {+ data: {+ callbackIndex: evt.index,+ data: data,+ random: new Date().getTime()+ }+ });+ },+ /**+ * Event (jQuery.Callbacks) firing on received data.+ */+ recv: evt.callback,+ /**+ * Close a socket.+ */+ close: function () {+ $.ajax('tianbar:///socket/close', {+ data: {+ callbackIndex: evt.index,+ random: new Date().getTime()+ }+ });+ }+ };+ });+ };+});
+ scripts/tianbar.js view
@@ -0,0 +1,26 @@+/*+ * Support infrastructure for Tianbar+ */+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();++ var index = events.push(evt) - 1;++ return {+ index: index,+ callback: evt+ };+ }++ return {+ createEvent: createEvent+ };+});
+ scripts/volume.js view
@@ -0,0 +1,86 @@+/*+ * A widget to show and control the system volume.+ */+define(['jquery', './socket'], function ($, socket) {+ "use strict";++ var UID_RE = /Uid:\t(\d+)/;++ var VOLUME_RE = /set-sink-volume.+ ([^ \n]+)/;+ var MUTE_RE = /set-sink-mute.+ ([^ \n]+)/;++ var MAX_VOLUME = 0x10000;++ var WAVES = 5;++ function uid() {+ return $.ajax('/proc/self/status')+ .then(function (result) {+ return +UID_RE.exec(result)[1];+ });+ }++ uid().then(function (uid) {+ return socket('/var/run/user/' + uid + '/pulse/cli');+ }).done(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;++ var widget = $('.widget-volume');+ widget.empty();++ var speaker = $('<div />').css({+ 'float': 'left',+ 'border-top': '4px solid transparent',+ 'border-bottom': '4px solid transparent',+ 'border-right': '5px solid black',+ 'margin-top': 5,+ 'margin-bottom': 5,+ 'margin-right': 2+ }).append($('<div />').css({+ 'background': 'black',+ 'width': 4,+ 'height': 5+ }));+ widget.append(speaker);++ var waves = $('<div />').css({+ 'float': 'left',+ 'height': '100%',+ 'margin-top': 5,+ 'margin-bottom': 5,+ 'width': 12+ });+ if (mute) {+ waves.append('x');+ } else {+ for (var i = 0; i < volume * WAVES; i ++) {+ var waveSize = 6 + i * 2;+ var margin = 10 - waveSize / 2;+ var wave = $('<div />').css({+ 'display': 'inline-block',+ 'width': 1,+ 'height': waveSize,+ 'margin': 1,+ 'background': 'black',+ 'margin-bottom': margin+ });+ waves.append(wave);+ }+ }+ widget.append(waves);++ var percentage = volume.toFixed(2) * 100;+ widget.attr('title', percentage + '%');++ window.setTimeout(requestDump, 1000);+ });++ function requestDump () {+ pulseSocket.send('dump\n');+ }++ requestDump();+ });+});
scripts/xmonad.js view
@@ -14,18 +14,15 @@ "use strict"; var change = $.Callbacks(); - dbus.session.listen(- {- path: '/org/xmonad/Log',- iface: 'org.xmonad.Log',- member: 'Update'- },- function (_, body) {- var st = body[0];- $('.widget-xmonad').html(st);- change.fire(st);- }- );+ 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);+ }); return { change: change
+ src/System/Tianbar/Callbacks.hs view
@@ -0,0 +1,33 @@+module System.Tianbar.Callbacks (+ callback,+ callbacks,+ Callbacks,+) where++import Data.Aeson++import Graphics.UI.Gtk+import Graphics.UI.Gtk.WebKit.WebView++import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.Encoding as E++newtype Callbacks = Callbacks WebView++callbacks :: WebView -> Callbacks+callbacks = Callbacks++callback :: (ToJSON i, ToJSON p) => Callbacks -> i -> p -> IO ()+callback (Callbacks wk) index param =+ postGUIAsync $ webViewExecuteScript wk $ callbackScript index param++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+ paramStr = showJSON param++showJSON :: ToJSON a => a -> String+showJSON = T.unpack . E.decodeUtf8 . encode . toJSON
− src/System/Tianbar/DBus.hs
@@ -1,115 +0,0 @@-{-# Language OverloadedStrings #-}-module System.Tianbar.DBus where---- DBus connectivity--import Control.Concurrent.MVar-import Control.Monad--import Data.Aeson hiding (Array)-import Data.List-import Data.List.Split-import qualified Data.Text.Lazy as T-import qualified Data.Text.Lazy.Encoding as E--import qualified Graphics.UI.Gtk as Gtk-import Graphics.UI.Gtk.WebKit.WebView--import DBus-import DBus.Client--import Network.URI--import System.Tianbar.DBus.JSON ()-import System.Tianbar.UriOverride--type DBusState = MVar DBusConn--data DBusConn = DBusConn { dbusSession :: Client- , dbusSystem :: Client- }--connectState :: IO DBusConn-connectState = do- session <- connectSession- system <- connectSystem- return $ DBusConn session system--initDBusState :: IO DBusState-initDBusState = connectState >>= newMVar--reloadDBusState :: DBusState -> IO ()-reloadDBusState state = modifyMVar_ state $ \dbus -> do- mapM_ disconnect [dbusSession dbus, dbusSystem dbus]- connectState--callback :: WebView -> Int -> Signal -> IO ()-callback wk index sig =- Gtk.postGUIAsync $ webViewExecuteScript wk $ dbusCallback index sig--dbusCallback :: Int -> Signal -> String-dbusCallback index sig =- "window.dbusCallbacks && "- ++ "window.dbusCallbacks[" ++ indexStr ++ "](" ++ paramsStr ++ ")"- where indexStr = show index- paramsStr = intercalate "," $ map (T.unpack . E.decodeUtf8) [signalStr, bodyStr]- signalStr = encode $ toJSON sig- bodyStr = encode $ toJSON $ signalBody sig--returnJSON :: (ToJSON a) => a -> IO String-returnJSON = returnContent . T.unpack . E.decodeUtf8 . encode . toJSON--dbusOverride :: WebView -> DBusState -> UriOverride-dbusOverride wk state = withScheme "dbus:" $ \uri -> do- let busCall = splitOn "/" (uriPath uri)- let params = parseQuery uri- case busCall of- [bus, "listen"] -> withMVar state $ \dbus -> do- let client = uriBus bus dbus- dbusListen wk client params- returnContent ""- [bus, "call"] -> withMVar state $ \dbus -> do- let client = uriBus bus dbus- result <- dbusCall client params- returnJSON result- _ -> returnContent ""--dbusListen :: WebView -> Client -> URIParams -> IO ()-dbusListen wk client params = do- let matcher = matchRuleUri params- let (Just index) = liftM read $ lookupQueryParam "index" params- _ <- addMatch client matcher $ callback wk index- return ()--dbusCall :: Client -> URIParams -> IO (Either MethodError MethodReturn)-dbusCall client params = do- let mcall = methodCallUri params- call client mcall--uriBus :: String -> DBusConn -> Client-uriBus "session" = dbusSession-uriBus "system" = dbusSystem-uriBus _ = error "Unknown bus"--matchRuleUri :: URIParams -> MatchRule-matchRuleUri params = matchAny { matchSender = Nothing- , matchDestination = Nothing- , matchPath = lookupQueryParam "path" params >>= parseObjectPath- , matchInterface = lookupQueryParam "iface" params >>= parseInterfaceName- , matchMember = lookupQueryParam "member" params >>= parseMemberName- }--variantFromString :: String -> Variant-variantFromString param = case splitOn ":" param of- ["string", str] -> toVariant str- _ -> error "Invalid variant string"--methodCallUri :: URIParams -> MethodCall-methodCallUri params = (methodCall callPath iface member) { methodCallBody = body- , methodCallDestination = dest- }- where (Just callPath) = parseObjectPath $ getQueryParam "path" params- (Just iface) = parseInterfaceName $ getQueryParam "iface" params- (Just member) = parseMemberName $ getQueryParam "member" params- body = map variantFromString $ getQueryParams "body[]" params- dest = lookupQueryParam "destination" params >>= parseBusName
− src/System/Tianbar/DBus/JSON.hs
@@ -1,87 +0,0 @@-{-# Language OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module System.Tianbar.DBus.JSON () where--import Data.Aeson hiding (Array)-import Data.Int-import qualified Data.Map as M-import Data.Word--import DBus--instance ToJSON Variant where- toJSON v = case variantType v of- TypeBoolean -> let Just b = fromVariant v :: Maybe Bool in toJSON b- TypeWord8 -> let Just i = fromVariant v :: Maybe Word8 in toJSON i- TypeWord16 -> let Just i = fromVariant v :: Maybe Word16 in toJSON i- TypeWord32 -> let Just i = fromVariant v :: Maybe Word32 in toJSON i- TypeWord64 -> let Just i = fromVariant v :: Maybe Word64 in toJSON i- TypeInt16 -> let Just i = fromVariant v :: Maybe Int16 in toJSON i- TypeInt32 -> let Just i = fromVariant v :: Maybe Int32 in toJSON i- TypeInt64 -> let Just i = fromVariant v :: Maybe Int64 in toJSON i- TypeDouble -> let Just i = fromVariant v :: Maybe Double in toJSON i- TypeString -> let Just s = fromVariant v :: Maybe String in toJSON s-- TypeSignature -> let Just s = fromVariant v :: Maybe Signature in- toJSON $ formatSignature s- TypeObjectPath -> let Just p = fromVariant v :: Maybe ObjectPath in- toJSON $ formatObjectPath p-- TypeVariant -> let Just n = fromVariant v :: Maybe Variant in toJSON n- TypeArray _ -> let Just a = fromVariant v :: Maybe Array in- toJSON $ arrayItems a- TypeDictionary _ _ -> let Just d = fromVariant v :: Maybe Dictionary in- toJSON $ M.fromList $ map variantStringKey $ dictionaryItems d- TypeStructure _ -> let Just a = fromVariant v :: Maybe Structure in- toJSON $ structureItems a--variantString :: Variant -> String-variantString v = s- where Just s = case variantType v of- TypeString -> fromVariant v- TypeVariant -> Just $ variantString v'- where Just v' = fromVariant v- _ -> Just $ show v--variantStringKey :: (Variant, Variant) -> (String, Variant)-variantStringKey (k, v) = (variantString k, v)--instance ToJSON ObjectPath where- toJSON = toJSON . formatObjectPath--instance ToJSON InterfaceName where- toJSON = toJSON . formatInterfaceName--instance ToJSON MemberName where- toJSON = toJSON . formatMemberName--instance ToJSON Signal where- toJSON s = object [ "path" .= toJSON (signalPath s)- , "iface" .= toJSON (signalInterface s)- , "member" .= toJSON (signalMember s)- ]--instance ToJSON ErrorName where- toJSON = toJSON . formatErrorName--instance ToJSON Serial where- toJSON = toJSON . serialValue--instance ToJSON BusName where- toJSON = toJSON . formatBusName--instance ToJSON MethodError where- toJSON e = object [ "name" .= toJSON (methodErrorName e)- , "serial" .= toJSON (methodErrorSerial e)- , "sender" .= toJSON (methodErrorSender e)- , "destination" .= toJSON (methodErrorDestination e)- , "body" .= toJSON (methodErrorBody e)- , "message" .= toJSON (methodErrorMessage e)- ]--instance ToJSON MethodReturn where- toJSON r = object [ "serial" .= toJSON (methodReturnSerial r)- , "sender" .= toJSON (methodReturnSender r)- , "destination" .= toJSON (methodReturnDestination r)- , "body" .= toJSON (methodReturnBody r)- ]
+ src/System/Tianbar/Plugin.hs view
@@ -0,0 +1,15 @@+module System.Tianbar.Plugin (+ Plugin (..),+) where++import Happstack.Server++import System.Tianbar.Callbacks++class Plugin p where+ initialize :: Callbacks -> IO p++ destroy :: p -> IO ()+ destroy _ = return ()++ handler :: p -> ServerPartT IO Response
+ src/System/Tianbar/Plugin/Basic.hs view
@@ -0,0 +1,20 @@+module System.Tianbar.Plugin.Basic where++-- Simple plugins++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/Combined.hs view
@@ -0,0 +1,19 @@+module System.Tianbar.Plugin.Combined where++import Control.Applicative+import Control.Monad++import System.Tianbar.Plugin++data Combined p q = Combined p q++instance (Plugin p, Plugin q) => Plugin (Combined p q) where+ initialize wk = Combined <$> initialize wk <*> initialize wk+ destroy (Combined p q) = destroy p >> destroy q+ handler (Combined p q) = handler p `mplus` handler q++data Empty = Empty++instance Plugin Empty where+ initialize _ = return Empty+ handler _ = mzero
+ src/System/Tianbar/Plugin/DBus.hs view
@@ -0,0 +1,58 @@+module System.Tianbar.Plugin.DBus where++-- DBus connectivity++import Control.Monad+import Control.Monad.IO.Class++import Data.Aeson (encode)++import Happstack.Server++import DBus.Client++import System.Tianbar.Callbacks+import System.Tianbar.Plugin+import System.Tianbar.Plugin.DBus.JSON ()+import System.Tianbar.Plugin.DBus.FromData ()++data DBusPlugin = DBusPlugin { dbusHost :: Callbacks+ , dbusSession :: Client+ , dbusSystem :: Client+ }++busNameMap :: [(String, DBusPlugin -> Client)]+busNameMap = [ ("session", dbusSession)+ , ("system", dbusSystem)+ ]++instance Plugin DBusPlugin where+ initialize c = do+ session <- connectSession+ system <- connectSystem+ return $ DBusPlugin c session system++ destroy plugin = mapM_ disconnect [dbusSession plugin, dbusSystem plugin]++ handler plugin = dir "dbus" $ msum [ busHandler plugin busName (bus plugin)+ | (busName, bus) <- busNameMap+ ]++busHandler :: DBusPlugin -> String -> Client -> ServerPartT IO Response+busHandler plugin busName bus = dir busName $ msum [ mzero+ , listenHandler plugin bus+ , callHandler plugin bus+ ]++listenHandler :: DBusPlugin -> Client -> ServerPartT IO Response+listenHandler plugin client = dir "listen" $ withData $ \matcher -> do+ nullDir+ index <- look "index"+ _ <- liftIO $ addMatch client matcher $ \sig -> callback (dbusHost plugin) index [sig]+ return $ toResponse ("ok" :: String)++callHandler :: DBusPlugin -> Client -> ServerPartT IO Response+callHandler _ client = dir "call" $ withData $ \mcall -> do+ nullDir+ res <- liftIO $ call client mcall+ return $ toResponse $ encode res
+ src/System/Tianbar/Plugin/DBus/JSON.hs view
@@ -0,0 +1,88 @@+{-# Language OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module System.Tianbar.Plugin.DBus.JSON () where++import Data.Aeson hiding (Array)+import Data.Int+import qualified Data.Map as M+import Data.Word++import DBus++instance ToJSON Variant where+ toJSON v = case variantType v of+ TypeBoolean -> let Just b = fromVariant v :: Maybe Bool in toJSON b+ TypeWord8 -> let Just i = fromVariant v :: Maybe Word8 in toJSON i+ TypeWord16 -> let Just i = fromVariant v :: Maybe Word16 in toJSON i+ TypeWord32 -> let Just i = fromVariant v :: Maybe Word32 in toJSON i+ TypeWord64 -> let Just i = fromVariant v :: Maybe Word64 in toJSON i+ TypeInt16 -> let Just i = fromVariant v :: Maybe Int16 in toJSON i+ TypeInt32 -> let Just i = fromVariant v :: Maybe Int32 in toJSON i+ TypeInt64 -> let Just i = fromVariant v :: Maybe Int64 in toJSON i+ TypeDouble -> let Just i = fromVariant v :: Maybe Double in toJSON i+ TypeString -> let Just s = fromVariant v :: Maybe String in toJSON s++ TypeSignature -> let Just s = fromVariant v :: Maybe Signature in+ toJSON $ formatSignature s+ TypeObjectPath -> let Just p = fromVariant v :: Maybe ObjectPath in+ toJSON $ formatObjectPath p++ TypeVariant -> let Just n = fromVariant v :: Maybe Variant in toJSON n+ TypeArray _ -> let Just a = fromVariant v :: Maybe Array in+ toJSON $ arrayItems a+ TypeDictionary _ _ -> let Just d = fromVariant v :: Maybe Dictionary in+ toJSON $ M.fromList $ map variantStringKey $ dictionaryItems d+ TypeStructure _ -> let Just a = fromVariant v :: Maybe Structure in+ toJSON $ structureItems a++variantString :: Variant -> String+variantString v = s+ where Just s = case variantType v of+ TypeString -> fromVariant v+ TypeVariant -> Just $ variantString v'+ where Just v' = fromVariant v+ _ -> Just $ show v++variantStringKey :: (Variant, Variant) -> (String, Variant)+variantStringKey (k, v) = (variantString k, v)++instance ToJSON ObjectPath where+ toJSON = toJSON . formatObjectPath++instance ToJSON InterfaceName where+ toJSON = toJSON . formatInterfaceName++instance ToJSON MemberName where+ toJSON = toJSON . formatMemberName++instance ToJSON Signal where+ toJSON s = object [ "path" .= toJSON (signalPath s)+ , "iface" .= toJSON (signalInterface s)+ , "member" .= toJSON (signalMember s)+ , "body" .= toJSON (signalBody s)+ ]++instance ToJSON ErrorName where+ toJSON = toJSON . formatErrorName++instance ToJSON Serial where+ toJSON = toJSON . serialValue++instance ToJSON BusName where+ toJSON = toJSON . formatBusName++instance ToJSON MethodError where+ toJSON e = object [ "name" .= toJSON (methodErrorName e)+ , "serial" .= toJSON (methodErrorSerial e)+ , "sender" .= toJSON (methodErrorSender e)+ , "destination" .= toJSON (methodErrorDestination e)+ , "body" .= toJSON (methodErrorBody e)+ , "message" .= toJSON (methodErrorMessage e)+ ]++instance ToJSON MethodReturn where+ toJSON r = object [ "serial" .= toJSON (methodReturnSerial r)+ , "sender" .= toJSON (methodReturnSender r)+ , "destination" .= toJSON (methodReturnDestination r)+ , "body" .= toJSON (methodReturnBody r)+ ]
+ src/System/Tianbar/Plugin/Socket.hs view
@@ -0,0 +1,71 @@+module System.Tianbar.Plugin.Socket where++-- Socket connectivity++import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class++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)+ }++instance Plugin SocketPlugin where+ initialize c = do+ socks <- newMVar M.empty+ return $ SocketPlugin c socks++ destroy sp = withMVar (spSock sp) $ mapM_ close . M.elems++ handler plugin = dir "socket" $ msum $ map (\act -> act plugin) acts+ where acts = [connectHandler, sendHandler, closeHandler]++connectHandler :: SocketPlugin -> ServerPartT IO Response+connectHandler sp = 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+ _ <- 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"++sendHandler :: SocketPlugin -> ServerPartT IO Response+sendHandler sp = dir "send" $ do+ nullDir+ callbackIndex <- look "callbackIndex"+ -- TODO: Maybe+ Just sock <- withSocket sp callbackIndex+ dataToSend <- look "data"+ -- TODO: resend until done+ _ <- liftIO $ send sock dataToSend+ return $ toResponse "ok"++closeHandler :: SocketPlugin -> ServerPartT IO Response+closeHandler sp = dir "close" $ do+ nullDir+ callbackIndex <- look "callbackIndex"+ sock <- withSocket sp callbackIndex+ case sock of+ Nothing -> return ()+ Just sock' -> liftIO $ do+ close sock'+ modifyMVar_ (spSock sp) $ return . M.delete callbackIndex+ return $ toResponse "ok"++withSocket :: MonadIO m => SocketPlugin -> String -> m (Maybe Socket)+withSocket sp callbackIndex = liftIO $ withMVar (spSock sp) $ return . M.lookup callbackIndex
+ src/System/Tianbar/Server.hs view
@@ -0,0 +1,63 @@+module System.Tianbar.Server (+ Server (..),+ startServer+) 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 System.Tianbar.Callbacks+import System.Tianbar.Plugin+import System.Tianbar.Plugin.Basic+import System.Tianbar.Plugin.Combined+import System.Tianbar.Plugin.DBus+import System.Tianbar.Plugin.Socket++data Server = Server { serverOverrideURI :: URI -> URI+ , stopServer :: IO ()+ }++startServer :: Callbacks -> IO Server+startServer c = do+ sock <- bindIPv4 "127.0.0.1" $ 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)++type AllPlugins = Combined DBusPlugin (+ Combined SocketPlugin (+ Combined DataDirectory (+ Combined Empty Empty)))++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++killServer :: Plugin p => ThreadId -> p -> IO ()+killServer thread p = do+ destroy p+ killThread thread++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+ }
− src/System/Tianbar/UriOverride.hs
@@ -1,50 +0,0 @@-module System.Tianbar.UriOverride where--import Control.Monad--import Data.List.Split-import qualified Data.Map as M-import Data.Maybe--import Network.URI--type UriOverride = String -> Maybe (IO String)--withScheme :: String -> (URI -> IO String) -> UriOverride-withScheme schemeMatch func uriStr- | uriScheme uri == schemeMatch = Just $ func uri- | otherwise = Nothing- where (Just uri) = parseURI uriStr--mergeOverrides :: [UriOverride] -> UriOverride-mergeOverrides overrides = foldr mplus Nothing . flip map overrides . flip ($)--multiMap :: [(String, String)] -> M.Map String [String]-multiMap = foldr addElement M.empty- where addElement (k, v) = M.insertWith (++) k [v]--type URIParams = M.Map String [String]--parseQuery :: URI -> URIParams-parseQuery = multiMap- . map ((\[a, b] -> (a, b)) . map unEscapeString . splitOn "=")- . splitOn "&"- . tail- . uriQuery--lookupQueryParam :: String -> URIParams -> Maybe String-lookupQueryParam key queryMap = M.lookup key queryMap >>= \value -> case value of- [v] -> Just v- _ -> Nothing--getQueryParam :: String -> URIParams -> String-getQueryParam key = fromJust . lookupQueryParam key--getQueryParams :: String -> URIParams -> [String]-getQueryParams key = fromMaybe [] . M.lookup key--plainContent :: String -> String-plainContent content = "data:text/plain," ++ content--returnContent :: String -> IO String-returnContent = return . plainContent
+ src/System/Tianbar/Utils.hs view
@@ -0,0 +1,6 @@+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
@@ -1,9 +1,10 @@ {-# Language OverloadedStrings #-} module System.Tianbar.WebKit where +import Control.Concurrent import Control.Monad--import Data.List.Split+import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe import Graphics.UI.Gtk hiding (disconnect, Signal, Variant) import Graphics.UI.Gtk.WebKit.NetworkRequest@@ -15,31 +16,10 @@ import System.Environment.XDG.BaseDir -import System.Process-+import System.Tianbar.Callbacks import System.Tianbar.Configuration-import System.Tianbar.DBus-import System.Tianbar.UriOverride--import Paths_tianbar---- GSettings URI override-gsettingsGet :: String -> String -> IO String-gsettingsGet schema key = do- output <- readProcess "gsettings" ["get", schema, key] []- let len = length output- return $ drop 1 $ take (len - 2) output--gsettingsUriOverride :: UriOverride-gsettingsUriOverride = withScheme "gsettings:" $ \uri -> do- let [schema, key] = splitOn "/" $ uriPath uri- setting <- gsettingsGet schema key- returnContent setting---- Data directory override-dataFileOverride :: UriOverride-dataFileOverride = withScheme "tianbar:" $ \uri ->- liftM ("file://" ++) $ getDataFileName $ uriPath uri+import System.Tianbar.Server+import System.Tianbar.Utils tianbarWebView :: IO WebView tianbarWebView = do@@ -50,24 +30,20 @@ set wsettings [webSettingsEnableUniversalAccessFromFileUris := True] webViewSetWebSettings wk wsettings - -- Connect DBus listener, and reconnect on reloads- dbus <- initDBusState- _ <- on wk loadStarted $ \_ ->- reloadDBusState dbus+ -- Initialize plugins, and re-initialize on reloads+ server <- startServer (callbacks wk) >>= newMVar+ _ <- on wk loadStarted $ \_ -> modifyMVar_ server $ \oldServer -> do+ stopServer oldServer+ startServer (callbacks wk) -- Process the special overrides- let allOverrides = mergeOverrides [ gsettingsUriOverride- , dataFileOverride- , dbusOverride wk dbus- ]- _ <- on wk resourceRequestStarting $ \_ _ nreq _ -> case nreq of- Nothing -> return ()- (Just req) -> do- uri <- networkRequestGetUri req- let override_ = uri >>= allOverrides- case override_ of- Nothing -> return ()- (Just override) -> override >>= networkRequestSetUri req+ _ <- 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' -- Handle new window creation _ <- on wk createWebView $ \_ -> do
tianbar.cabal view
@@ -1,5 +1,5 @@ name: tianbar-version: 0.3.6.0+version: 0.4.0.0 synopsis: A desktop bar based on WebKit description: A desktop bar using WebKit for rendering as much as possible.@@ -16,7 +16,10 @@ , scripts/location_shim.js , scripts/dbus.js , scripts/power.js+ , scripts/socket.js+ , scripts/tianbar.js , scripts/time.js+ , scripts/volume.js , scripts/weather.js , scripts/xmonad.js @@ -28,23 +31,32 @@ , dbus >=0.10.7 && <0.11 , gtk ==0.12.* , gtk-traymanager ==0.1.*+ , happstack-server == 7.3.* , MissingH ==1.2.* , network ==2.4.* , process ==1.1.*+ , random ==1.0.* , split ==0.2.* , text ==0.11.*+ , transformers ==0.3.* , webkit ==0.12.* , xdg-basedir ==0.2.* pkgconfig-depends: gtk+-2.0 hs-source-dirs: src main-is: Main.hs other-modules: System.Tianbar+ , System.Tianbar.Callbacks , System.Tianbar.Configuration- , System.Tianbar.DBus- , System.Tianbar.DBus.JSON+ , System.Tianbar.Server , System.Tianbar.StrutProperties , System.Tianbar.Systray- , System.Tianbar.UriOverride+ , System.Tianbar.Plugin+ , System.Tianbar.Plugin.Basic+ , System.Tianbar.Plugin.Combined+ , System.Tianbar.Plugin.DBus+ , System.Tianbar.Plugin.DBus.JSON+ , System.Tianbar.Plugin.Socket+ , System.Tianbar.Utils , System.Tianbar.WebKit c-sources: src/gdk_property_change_wrapper.c ghc-options: -Wall -rtsopts -threaded@@ -61,8 +73,8 @@ , blaze-markup >=0.5 && <0.7 hs-source-dirs: src exposed-modules: System.Tianbar.XMonadLog- ghc-options: -Wall -rtsopts- ghc-prof-options: -auto-all+ ghc-options: -Wall -rtsopts+ ghc-prof-options: -auto-all source-repository head type: git