diff --git a/Manatee/Core/DBus.hs b/Manatee/Core/DBus.hs --- a/Manatee/Core/DBus.hs +++ b/Manatee/Core/DBus.hs @@ -27,17 +27,19 @@ import DBus.MatchRule import DBus.Message (Signal, signalBody, MethodReturn, Error) import DBus.Types -import Data.Maybe (fromMaybe) -import Data.Text.Lazy (Text, empty, append) +import Data.Text.Lazy (Text) import Graphics.UI.Gtk.General.General import Manatee.Core.TH import Manatee.Core.Types import Manatee.Toolkit.General.DBus +import Manatee.Toolkit.General.Maybe import Manatee.Toolkit.General.Misc import System.Posix.Process import System.Posix.Types (ProcessID) import qualified Data.Map as M +import qualified Data.Text.Lazy as TL +import qualified Control.Exception as Exc -- | The daemon bus name. daemonBusName :: Text @@ -77,22 +79,42 @@ renderPathName :: Text renderPathName = "/path" +-- | Generic daemon bus name. +genericDaemonBusName :: Text +genericDaemonBusName = "org.manatee.extension.generic" + +genericDaemonInterfaceName :: Text +genericDaemonInterfaceName = "org.manatee.daemon.interface" + +-- | The daemon path name. +genericDaemonPathName :: Text +genericDaemonPathName = "/path" + +-- | DBus message error. +printDBusMessageError :: String -> String -> IO () +printDBusMessageError funName member = + putStrLn (funName + ++ ": Invalid DBus message " + ++ member + ++ "\nOne possible is extension package older than manatee-core, please make sure all pacages is newest." + ++ "\nPlease report bug to author if still have this problem after update." ) + -- | Build render client name. -- Concat renderBusName and render process id. mkRenderClientName :: ProcessID -> Text -mkRenderClientName processId = append renderBusName $ showText processId +mkRenderClientName processId = TL.append renderBusName $ showText processId -- | Unpack daemon signal from Variant list. --- unpackDaemonSignalArgs_ :: DaemonMember -> [Variant] -> Maybe DaemonSignalArgs -mkFunDec "unpackDaemonSignalArgs_" (unpackVariantList ''DaemonMember ''DaemonSignalArgs) +-- unpackDaemonSignalArgs :: DaemonMember -> [Variant] -> Maybe DaemonSignalArgs +mkFunDec "unpackDaemonSignalArgs" (unpackVariantList ''DaemonMember ''DaemonSignalArgs) -- | Unpack daemon signal from Variant list. --- unpackDaemonBroadcastSignalArgs_ :: DaemonBroadcastMember -> [Variant] -> Maybe DaemonBroadcastSignalArgs -mkFunDec "unpackDaemonBroadcastSignalArgs_" (unpackVariantList ''DaemonBroadcastMember ''DaemonBroadcastSignalArgs) +-- unpackDaemonBroadcastSignalArgs :: DaemonBroadcastMember -> [Variant] -> Maybe DaemonBroadcastSignalArgs +mkFunDec "unpackDaemonBroadcastSignalArgs" (unpackVariantList ''DaemonBroadcastMember ''DaemonBroadcastSignalArgs) -- | Unpack render signal arguments from Variant list. --- unpackRenderSignalArgs_ :: RenderMember -> [Variant] -> Maybe RenderSignalArgs -mkFunDec "unpackRenderSignalArgs_" (unpackVariantList ''RenderMember ''RenderSignalArgs) +-- unpackRenderSignalArgs :: RenderMember -> [Variant] -> Maybe RenderSignalArgs +mkFunDec "unpackRenderSignalArgs" (unpackVariantList ''RenderMember ''RenderSignalArgs) -- | Pack daemon signal argument to Variant list. -- packDaemonSignalArgs :: DaemonSignalArgs -> [Variant] @@ -128,21 +150,21 @@ daemonBroadcastPathName (showText memberName) daemonBroadcastInterfaceName - empty -- send to any client that interested this signal + TL.empty -- send to any client that interested this signal (packDaemonBroadcastSignalArgs args) -- | Build daemon broadcast match rule. mkDaemonBroadcastMatchRule :: Client -> (DaemonBroadcastMember, DaemonBroadcastSignalArgs -> IO ()) -> IO () mkDaemonBroadcastMatchRule client (member, fun) = onSignal client matchRule $ \_ signal -> - fun $ pickDaemonBroadcastSignalArgs member signal + pickDaemonBroadcastSignalArgs member signal >?>= fun where matchRule = mkMatchRule (Just Signal) - empty + TL.empty daemonBroadcastInterfaceName (showText member) daemonBroadcastPathName - empty + TL.empty [] -- | Build daemon signal. @@ -166,10 +188,10 @@ mkDaemonMatchRule client (member, fun) = -- Use postGUIAsync wrap DBus action to protect gtk+ main thread. onSignal client matchRule $ \_ signal -> - postGUIAsync $ fun $ pickDaemonSignalArgs member signal + pickDaemonSignalArgs member signal >?>= (postGUIAsync . fun) where matchRule = mkMatchRule (Just Signal) - empty + TL.empty daemonInterfaceName (showText member) daemonPathName @@ -181,12 +203,22 @@ mkDaemonMatchRules client = mapM_ (mkDaemonMatchRule client) -- | Pick DaemonSignalArgs. -pickDaemonSignalArgs :: DaemonMember -> Signal -> DaemonSignalArgs -pickDaemonSignalArgs member signal = unpackDaemonSignalArgs member $ signalBody signal +pickDaemonSignalArgs :: DaemonMember -> Signal -> IO (Maybe DaemonSignalArgs) +pickDaemonSignalArgs member signal = + Exc.catch + (return $ unpackDaemonSignalArgs member $ signalBody signal) + (\ (_ :: Exc.SomeException) -> + printDBusMessageError "pickDaemonSignalArgs" (show member) + >> return Nothing) -- | Pick DaemonBroadcastSignalArgs. -pickDaemonBroadcastSignalArgs :: DaemonBroadcastMember -> Signal -> DaemonBroadcastSignalArgs -pickDaemonBroadcastSignalArgs member signal = unpackDaemonBroadcastSignalArgs member $ signalBody signal +pickDaemonBroadcastSignalArgs :: DaemonBroadcastMember -> Signal -> IO (Maybe DaemonBroadcastSignalArgs) +pickDaemonBroadcastSignalArgs member signal = + Exc.catch + (return $ unpackDaemonBroadcastSignalArgs member $ signalBody signal) + (\ (_ :: Exc.SomeException) -> + printDBusMessageError "pickDaemonBroadcastSignalArgs" (show member) + >> return Nothing) -- | Build render signal. -- If signal argument not match render member name. @@ -212,7 +244,7 @@ processId <- getProcessID let matchRule = mkMatchRule (Just Signal) - empty + TL.empty renderInterfaceName (showText member) renderPathName @@ -220,7 +252,7 @@ [] -- Use postGUIAsync wrap DBus action to protect gtk+ main thread. onSignal client matchRule $ \_ signal -> - postGUIAsync $ fun $ pickRenderSignalArgs member signal + pickRenderSignalArgs member signal >?>= (postGUIAsync . fun) -- | Build render process match rule for catch signal. -- Simliar 'mkRenderMatchRule', but don't use 'postGUIAsync' wrap all signal handler. @@ -231,43 +263,27 @@ processId <- getProcessID let matchRule = mkMatchRule (Just Signal) - empty + TL.empty renderInterfaceName (showText member) renderPathName (mkRenderClientName processId) [] onSignal client matchRule $ \_ signal -> - fun $ pickRenderSignalArgs member signal + pickRenderSignalArgs member signal >?>= fun -- | Build render math rule list. mkRenderMatchRules :: Client -> [(RenderMember, RenderSignalArgs -> IO ())] -> IO () mkRenderMatchRules client = mapM_ (mkRenderMatchRule client) -- | Pick RenderSignalArgs. -pickRenderSignalArgs :: RenderMember -> Signal -> RenderSignalArgs -pickRenderSignalArgs member signal = unpackRenderSignalArgs member $ signalBody signal - --- | Unpack daemon signal from Variant list. --- Report error if mismatch. -unpackDaemonSignalArgs member args = - fromMaybe - (error $ "unpackDaemonSignalArgs: Miss pattern for " ++ show member) - (unpackDaemonSignalArgs_ member args) - --- | Unpack daemon signal from Variant list. --- Report error if mismatch. -unpackDaemonBroadcastSignalArgs member args = - fromMaybe - (error $ "unpackDaemonBroadcastSignalArgs: Miss pattern for " ++ show member) - (unpackDaemonBroadcastSignalArgs_ member args) - --- | Unpack render signal arguments from Variant list. --- Report error when mismatch. -unpackRenderSignalArgs member args = - fromMaybe - (error $ "unpackRenderSignalArgs: Miss pattern for " ++ show member) - (unpackRenderSignalArgs_ member args) +pickRenderSignalArgs :: RenderMember -> Signal -> IO (Maybe RenderSignalArgs) +pickRenderSignalArgs member signal = + Exc.catch + (return $ unpackRenderSignalArgs member $ signalBody signal) + (\ (_ :: Exc.SomeException) -> + printDBusMessageError "pickRenderSignalArgs" (show member) + >> return Nothing) -- | Wait broadcast exit signal. -- This function is useful for listen exit status of main process of manatee. @@ -286,14 +302,14 @@ forM_ methods $ \ (name, member) -> do let object = LocalObject $ M.fromList [(mkInterfaceName_ daemonInterfaceName ,Interface $ M.fromList [(mkMemberName_ name, member)])] - client <- mkSessionClientWithName (append daemonBusName name) + client <- mkSessionClientWithName (TL.append daemonBusName name) export client (mkObjectPath_ daemonPathName) object -- | Call daemon method. callDaemonMethod :: Client -> Text -> [Variant] -> IO (Either Error MethodReturn) callDaemonMethod client methodName = callProxyBlocking client (Proxy (RemoteObject - (mkBusName_ (append daemonBusName methodName)) + (mkBusName_ (TL.append daemonBusName methodName)) (mkObjectPath_ daemonPathName)) (mkInterfaceName_ daemonInterfaceName)) (mkMemberName_ methodName) [] @@ -302,8 +318,69 @@ callDaemonMethodAsync :: Client -> Text -> [Variant] -> (Error -> IO ()) -> (MethodReturn -> IO ()) -> IO () callDaemonMethodAsync client methodName = callProxy client (Proxy (RemoteObject - (mkBusName_ (append daemonBusName methodName)) + (mkBusName_ (TL.append daemonBusName methodName)) (mkObjectPath_ daemonPathName)) (mkInterfaceName_ daemonInterfaceName)) (mkMemberName_ methodName) [] +-- | Check daemon signal argument. +-- Return False if mismatch. +mkFunDec "checkGenericDaemonSignalArgs" (checkSignalArgs ''GenericDaemonMember ''GenericDaemonSignalArgs) + +-- | Unpack daemon signal from Variant list. +-- unpackGenericDaemonSignalArgs :: GenericDaemonMember -> [Variant] -> Maybe GenericDaemonSignalArgs +mkFunDec "unpackGenericDaemonSignalArgs" (unpackVariantList ''GenericDaemonMember ''GenericDaemonSignalArgs) + +-- | Pack daemon signal argument to Variant list. +-- packGenericDaemonSignalArgs :: GenericDaemonSignalArgs -> [Variant] +$(packVariantList "packGenericDaemonSignalArgs" ''GenericDaemonSignalArgs) + +-- | Build daemon signal. +-- If signal argument not match daemon member name. +mkGenericDaemonSignal :: Client -> Text -> GenericDaemonMember -> GenericDaemonSignalArgs -> IO () +mkGenericDaemonSignal client busName memberName args + | checkGenericDaemonSignalArgs memberName args -- check signal argument before emit signal. + = emitSignal client signal + | otherwise + = putStrLn $ "mkGenericDaemonSignal CRITICAL: Invalid argument for dbus daemon member: " ++ show memberName + where signal = mkMessageSignal + genericDaemonPathName + (showText memberName) + genericDaemonInterfaceName + (packGenericBusName busName) + (packGenericDaemonSignalArgs args) + +-- | Build daemon match rule. +mkGenericDaemonMatchRule :: Client -> Text -> (GenericDaemonMember, GenericDaemonSignalArgs -> IO ()) -> IO () +mkGenericDaemonMatchRule client busName (member, fun) = + onSignal client matchRule $ \_ signal -> + pickGenericDaemonSignalArgs member signal >?>= fun + where matchRule = mkMatchRule + (Just Signal) + TL.empty + genericDaemonInterfaceName + (showText member) + genericDaemonPathName + (packGenericBusName busName) + [] + +-- | Pick GenericDaemonSignalArgs. +pickGenericDaemonSignalArgs :: GenericDaemonMember -> Signal -> IO (Maybe GenericDaemonSignalArgs) +pickGenericDaemonSignalArgs member signal = + Exc.catch + (return $ unpackGenericDaemonSignalArgs member $ signalBody signal) + (\ (_ :: Exc.SomeException) -> + printDBusMessageError "pickGenericDaemonSignalArgs" (show member) + >> return Nothing) + +-- | Pack generic bus name. +packGenericBusName :: Text -> Text +packGenericBusName name = + TL.concat [genericDaemonBusName, ".", name] + +-- | Apply generic action. +parseGenericSignalArgs :: GenericDaemonSignalArgs -> ([String] -> a) -> (a -> IO ()) -> IO () +parseGenericSignalArgs args@(GenericArgs _ options) paser action = + Exc.catch (action $ paser options) + $ \ (_ :: Exc.SomeException) -> + putStrLn $ "Parse " ++ show args ++ " failed, please make sure transfer valid DBus arguments." diff --git a/Manatee/Core/Types.hs b/Manatee/Core/Types.hs --- a/Manatee/Core/Types.hs +++ b/Manatee/Core/Types.hs @@ -292,6 +292,12 @@ data DaemonBroadcastSignalArgs = ExitDaemonProcessArgs deriving (Show, Eq, Ord) +data GenericDaemonMember = Generic + deriving (Show, Eq, Ord) + +data GenericDaemonSignalArgs = GenericArgs String [String] + deriving (Show, Eq, Ord) + data AnythingSearchArgs = GlobalSearchArgs | InteractiveSearchArgs AnythingInteractiveType [String] deriving (Show, Eq, Ord, Read) diff --git a/Manatee/Toolkit/Gio/Gio.hs b/Manatee/Toolkit/Gio/Gio.hs --- a/Manatee/Toolkit/Gio/Gio.hs +++ b/Manatee/Toolkit/Gio/Gio.hs @@ -187,13 +187,18 @@ pixbuf <- iconThemeLoadIcon iconTheme "unknown" 24 IconLookupUseBuiltin return $ maybeError pixbuf "getFileIconPixbuf: can't get `unknown` icon pixbuf." +-- | Find icon pixbuf. +findIconPixbuf :: FileIconPixbufDatabase -> String -> Maybe Pixbuf +findIconPixbuf database fMime = + fmap snd $ findMinMatch database (\ mime _ -> mime == fMime) + -- | Update file icon database. updateFileIconPixbufDatabase :: FileInfoClass info => info -> FileIconPixbufDatabase -> IO FileIconPixbufDatabase updateFileIconPixbufDatabase info database = do let fMime = maybeError (fileInfoGetContentType info) "getFileIconPixbuf: can't get file content type." - case findMinMatch database (\ mime _ -> mime == fMime) of - Just _ -> return database + case findIconPixbuf database fMime of + Just _ -> return database Nothing -> do pixbuf <- fileInfoGetIconPixbuf info return $ M.insert fMime pixbuf database @@ -202,8 +207,8 @@ updateFileIconPixbufDatabaseWithFilePath :: FilePath -> FileIconPixbufDatabase -> IO FileIconPixbufDatabase updateFileIconPixbufDatabaseWithFilePath filepath database = do (_, fMime) <- contentTypeGuess filepath "" 0 - case findMinMatch database (\ mime _ -> mime == fMime) of - Just _ -> return database + case findIconPixbuf database fMime of + Just _ -> return database Nothing -> do pixbuf <- getIconPixbuf (contentTypeGetIcon fMime) return $ M.insert fMime pixbuf database diff --git a/manatee-core.cabal b/manatee-core.cabal --- a/manatee-core.cabal +++ b/manatee-core.cabal @@ -1,11 +1,13 @@ name: manatee-core -version: 0.0.5 +version: 0.0.6 Cabal-Version: >= 1.6 license: GPL-3 license-file: LICENSE copyright: (c) 2009 ~ 2010 Andy Stewart synopsis: The core of Manatee. description: manatee-core is core package of Manatee (Haskell/Gtk+ Integrated Live Environment) + . + Video at (Select 720p HD) at : . To provide basic communication protocol and toolkit. .