tianbar 1.1.1.1 → 1.2.0.0
raw patch · 14 files changed
+474/−100 lines, 14 filesdep +scientificdep +tastydep +tasty-quickcheck
Dependencies added: scientific, tasty, tasty-quickcheck, unordered-containers, vector
Files
- README.md +2/−2
- scripts/dbus.js +55/−12
- scripts/ibus.js +1/−1
- scripts/network.js +4/−4
- scripts/power.js +8/−10
- scripts/volume.js +74/−32
- src/System/Tianbar/Plugin/DBus.hs +24/−3
- src/System/Tianbar/Plugin/DBus/FromData.hs +4/−7
- src/System/Tianbar/Plugin/DBus/JSON.hs +104/−25
- src/System/Tianbar/Plugin/DBus/Utils.hs +22/−0
- src/System/Tianbar/WebKit.hs +4/−3
- tests/TestMain.hs +10/−0
- tests/TestPlugin/DBus/Serialization.hs +102/−0
- tianbar.cabal +60/−1
README.md view
@@ -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
scripts/dbus.js view
@@ -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 }; });
scripts/ibus.js view
@@ -23,7 +23,7 @@ bus.getProperty( 'org.freedesktop.IBus',- '/org/freedesktop/IBus',+ dbus.toObjectPath('/org/freedesktop/IBus'), 'org.freedesktop.IBus', 'GlobalEngine' ).then(function (result) {
scripts/network.js view
@@ -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();
scripts/power.js view
@@ -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(); }); };
scripts/volume.js view
@@ -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 () {
src/System/Tianbar/Plugin/DBus.hs view
@@ -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
src/System/Tianbar/Plugin/DBus/FromData.hs view
@@ -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
src/System/Tianbar/Plugin/DBus/JSON.hs view
@@ -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)
+ src/System/Tianbar/Plugin/DBus/Utils.hs view
@@ -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"
src/System/Tianbar/WebKit.hs view
@@ -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
+ tests/TestMain.hs view
@@ -0,0 +1,10 @@+import Test.Tasty++import qualified TestPlugin.DBus.Serialization+++main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [ TestPlugin.DBus.Serialization.tests+ ]
+ tests/TestPlugin/DBus/Serialization.hs view
@@ -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
tianbar.cabal view
@@ -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