diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -40,8 +40,8 @@ ### Volume -Displays the current PulseAudio volume. Note that `module-cli-protocol-unix` -is required to be loaded. +Displays the current PulseAudio volume. Note that `module-dbus-protocol` +is required to be available. ### Weather diff --git a/scripts/dbus.js b/scripts/dbus.js --- a/scripts/dbus.js +++ b/scripts/dbus.js @@ -13,17 +13,51 @@ }); } + function stripVariants(obj) { + if (obj.hasOwnProperty('__variant')) { + return stripVariants(obj.__variant); + } + if (obj instanceof Array) { + return obj.map(stripVariants); + } + if (obj instanceof Object) { + const result = {}; + for (var key in obj) { + if (obj.hasOwnProperty(key)) { + result[key] = stripVariants(obj[key]); + } + } + return result; + } + return obj; + } + + function toObjectPath (str) { + return {__object_path: str}; + } + + function fromObjectPath (op) { + return op.__object_path; + } + function bus(busName) { return { /** * Listen for a particular DBus event. - * @param match {Object} DBus match conditions ('path', 'iface', 'member') + * @param match {Object} DBus match conditions ('path', 'iface', + * 'member'), as well as 'direct' to only add the listener without + * calling AddMatch (for direct connections) * @param handler {Function} The function to call upon receiving the event * @returns {Deferred} Promise to be fulfilled with a Tianbar event object */ listen: function (match) { var data = {}; - copyProperties(['path', 'iface', 'member'], match, data); + copyProperties([ + 'path', + 'iface', + 'member', + 'direct' + ], match, data); return $.ajax('tianbar:///dbus/' + busName + '/listen', { data: data }).then(tianbar.createEvent).then(function (evt) { @@ -52,7 +86,11 @@ call: function (params) { var data = {}; copyProperties( - ['path', 'iface', 'member', 'destination', 'body'], params, data); + ['iface', 'member', 'destination'], params, data); + if (params.path) { + data.path = fromObjectPath(params.path); + } + data.body = JSON.stringify(params.body); // Prevent caching data.random = new Date().getTime(); var deferred = $.Deferred(); @@ -62,7 +100,8 @@ }).done(function (result) { result = JSON.parse(result); if (result.Right) { - deferred.resolve(result.Right); + result = stripVariants(result.Right.body)[0]; + deferred.resolve(result); } else { deferred.reject(result.Left); } @@ -87,11 +126,9 @@ 'iface': 'org.freedesktop.DBus.Properties', 'member': 'Get', 'body': [ - 'string:' + object, - 'string:' + property + object, + property ] - }).then(function (result) { - return result.body[0]; }); }, @@ -110,10 +147,8 @@ 'iface': 'org.freedesktop.DBus.Properties', 'member': 'GetAll', 'body': [ - 'string:' + object + object ] - }).then(function (result) { - return result.body[0]; }); } }; @@ -150,6 +185,14 @@ /** * Connect an arbitrary bus. */ - connect: connectBus + connect: connectBus, + /** + * Convert a string to an object path. + */ + toObjectPath: toObjectPath, + /** + * Convert an object path to string. + */ + fromObjectPath: fromObjectPath }; }); diff --git a/scripts/ibus.js b/scripts/ibus.js --- a/scripts/ibus.js +++ b/scripts/ibus.js @@ -23,7 +23,7 @@ bus.getProperty( 'org.freedesktop.IBus', - '/org/freedesktop/IBus', + dbus.toObjectPath('/org/freedesktop/IBus'), 'org.freedesktop.IBus', 'GlobalEngine' ).then(function (result) { diff --git a/scripts/network.js b/scripts/network.js --- a/scripts/network.js +++ b/scripts/network.js @@ -1,4 +1,3 @@ -/* jshint esversion: 6 */ define(['jquery', './dbus'], function ($, dbus) { "use strict"; @@ -9,6 +8,7 @@ const INACTIVE_COLOR = '#999'; + const NM_OBJECT = dbus.toObjectPath('/org/freedesktop/NetworkManager'); self.settings_command = 'gnome-control-center network'; self.widget = function () { @@ -243,7 +243,7 @@ const get_obj_property = (iface, prop) => get_nm_property(conn_object, iface, prop); - if (/AccessPoint/.test(conn_object)) { + if (/AccessPoint/.test(dbus.fromObjectPath(conn_object))) { $.when( get_obj_property('org.freedesktop.NetworkManager.AccessPoint', 'Strength') ).done(function (strength) { @@ -305,7 +305,7 @@ self.refresh = function () { get_nm_property( - '/org/freedesktop/NetworkManager', + NM_OBJECT, 'org.freedesktop.NetworkManager', 'PrimaryConnection' ).done(function (conn) { @@ -326,7 +326,7 @@ }); }); - watch_properties('/org/freedesktop/NetworkManager').then(function (evt) { + watch_properties(NM_OBJECT).then(function (evt) { evt.add(self.refresh); }); self.refresh(); diff --git a/scripts/power.js b/scripts/power.js --- a/scripts/power.js +++ b/scripts/power.js @@ -1,4 +1,3 @@ -/* jshint esversion: 6 */ /* * A plugin to show the power (e.g. battery) state through UPower. * @@ -46,7 +45,7 @@ Phone: 8 }; - self.DISPLAY_DEVICE = '/org/freedesktop/UPower/devices/DisplayDevice'; + self.DISPLAY_DEVICE = dbus.toObjectPath('/org/freedesktop/UPower/devices/DisplayDevice'); self.widget = () => $('.widget-power'); @@ -96,7 +95,8 @@ } // Ignore the batteries which are not the (combined) display device - if (st.Type == self.DEVICE_TYPE.Battery && path !== self.DISPLAY_DEVICE) { + if (st.Type == self.DEVICE_TYPE.Battery && + dbus.fromObjectPath(path) !== dbus.fromObjectPath(self.DISPLAY_DEVICE)) { return ''; } @@ -223,11 +223,11 @@ widget.empty(); self.devices.forEach(function (path) { - if (!self.deviceProperties[path]) { + if (!self.deviceProperties[dbus.fromObjectPath(path)]) { // Device is active but no data yet return; } - widget.append(self.formatDevice(path, self.deviceProperties[path])); + widget.append(self.formatDevice(path, self.deviceProperties[dbus.fromObjectPath(path)])); }); self.updated.fire(); @@ -237,14 +237,12 @@ self.refresh = function () { dbus.system.call({ 'destination': 'org.freedesktop.UPower', - 'path': '/org/freedesktop/UPower', + 'path': dbus.toObjectPath('/org/freedesktop/UPower'), 'iface': 'org.freedesktop.UPower', 'member': 'EnumerateDevices', 'body': [ ] }).done(function (devices) { - devices = devices.body[0]; - // Add the display device devices.push(self.DISPLAY_DEVICE); @@ -263,7 +261,7 @@ path, 'org.freedesktop.UPower.Device' ).done(function (properties) { - if (!self.deviceProperties[path]) { + if (!self.deviceProperties[dbus.fromObjectPath(path)]) { // New device never seen before, listen for changes dbus.system.listen( { path: path } @@ -274,7 +272,7 @@ }); } - self.deviceProperties[path] = properties; + self.deviceProperties[dbus.fromObjectPath(path)] = properties; self.display(); }); }; diff --git a/scripts/volume.js b/scripts/volume.js --- a/scripts/volume.js +++ b/scripts/volume.js @@ -1,17 +1,11 @@ -/* jshint esversion: 6 */ /* * A widget to show and control the system volume. * * Requires 'jquery' to be available through RequireJS. */ -define(['jquery', './socket'], function ($, socket) { +define(['jquery', './dbus'], function ($, dbus) { "use strict"; - const UID_RE = /Uid:\t(\d+)/; - - const VOLUME_RE = /set-sink-volume.+ ([^ \n]+)/; - const MUTE_RE = /set-sink-mute.+ ([^ \n]+)/; - const MAX_VOLUME = 0x10000; const WIDTH = 25; @@ -23,13 +17,6 @@ self.settings_command = 'gnome-control-center sound'; - function uid() { - return $.ajax('tianbar:///root/proc/self/status') - .then(function (result) { - return +UID_RE.exec(result)[1]; - }); - } - self.widget = () => $('.widget-volume'); self.display = function () { @@ -103,31 +90,86 @@ widget.attr('title', percentage + '%'); }; - $.when( - $.ajax('tianbar:///execute', { - data: { - command: 'pacmd load-module module-cli-protocol-unix' + $.ajax('tianbar:///execute', { + data: { + command: 'pacmd load-module module-dbus-protocol' + } + }).then(function () { + return dbus.session.getProperty( + 'org.PulseAudio1', + dbus.toObjectPath('/org/pulseaudio/server_lookup1'), + 'org.PulseAudio.ServerLookup1', + 'Address' + ); + }).then(function (bus_address) { + return dbus.connect(bus_address); + }).then(function (bus) { + const core_path = dbus.toObjectPath('/org/pulseaudio/core1'); + const seenSinks = {}; + function refresh() { + function get_device_property(sink, name) { + return bus.getProperty( + 'org.PulseAudio.Core1', + sink, + 'org.PulseAudio.Core1.Device', + name + ); } - }), - uid() - ).then(function (_, uid) { - return socket('/var/run/user/' + uid + '/pulse/cli'); - }).then(function (pulseSocket) { - pulseSocket.recv.add(function (dump) { - self.mute = MUTE_RE.exec(dump)[1] === "yes"; - self.volume = parseInt(VOLUME_RE.exec(dump)[1], 16) / MAX_VOLUME; - self.display(); + function subscribe(sink, eventName) { + bus.call({ + path: core_path, + iface: 'org.PulseAudio.Core1', + member: 'ListenForSignal', + body: [ + 'org.PulseAudio.Core1.Device.' + eventName, + [sink] + ] + }).then(function () { + bus.listen({ + member: eventName, + direct: true + }).then(function (evt) { + evt.add(refresh); + }); + }); + } - window.setTimeout(requestDump, 1000); + // TODO: monitor changes to sinks + bus.getProperty( + 'org.PulseAudio.Core1', + core_path, + 'org.PulseAudio.Core1', + 'Sinks' + ).then(function (sinks) { + if (sinks.length === 0) { + // No sound + return [[0], true]; + } else { + const sink = sinks[0]; - }); + // Subscribe the updates for this sink + if (!seenSinks[dbus.fromObjectPath(sink)]) { + seenSinks[dbus.fromObjectPath(sink)] = true; + subscribe(sink, 'VolumeUpdated'); + subscribe(sink, 'MuteUpdated'); + } - function requestDump () { - pulseSocket.send('dump\n'); + return $.when( + get_device_property(sink, 'Volume'), + get_device_property(sink, 'Mute') + ); + } + }).then(function (volumes, mute) { + // volume is an array of channels' volumes, average it + const volume = volumes.reduce((a, b) => a + b, 0) / volumes.length; + self.volume = volume / MAX_VOLUME; + self.mute = mute; + self.display(); + }); } - requestDump(); + refresh(); }); $(document).ready(function () { 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 @@ -5,15 +5,20 @@ import Control.Lens hiding (index) +import Control.Exception (handle) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import qualified Data.Map as M -import DBus (parseAddress) +import DBus ( Signal + , parseAddress + ) import DBus.Client ( Client + , ClientError , SignalHandler + , MatchRule , addMatch , call , connect @@ -110,9 +115,25 @@ nullDir clnt <- use $ busRef . busClient (callback, index) <- newCallback - listener <- liftIO $ addMatch clnt matcher $ \sig -> callback [sig] - busRef . busSignals . at index .= Just listener + direct <- liftM (not . null) $ looks "direct" + if direct + then do + liftIO $ addMatchDirect clnt matcher $ \sig -> callback [sig] + else do + listener <- liftIO $ addMatch clnt matcher $ \sig -> callback [sig] + busRef . busSignals . at index .= Just listener callbackResponse index + +-- dbus package calls the AddMatch method on listening. This is not needed +-- in case of a direct connection, such as to a PulseAudio bus, as the +-- signals will be delivered anyway. The method call, however, will crash +-- and must be ignored. +addMatchDirect :: Client -> MatchRule -> (Signal -> IO ()) -> IO () +addMatchDirect client matcher sighandler = handle ignore $ do + _ <- addMatch client matcher sighandler + return () + where ignore :: ClientError -> IO () + ignore _ = return () stopHandler :: BusReference -> ServerPart DBusPlugin Response stopHandler busRef = dir "stop" $ do 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,13 +1,15 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module System.Tianbar.Plugin.DBus.FromData () where -import Data.List.Split +import Data.Aeson +import Data.ByteString.Lazy as LBS import Data.Maybe import DBus import DBus.Client import System.Tianbar.Plugin +import System.Tianbar.Plugin.DBus.JSON () instance FromData MatchRule where fromData = do @@ -26,7 +28,7 @@ callPath <- fromData iface <- fromData member <- fromData - callBody <- map variantFromString <$> looks "body[]" + callBody <- (fromJust . decode . LBS.fromStrict) <$> lookBS "body" dest <- fromData let setBodyDest mcall = mcall { methodCallBody = callBody , methodCallDestination = dest @@ -44,8 +46,3 @@ instance FromData BusName where fromData = fromJust . parseBusName <$> look "destination" - -variantFromString :: String -> Variant -variantFromString param = case splitOn ":" param of - ["string", str] -> toVariant str - _ -> 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 @@ -1,62 +1,141 @@ -{-# Language OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module System.Tianbar.Plugin.DBus.JSON () where +import Control.Applicative + import Data.Aeson hiding (Array) +import qualified Data.Aeson.Types as A +import qualified Data.HashMap.Strict as HM import Data.Int import qualified Data.Map as M +import Data.Maybe +import qualified Data.Scientific as S import qualified Data.Text as T +import qualified Data.Vector as V import Data.Word import DBus +import System.Tianbar.Plugin.DBus.Utils + +fromVariantJust :: IsVariant v => Variant -> v +fromVariantJust = fromJust . fromVariant + 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 T.Text in toJSON s + TypeBoolean -> toJSON (fromVariantJust v :: Bool) + TypeWord8 -> toJSON (fromVariantJust v :: Word8) + TypeWord16 -> toJSON (fromVariantJust v :: Word16) + TypeWord32 -> toJSON (fromVariantJust v :: Word32) + TypeWord64 -> toJSON (fromVariantJust v :: Word64) + TypeInt16 -> toJSON (fromVariantJust v :: Int16) + TypeInt32 -> toJSON (fromVariantJust v :: Int32) + TypeInt64 -> toJSON (fromVariantJust v :: Int64) + TypeDouble -> doubleToJSON (fromVariantJust v :: Double) + TypeString -> toJSON (fromVariantJust v :: T.Text) - TypeSignature -> let Just s = fromVariant v :: Maybe Signature in - toJSON $ formatSignature s - TypeObjectPath -> let Just p = fromVariant v :: Maybe ObjectPath in - toJSON $ formatObjectPath p + TypeSignature -> toJSON (fromVariantJust v :: Signature) + TypeObjectPath -> toJSON (fromVariantJust v :: ObjectPath) - TypeUnixFd -> let Just fd = fromVariant v :: Maybe Word32 in toJSON fd + TypeUnixFd -> toJSON (fromVariantJust v :: Word32) - 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 + TypeVariant -> formatStringMarker "__variant" (fromVariantJust :: Variant -> Variant) v + TypeArray _ -> toJSON (arrayItems $ fromVariantJust v) + TypeDictionary _ _ -> toJSON $ M.fromList $ map variantStringKey $ + dictionaryItems $ fromVariantJust v + TypeStructure _ -> toJSON $ structureItems $ fromVariantJust v +-- Floating point zero is instantiated as "0". To distinguish from integer +-- zero, encode it as "0.0" +doubleToJSON :: Double -> A.Value +doubleToJSON 0 = A.Number (S.scientific 0 (-1)) +doubleToJSON v = toJSON v + +instance IsValue v => IsVariant (HM.HashMap T.Text v) where + toVariant = toVariant . M.fromList . HM.toList + fromVariant = fmap (HM.fromList . M.toList) . fromVariant + +instance FromJSON Variant where + parseJSON v = snd <$> parseSimpleVairant v + <|> parseArrayVariant v + <|> parseDictVariant v + +parseSimpleVairant :: Value -> A.Parser (Type, Variant) +parseSimpleVairant (Bool b) = pure $ (TypeBoolean, toVariant b) +parseSimpleVairant (Number n) | S.base10Exponent n < 0 = pure $ (TypeDouble, toVariant doubleValue) + | otherwise = pure $ (TypeInt64, toVariant (fromIntegral integerValue :: Int64)) + where doubleValue = S.toRealFloat n :: Double + integerValue = S.coefficient n * (10 ^ S.base10Exponent n) +parseSimpleVairant (String s) = pure $ (TypeString, toVariant s) +parseSimpleVairant v = (,) TypeObjectPath <$> parseObjectPathJSON v + <|> (,) TypeVariant <$> parseNestedVariant v + +parseObjectPathJSON :: Value -> A.Parser Variant +parseObjectPathJSON v = toVariant <$> (parseJSON v :: A.Parser ObjectPath) + +parseNestedVariant :: Value -> A.Parser Variant +parseNestedVariant v = (toVariant :: Variant -> Variant) <$> (parseStringMarker "__variant" Just v) + +parseArrayVariant :: Value -> A.Parser Variant +parseArrayVariant v@(A.Array a) = mapM parseSimpleVairant (V.toList a) >>= makeArray + where makeArray items = case commonType items of + Just typ -> pure $ unwrapVariantsType typ (map snd items) + Nothing -> A.typeMismatch "items in array" v +parseArrayVariant val = A.typeMismatch "parseArrayVariant" val + +commonType :: [(Type, Variant)] -> Maybe Type +commonType [] = Just TypeVariant -- all empty arrays are the same +commonType ((typ, _):rest) | all (typ ==) (map fst rest) = Just typ + | otherwise = Nothing + +parseDictVariant :: Value -> A.Parser Variant +parseDictVariant v@(Object o) = do + let (keys, values) = unzip $ HM.toList o + values' <- mapM parseSimpleVairant values + let dict = M.fromList $ zip keys values' + makeDict dict + where makeDict :: M.Map T.Text (Type, Variant) -> A.Parser Variant + makeDict items = case commonType (M.elems items) of + Just typ -> pure $ unwrapVariantsType typ (M.map snd items) + Nothing -> A.typeMismatch "items in dictionary" v +parseDictVariant val = A.typeMismatch "parseDictVariant" val + 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 + where v' = fromVariantJust v _ -> Just $ show v variantStringKey :: (Variant, Variant) -> (String, Variant) variantStringKey (k, v) = (variantString k, v) +parseStringMarker :: FromJSON v => T.Text -> (v -> Maybe a) -> Value -> A.Parser a +parseStringMarker marker parseFunc = withObject "Object expected" $ \o -> + (parseFunc <$> o .: marker) >>= maybeParse + where maybeParse Nothing = empty + maybeParse (Just v) = pure v + +formatStringMarker :: ToJSON v => T.Text -> (a -> v) -> a -> Value +formatStringMarker marker formatFunc val = object [marker .= formatFunc val] + instance ToJSON ObjectPath where - toJSON = toJSON . formatObjectPath + toJSON = formatStringMarker "__object_path" formatObjectPath +instance FromJSON ObjectPath where + parseJSON = parseStringMarker "__object_path" parseObjectPath + instance ToJSON InterfaceName where toJSON = toJSON . formatInterfaceName instance ToJSON MemberName where toJSON = toJSON . formatMemberName + +instance ToJSON Signature where + toJSON = toJSON . formatSignature instance ToJSON Signal where toJSON s = object [ "path" .= toJSON (signalPath s) diff --git a/src/System/Tianbar/Plugin/DBus/Utils.hs b/src/System/Tianbar/Plugin/DBus/Utils.hs new file mode 100644 --- /dev/null +++ b/src/System/Tianbar/Plugin/DBus/Utils.hs @@ -0,0 +1,22 @@ +module System.Tianbar.Plugin.DBus.Utils where + +import Data.Int +import Data.Maybe +import Data.Proxy +import qualified Data.Text as T + +import DBus + + +unwrapVariants :: (IsValue v, Functor f, IsVariant (f v)) => Proxy v -> f Variant -> Variant +unwrapVariants typ = toVariant . fmap ((`asProxyTypeOf` typ) . fromJust . fromVariant) + +unwrapVariantsType :: (Functor f, IsVariant (f Bool), IsVariant (f Double), IsVariant (f Int64), IsVariant (f T.Text), IsVariant (f ObjectPath), IsVariant (f Variant)) => + Type -> f Variant -> Variant +unwrapVariantsType TypeBoolean = unwrapVariants (Proxy :: Proxy Bool) +unwrapVariantsType TypeDouble = unwrapVariants (Proxy :: Proxy Double) +unwrapVariantsType TypeInt64 = unwrapVariants (Proxy :: Proxy Int64) +unwrapVariantsType TypeString = unwrapVariants (Proxy :: Proxy T.Text) +unwrapVariantsType TypeObjectPath = unwrapVariants (Proxy :: Proxy ObjectPath) +unwrapVariantsType TypeVariant = unwrapVariants (Proxy :: Proxy Variant) +unwrapVariantsType typ = error $ show typ ++ " is not a simple variant type" 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 @@ -60,10 +60,11 @@ server <- startServer wk >>= newMVar -- TODO: Destroy server (stopServer) on destroying the WebView - -- All Tianbar plugins are served under tianbar://, allow it for CORS and - -- register its handler + -- All Tianbar plugins are served under tianbar://, mark it as secure, + -- allow CORS and register its handler ctx <- webViewGetContext wk sec <- webContextGetSecurityManager ctx + securityManagerRegisterUriSchemeAsSecure sec "tianbar" securityManagerRegisterUriSchemeAsCorsEnabled sec "tianbar" webContextRegisterUriScheme ctx "tianbar" (handleRequest server) @@ -124,7 +125,7 @@ (\e -> return $ Left (e :: SomeException)) case response of Left exc -> do - putStrLn $ "Error on URI: " ++ T.unpack uriStr + putStrLn $ "Error: " ++ show exc ++ " on URI: " ++ T.unpack uriStr err <- tianbarError 500 (show exc) uRISchemeRequestFinishError ureq err Right Nothing -> do diff --git a/tests/TestMain.hs b/tests/TestMain.hs new file mode 100644 --- /dev/null +++ b/tests/TestMain.hs @@ -0,0 +1,10 @@ +import Test.Tasty + +import qualified TestPlugin.DBus.Serialization + + +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [ TestPlugin.DBus.Serialization.tests + ] diff --git a/tests/TestPlugin/DBus/Serialization.hs b/tests/TestPlugin/DBus/Serialization.hs new file mode 100644 --- /dev/null +++ b/tests/TestPlugin/DBus/Serialization.hs @@ -0,0 +1,102 @@ +module TestPlugin.DBus.Serialization where + +import Data.Aeson +import Data.Int +import qualified Data.Map as M +import Data.Maybe +import Data.Proxy +import qualified Data.Text as T + +import DBus + +import Test.Tasty +import Test.Tasty.QuickCheck as QC + +import System.Tianbar.Plugin.DBus.FromData () +import System.Tianbar.Plugin.DBus.JSON () +import System.Tianbar.Plugin.DBus.Utils (unwrapVariants) + + +tests :: TestTree +tests = testGroup "Serialization" [jsonRoundTrip] + + +-- JSON round-trip identity doesn't make sense for all different Variant types, +-- such as different size integers. Limit the Arbitrary instance to the only +-- ones we care about +newtype WrapVariant = WrapVariant { wrapV :: Variant } + deriving (Eq) + +instance Show WrapVariant where + show = show . wrapV + +instance Arbitrary WrapVariant where + arbitrary = WrapVariant <$> limitedArbitrary + +half :: Gen a -> Gen a +half = scale (`div` 2) + +simpleTypes :: [Type] +simpleTypes = [ TypeBoolean + , TypeInt64 + , TypeDouble + , TypeString + , TypeObjectPath + , TypeVariant + ] + +simpleVariant :: Type -> Gen Variant +simpleVariant TypeBoolean = toVariant <$> (arbitrary :: Gen Bool) +simpleVariant TypeInt64 = toVariant <$> (arbitrary :: Gen Int64) +simpleVariant TypeDouble = toVariant <$> (arbitrary :: Gen Double) +simpleVariant TypeString = (toVariant . T.pack) <$> (arbitrary :: Gen String) +simpleVariant TypeObjectPath = (toVariant . unwrapOP) <$> (arbitrary :: Gen WrapObjectPath) +simpleVariant TypeVariant = (toVariant . wrapV) <$> (half $ arbitrary :: Gen WrapVariant) +simpleVariant typ = error $ show typ ++ " isn't a simple Variant type." + +simpleVariantArray :: Type -> Gen Variant +simpleVariantArray TypeBoolean = unwrapVariants (Proxy :: Proxy Bool) <$> listOf1 (simpleVariant TypeBoolean) +simpleVariantArray TypeInt64 = unwrapVariants (Proxy :: Proxy Int64) <$> listOf1 (simpleVariant TypeInt64) +simpleVariantArray TypeDouble = unwrapVariants (Proxy :: Proxy Double) <$> listOf1 (simpleVariant TypeDouble) +simpleVariantArray TypeString = unwrapVariants (Proxy :: Proxy T.Text) <$> listOf1 (simpleVariant TypeString) +simpleVariantArray TypeObjectPath = unwrapVariants (Proxy :: Proxy ObjectPath) <$> listOf1 (simpleVariant TypeObjectPath) +simpleVariantArray TypeVariant = unwrapVariants (Proxy :: Proxy Variant) <$> listOf1 (simpleVariant TypeVariant) +simpleVariantArray typ = error $ show typ ++ " isn't a simple Variant type." + +simpleVariantDictionary :: Type -> Gen Variant +simpleVariantDictionary TypeBoolean = unwrapVariants (Proxy :: Proxy Bool) <$> stringMapOf1 (simpleVariant TypeBoolean) +simpleVariantDictionary TypeInt64 = unwrapVariants (Proxy :: Proxy Int64) <$> stringMapOf1 (simpleVariant TypeInt64) +simpleVariantDictionary TypeDouble = unwrapVariants (Proxy :: Proxy Double) <$> stringMapOf1 (simpleVariant TypeDouble) +simpleVariantDictionary TypeString = unwrapVariants (Proxy :: Proxy T.Text) <$> stringMapOf1 (simpleVariant TypeString) +simpleVariantDictionary TypeObjectPath = unwrapVariants (Proxy :: Proxy ObjectPath) <$> stringMapOf1 (simpleVariant TypeObjectPath) +simpleVariantDictionary TypeVariant = unwrapVariants (Proxy :: Proxy Variant) <$> stringMapOf1 (simpleVariant TypeVariant) +simpleVariantDictionary typ = error $ show typ ++ " isn't a simple Variant type." + +stringMapOf1 :: Gen a -> Gen (M.Map String a) +stringMapOf1 gen = do + values <- listOf1 gen + keys <- vector (length values) + return $ M.fromList (zip keys values) + +limitedArbitrary :: Gen Variant +limitedArbitrary = oneof $ map (oneof . flip map simpleTypes) [ simpleVariant + , simpleVariantArray + , simpleVariantDictionary + ] + +newtype WrapObjectPath = WrapObjectPath { unwrapOP :: ObjectPath } + deriving (Eq) + +instance Show WrapObjectPath where + show = show . unwrapOP + +instance Arbitrary WrapObjectPath where + arbitrary = (WrapObjectPath . fromJust . parseObjectPath . concatPath) <$> listOf1 arbitraryAlpha + where concatPath :: [String] -> String + concatPath = concat . map ('/':) + arbitraryAlpha :: Gen String + arbitraryAlpha = listOf1 $ elements ['a'..'z'] + +jsonRoundTrip :: TestTree +jsonRoundTrip = QC.testProperty "Variant's FromJSON and ToJSON are inverse of each other" $ + \(WrapVariant val) -> decode (encode val) == Just val diff --git a/tianbar.cabal b/tianbar.cabal --- a/tianbar.cabal +++ b/tianbar.cabal @@ -1,5 +1,5 @@ name: tianbar -version: 1.1.1.1 +version: 1.2.0.0 synopsis: A desktop bar based on WebKit description: A desktop bar using WebKit for rendering as much as possible. @@ -50,9 +50,12 @@ , network , process , random + , scientific , split , text , transformers + , vector + , unordered-containers , utf8-string , xdg-basedir pkgconfig-depends: gtk+-3.0 @@ -71,6 +74,7 @@ , System.Tianbar.Plugin.DBus , System.Tianbar.Plugin.DBus.FromData , System.Tianbar.Plugin.DBus.JSON + , System.Tianbar.Plugin.DBus.Utils , System.Tianbar.Plugin.GSettings , System.Tianbar.Plugin.Socket , System.Tianbar.RequestResponse @@ -89,6 +93,61 @@ hs-source-dirs: src exposed-modules: System.Tianbar.XMonadLog ghc-options: -Wall + +test-suite tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: src, tests + main-is: TestMain.hs + build-depends: base >3 && <5 + , tasty + , tasty-quickcheck + , 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 + , scientific + , split + , text + , transformers + , vector + , unordered-containers + , utf8-string + , xdg-basedir + other-modules: System.Tianbar + , System.Tianbar.Callbacks + , System.Tianbar.Configuration + , System.Tianbar.Server + , System.Tianbar.StrutProperties + , System.Tianbar.Plugin + , System.Tianbar.Plugin.All + , System.Tianbar.Plugin.Combined + , 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.DBus.Utils + , System.Tianbar.Plugin.GSettings + , System.Tianbar.Plugin.Socket + , System.Tianbar.RequestResponse + , System.Tianbar.WebKit + , TestPlugin.DBus.Serialization source-repository head type: git