libvirt-hs 0.1 → 0.1.2
raw patch · 4 files changed
+156/−11 lines, 4 files
Files
- System/LibVirt/Errors.chs +1/−1
- System/LibVirt/Foreign.chs +97/−3
- Test.hs +56/−5
- libvirt-hs.cabal +2/−2
System/LibVirt/Errors.chs view
@@ -14,7 +14,7 @@ where import qualified Control.Exception as E-import Data.Generics+import Data.Generics (Data, Typeable) import Foreign import Foreign.C.Types import Foreign.C.String
System/LibVirt/Foreign.chs view
@@ -18,10 +18,24 @@ NodeInfo (..), SchedParameterType (..), ConnectCredential (..),+ DomainEventID (..),+ DomainEventType (..),+ DomainEventDefinedDetailType (..),+ DomainEventUndefinedDetailType (..),+ DomainEventStartedDetailType (..),+ DomainEventSuspendedDetailType (..),+ DomainEventResumedDetailType (..),+ DomainEventStoppedDetailType (..),+ DomainEventShutdownDetailType (..),+ FreeCallback,+ ConnectDomainEventGenericCallback,+ ConnectDomainEventCallback, -- * Connection management functions initialize, openConnection, closeConnection,+ connectSetKeepAlive,+ connectGetCapabilities, -- * Domains management functions runningDomainsCount, definedDomainsCount,@@ -33,7 +47,7 @@ -- * Domains control createDomain, createDomainXML,- destroyDomain, + destroyDomain, shutdownDomain, rebootDomain, suspendDomain, resumeDomain, saveDomain, restoreDomain,@@ -49,11 +63,22 @@ createNetwork, refNetwork, freeNetwork, getNetworkName,- getNetworkXML+ getNetworkXML,++ -- * callback management+ eventRegisterDefaultImpl,+ eventRunDefaultImpl,+ connectDomainEventRegister,+ connectDomainEventRegisterAny,+ connectDomainEventDeregisterAny,+ mkConnectDomainEventGenericCallback,+ mkConnectDomainEventCallback,+ mkFreeCallback+ ) where import Data.Bits-import Data.Generics+import Data.Generics () import Foreign import Foreign.C.Types import Foreign.C.String@@ -69,6 +94,9 @@ flags2int :: (Enum f, Num a) => [f] -> a flags2int list = fromIntegral $ foldr (.|.) 0 (map fromEnum list) +flag2int :: (Enum f, Num a) => f -> a+flag2int = fromIntegral . fromEnum+ data DomainInfo = DomainInfo { diState :: DomainState, diMaxMem :: Integer,@@ -82,7 +110,17 @@ {# enum DomainState {underscoreToCase} deriving (Eq, Show) #} {# enum DomainCreateFlags {underscoreToCase} deriving (Eq, Show) #} {# enum DomainXMLFlags {underscoreToCase} deriving (Eq, Show) #}+{# enum DomainEventID {underscoreToCase} deriving (Eq, Show) #}+{# enum DomainEventType {underscoreToCase} deriving (Eq, Show) #}+{# enum DomainEventDefinedDetailType {underscoreToCase} deriving (Eq, Show) #}+{# enum DomainEventUndefinedDetailType {underscoreToCase} deriving (Eq, Show) #}+{# enum DomainEventStartedDetailType {underscoreToCase} deriving (Eq, Show) #}+{# enum DomainEventSuspendedDetailType {underscoreToCase} deriving (Eq, Show) #}+{# enum DomainEventResumedDetailType {underscoreToCase} deriving (Eq, Show) #}+{# enum DomainEventStoppedDetailType {underscoreToCase} deriving (Eq, Show) #}+{# enum DomainEventShutdownDetailType {underscoreToCase} deriving (Eq, Show) #} + data NetworkXMLFlags = NetworkXML deriving (Eq, Show, Enum) @@ -303,4 +341,60 @@ {# fun virNetworkGetXMLDesc as getNetworkXML { networkToPtr `Network', flags2int `[NetworkXMLFlags]' } -> `String' #}++{# fun virConnectDomainEventRegisterAny as connectDomainEventRegisterAny+ `(Storable a)' =>+ { connectionToPtr `Connection',+ domainToPtr `Domain',+ flag2int `DomainEventID',+ castFunPtr `FunPtr (ConnectDomainEventCallback a)',+ castPtr `Ptr a',+ id `FunPtr FreeCallback'+ } -> `Int' exceptionOnMinusOne* #}++{# fun virConnectDomainEventDeregisterAny as connectDomainEventDeregisterAny+ { connectionToPtr `Connection',+ fromIntegral `Int'+ } -> `Int' exceptionOnMinusOne* #}++{# fun virEventRegisterDefaultImpl as eventRegisterDefaultImpl+ { } -> `Int'exceptionOnMinusOne* #}++{# fun virConnectSetKeepAlive as connectSetKeepAlive+ { connectionToPtr `Connection',+ id `CInt',+ id `CUInt'+ } -> `Int' exceptionOnMinusOne* #}++{# fun virConnectDomainEventRegister as connectDomainEventRegister+ { connectionToPtr `Connection',+ castFunPtr `FunPtr (ConnectDomainEventCallback a)',+ castPtr `Ptr a',+ id `FunPtr FreeCallback'+ } -> `Int' exceptionOnMinusOne* #}++{# fun virEventRunDefaultImpl as eventRunDefaultImpl+ {} -> `Int' exceptionOnMinusOne* #}++-- | Provides capabilities of the hypervisor / driver.+{# fun virConnectGetCapabilities as connectGetCapabilities+ { connectionToPtr `Connection' } -> `String' #}+++type ConnectDomainEventGenericCallback a = Connection -> Domain -> Ptr a -> IO ()+type FreeCallback = Ptr () -> IO ()+++type ConnectDomainEventCallback a = Connection -> Domain -> Int -> Int -> Ptr a -> IO ()++foreign import ccall "wrapper"+ mkConnectDomainEventCallback :: ConnectDomainEventCallback a+ -> IO (FunPtr (ConnectDomainEventCallback a))++foreign import ccall "wrapper"+ mkConnectDomainEventGenericCallback :: ConnectDomainEventGenericCallback a+ -> IO (FunPtr (ConnectDomainEventGenericCallback a))++foreign import ccall "wrapper"+ mkFreeCallback :: FreeCallback -> IO (FunPtr FreeCallback)
Test.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE ScopedTypeVariables #-} import Control.Monad+import Control.Concurrent import System.Environment+import Foreign import System.LibVirt @@ -11,11 +13,14 @@ main = do args <- getArgs case args of- ["test"] -> initialize >> withConnection uri doTest- ["list-nets"] -> initialize >> withConnection uri listNets- ["start", domain] -> initialize >> withConnection uri (start domain)- ["stop", domain] -> initialize >> withConnection uri (stop domain)- other -> putStrLn "Usage: Test <test | list-nets | start DOMAIN | stop DOMAIN>"+ ["test"] -> initialize >> withConnection uri doTest+ ["list-nets"] -> initialize >> withConnection uri listNets+ ["start", domain] -> initialize >> withConnection uri (start domain)+ ["stop", domain] -> initialize >> withConnection uri (stop domain)+ ["destroy", domain] -> initialize >> withConnection uri (destroy domain)+ ["callback", domain] -> initialize >> eventRegisterDefaultImpl >> withConnection uri (doTest1 domain)+ ["capabilities"] -> initialize >> withConnection uri (\c -> connectGetCapabilities c >>= putStrLn)+ other -> putStrLn "Usage: Test <test | list-nets | start DOMAIN | stop DOMAIN | destroy DOMAIN | callback DOMAIN | capabilities>" start :: String -> Connection -> IO () start domain conn = do@@ -35,6 +40,15 @@ print e) return () +destroy:: String -> Connection -> IO ()+destroy domain conn = do+ putStrLn $ "Destroing down " ++ domain ++ "..."+ dom <- lookupDomainName conn domain+ destroyDomain dom `catchVirtError` (\e -> do+ putStrLn "Error:"+ print e)+ return ()+ doTest :: Connection -> IO () doTest conn = do putStrLn $ "Defined domains:"@@ -58,4 +72,41 @@ putStrLn "Running networks:" names <- runningNetworksNames conn forM_ names putStrLn++doTest1 domain conn = do++ doTest conn+ dom <- lookupDomainName conn domain+ print $ fromEnum DomainEventIdLifecycle+ callback <- mkConnectDomainEventCallback $ \conn dom event detail _o -> do+ print conn+ print =<< getDomainInfo dom+ let ev = toEnum event+ print ev+ case ev of+ DomainEventDefined -> print (toEnum detail ::DomainEventDefinedDetailType)+ DomainEventUndefined -> print (toEnum detail ::DomainEventUndefinedDetailType)+ DomainEventStarted -> print (toEnum detail :: DomainEventStartedDetailType)+ DomainEventSuspended -> print (toEnum detail :: DomainEventSuspendedDetailType)+ DomainEventResumed -> print (toEnum detail :: DomainEventResumedDetailType)+ DomainEventStopped -> print (toEnum detail :: DomainEventStoppedDetailType)+ DomainEventShutdown -> print (toEnum detail :: DomainEventShutdownDetailType)+ print "callback"+ callbackFree <- mkFreeCallback $ \a -> print "free"+ --start domain conn+ --threadDelay (10*1000000)+ print callback+ print callbackFree+ print conn+ print dom+ print =<< getDomainInfo dom+ connectDomainEventRegisterAny conn (dom) + DomainEventIdLifecycle+ (callback) -- callback+ (nullPtr :: Ptr Int) + (callbackFree) -- callbackFree+ forkIO . forever $ eventRunDefaultImpl+ getLine+ freeHaskellFunPtr callback+ freeHaskellFunPtr callbackFree
libvirt-hs.cabal view
@@ -1,5 +1,5 @@ Name: libvirt-hs-Version: 0.1+Version: 0.1.2 Synopsis: FFI bindings to libvirt virtualization API (http://libvirt.org) @@ -41,7 +41,7 @@ Build-tools: c2hs - Extra-libraries: "virt"+ pkgconfig-depends: libvirt Source-repository head type: git