manatee-core 0.0.5 → 0.0.6
raw patch · 4 files changed
+144/−54 lines, 4 files
Files
- Manatee/Core/DBus.hs +126/−49
- Manatee/Core/Types.hs +6/−0
- Manatee/Toolkit/Gio/Gio.hs +9/−4
- manatee-core.cabal +3/−1
Manatee/Core/DBus.hs view
@@ -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."
Manatee/Core/Types.hs view
@@ -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)
Manatee/Toolkit/Gio/Gio.hs view
@@ -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
manatee-core.cabal view
@@ -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 : <http://www.youtube.com/watch?v=weS6zys3U8k> <http://v.youku.com/v_show/id_XMjI2MDMzODI4.html> . To provide basic communication protocol and toolkit. .