packages feed

libvirt-hs (empty) → 0.1

raw patch · 8 files changed

+663/−0 lines, 8 filesdep +basedep +sybsetup-changed

Dependencies added: base, syb

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, IlyaPortnov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of IlyaPortnov nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/LibVirt.hs view
@@ -0,0 +1,16 @@++module System.LibVirt+  (module System.LibVirt.Foreign,+   module System.LibVirt.Errors,+   withConnection+  ) where++import System.LibVirt.Foreign+import System.LibVirt.Errors+import Control.Exception(finally)++withConnection :: String -> (Connection -> IO a) -> IO a+withConnection uri fn = do+  conn <- openConnection uri+  finally (fn conn) (closeConnection conn)+
+ System/LibVirt/Errors.chs view
@@ -0,0 +1,155 @@+{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, StandaloneDeriving, DeriveDataTypeable #-}++{# context lib="virt" prefix="vir" #}++#include <libvirt/virterror.h>++module System.LibVirt.Errors+  (Error (..), ErrorLevel (..),+   ErrorDomain (..), ErrorNumber (..),+   catchVirtError,+   exceptionOnMinusOne,+   ptrToConnection, ptrToDomain, ptrToNetwork,+   connectionToPtr, domainToPtr, networkToPtr)+  where++import qualified Control.Exception as E+import Data.Generics+import Foreign+import Foreign.C.Types+import Foreign.C.String++{# import System.LibVirt.Internal #}++{# enum ErrorLevel {underscoreToCase} deriving (Eq, Show) #}+deriving instance Data ErrorLevel+deriving instance Typeable ErrorLevel++{# enum ErrorDomain {underscoreToCase} deriving (Eq, Show) #}+deriving instance Data ErrorDomain+deriving instance Typeable ErrorDomain++data Error = Error {+  veCode :: ErrorNumber,+  veDomain :: ErrorDomain,+  veMessage :: String,+  veLevel :: ErrorLevel,+  veConnect :: Connection,+  veDom :: Domain,+  veStr1 :: Maybe String,+  veStr2 :: Maybe String,+  veStr3 :: Maybe String,+  veInt1 :: Int,+  veInt2 :: Int,+  veNet :: Network }+  deriving (Eq, Show, Data, Typeable)++instance E.Exception Error++{# pointer *virErrorPtr as VirtErrorPtr -> Error #}++{# enum ErrorNumber {underscoreToCase} deriving (Eq, Show) #}++deriving instance Data ErrorNumber+deriving instance Typeable ErrorNumber++data UnknownError = UnknownError+  deriving (Eq, Show, Data, Typeable)++instance E.Exception UnknownError++peekCString' :: CString -> IO (Maybe String)+peekCString' ptr+  | ptr == nullPtr = return Nothing+  | otherwise = Just `fmap` peekCString ptr++convertError :: Ptr () -> IO (Maybe Error)+convertError ptr+  | ptr == nullPtr = return Nothing+  | otherwise = do+  let err = castPtr ptr :: VirtErrorPtr+  code <- {# get Error->code #} err+  domain <- {# get Error->domain #} err+  message <- peekCString =<< {# get Error->message #} err+  level <- {# get Error->level #} err+  conn <- ptrToConnection' =<< {# get Error->conn #} err+  dom  <- ptrToDomain' =<< {# get Error->dom #} err+  str1 <- peekCString' =<< {# get Error->str1 #} err+  str2 <- peekCString' =<< {# get Error->str2 #} err+  str3 <- peekCString' =<< {# get Error->str3 #} err+  int1 <- {# get Error->int1 #} err+  int2 <- {# get Error->int2 #} err+  net  <- ptrToNetwork' =<< {# get Error->net #} err+  return $ Just $ Error {+             veCode = toEnum $ fromIntegral code,+             veDomain = toEnum $ fromIntegral domain,+             veMessage = message,+             veLevel = toEnum $ fromIntegral level,+             veConnect = conn,+             veDom = dom,+             veStr1 = str1,+             veStr2 = str2,+             veStr3 = str3,+             veInt1 = fromIntegral int1,+             veInt2 = fromIntegral int2,+             veNet = net }++{# fun virGetLastError as getLastError { } -> `Maybe Error' convertError* #}++catchVirtError :: IO a -> (Error -> IO b) -> IO (Either b a)+catchVirtError m f = do+  (Right `fmap` m) `E.catch` (\e -> Left `fmap` f e)++exceptionOnMinusOne :: CInt -> IO Int+exceptionOnMinusOne x = do+  if x == -1+    then handleError' (fromIntegral x)+    else return (fromIntegral x)++handleError :: IO a+handleError = do+    merr <- getLastError+    case merr of+      Just err -> E.throw err+      Nothing  -> E.throw UnknownError++handleError' :: a -> IO a+handleError' x = do+    merr <- getLastError+    case merr of+      Just err -> E.throw err+      Nothing  -> return x++ptrToConnection :: Ptr () -> IO Connection+ptrToConnection ptr+  | ptr == nullPtr = handleError+  | otherwise      = return $ Connection (castPtr ptr)++ptrToConnection' :: Ptr () -> IO Connection+ptrToConnection' ptr = return $ Connection (castPtr ptr)++connectionToPtr :: Connection -> Ptr ()+connectionToPtr (Connection ptr) = castPtr ptr++ptrToDomain :: Ptr () -> IO Domain+ptrToDomain ptr+  | ptr == nullPtr = handleError+  | otherwise      = return $ Domain (castPtr ptr)++ptrToDomain' :: Ptr () -> IO Domain+ptrToDomain' ptr = return $ Domain (castPtr ptr)++domainToPtr :: Domain -> Ptr ()+domainToPtr (Domain ptr) = castPtr ptr++ptrToNetwork :: Ptr () -> IO Network+ptrToNetwork ptr+  | ptr == nullPtr = handleError+  | otherwise      = return $ Network (castPtr ptr)++ptrToNetwork' :: Ptr () -> IO Network+ptrToNetwork' ptr = return $ Network (castPtr ptr)++networkToPtr :: Network -> Ptr ()+networkToPtr (Network ptr) = castPtr ptr+
+ System/LibVirt/Foreign.chs view
@@ -0,0 +1,306 @@+{-# LANGUAGE ForeignFunctionInterface, StandaloneDeriving, DeriveDataTypeable, EmptyDataDecls #-}++{# context lib="virt" prefix="vir" #}++#include <libvirt/libvirt.h>++module System.LibVirt.Foreign+  (-- * Types+   Connection, Domain, Network,+   DomainID,+   DomainInfo (..),+   DomainState (..),+   Stream,+   DomainCreateFlags (..),+   DomainXMLFlags (..),+   SecurityLabel (..),+   SecurityModel (..),+   NodeInfo (..),+   SchedParameterType (..),+   ConnectCredential (..),++   -- * Connection management functions+   initialize,+   openConnection, closeConnection,++   -- * Domains management functions+   runningDomainsCount, definedDomainsCount,+   runningDomainsIDs, definedDomainsNames,+   lookupDomainID, lookupDomainName,+   getDomainInfo, getDomainXML,+   defineDomainXML, undefineDomain,+   getDomainID, getDomainName,++   -- * Domains control+   createDomain, createDomainXML,+   destroyDomain, +   shutdownDomain, rebootDomain,+   suspendDomain, resumeDomain,+   saveDomain, restoreDomain,+   refDomain, freeDomain,++   -- * Networks management+   getNetworkConnection,+   runningNetworksCount, definedNetworksCount,+   runningNetworksNames, definedNetworksNames,+   lookupNetworkName, lookupNetworkUUID,+   createNetworkXML, defineNetworkXML,+   undefineNetwork, destroyNetwork,+   createNetwork,+   refNetwork, freeNetwork,+   getNetworkName,+   getNetworkXML+  ) where++import Data.Bits+import Data.Generics+import Foreign+import Foreign.C.Types+import Foreign.C.String++{# import System.LibVirt.Internal #}+{# import System.LibVirt.Errors #}++cIntConv = fromIntegral++cuchar2state :: CUChar -> DomainState+cuchar2state c = toEnum (fromIntegral c)++flags2int :: (Enum f, Num a) => [f] -> a+flags2int list = fromIntegral $ foldr (.|.) 0 (map fromEnum list)++data DomainInfo = DomainInfo {+  diState :: DomainState,+  diMaxMem :: Integer,+  diMemory :: Integer,+  diNrVirtCPU :: Int,+  diCPUTime :: Integer }+  deriving (Eq, Show)++{# pointer *virDomainInfo as DomainInfoPtr -> DomainInfo #}++{# enum DomainState {underscoreToCase} deriving (Eq, Show) #}+{# enum DomainCreateFlags {underscoreToCase} deriving (Eq, Show) #}+{# enum DomainXMLFlags {underscoreToCase} deriving (Eq, Show) #}++data NetworkXMLFlags = NetworkXML+  deriving (Eq, Show, Enum)++{# pointer *virStreamPtr as Stream newtype #}++data SecurityLabel = SecurityLabel {+  slLabel :: String,+  slEnforcing :: Int }+  deriving (Eq, Show)++{# pointer *virSecurityLabelPtr as SecurityLabelPtr -> SecurityLabel #}++data SecurityModel = SecurityModel {+  smModel :: String,+  smDOI :: String }+  deriving (Eq, Show)++{# pointer *virSecurityModelPtr as SecurityModelPtr -> SecurityModel #}++data NodeInfo = NodeInfo {+  niModel :: String,+  niMemory :: CULong,+  niCPUs :: CUInt,+  niMHz :: CUInt,+  niNodes :: CUInt,+  niSockets :: CUInt,+  niCores :: CUInt,+  niThreads :: CUInt }+  deriving (Eq, Show)++{# pointer *virNodeInfoPtr as NodeInfoPtr -> NodeInfo #}++{# enum SchedParameterType {underscoreToCase} deriving (Eq, Show) #}++data ConnectCredential = ConnectCredential {+  ccType :: Int,+  ccPrompt :: String,+  ccChallenge :: String,+  ccDefresult :: String,+  ccResult :: String,+  ccResultLen :: Integer }+  deriving (Eq, Show)++{# pointer *virConnectCredentialPtr as ConnectCredentialPtr -> ConnectCredential #}++{# fun virInitialize as initialize { } -> `Int' exceptionOnMinusOne* #}++{# fun virConnectOpen as openConnection+    { `String' } -> `Connection' ptrToConnection* #}++{# fun virConnectClose as closeConnection+    { connectionToPtr `Connection' } -> `Int' exceptionOnMinusOne* #}++{# fun virConnectNumOfDomains as runningDomainsCount+    { connectionToPtr `Connection' } -> `Int' exceptionOnMinusOne* #}++type DomainID = CInt++runningDomainsIDs :: Connection -> IO [DomainID]+runningDomainsIDs conn = do+  cn <- {# call virConnectNumOfDomains #} (connectionToPtr conn)+  let n = fromIntegral cn+  r <- allocaArray n $ \arr -> do+          r <- {# call virConnectListDomains #}+                  (connectionToPtr conn) arr cn+          peekArray n arr+  return r++definedDomainsNames :: Connection -> IO [String]+definedDomainsNames conn = do+  cn <- {# call virConnectNumOfDefinedDomains #} (connectionToPtr conn)+  let n = fromIntegral cn+  allocaArray n $ \nptr -> do+    {# call virConnectListDefinedDomains #}+        (connectionToPtr conn) nptr cn+    mapM peekCString =<< peekArray n nptr++{# fun virDomainLookupByID as lookupDomainID+    { connectionToPtr `Connection',+      id              `DomainID'    } -> `Domain' ptrToDomain* #}++{# fun virDomainGetID as getDomainID+    { domainToPtr `Domain' } -> `DomainID' cIntConv #}++{# fun virDomainGetName as getDomainName+    { domainToPtr `Domain' } -> `String' #}++{# fun virDomainLookupByName as lookupDomainName+    { connectionToPtr `Connection',+                      `String'      } -> `Domain' ptrToDomain* #}++{# fun virConnectNumOfDefinedDomains as definedDomainsCount+    { connectionToPtr `Connection' } -> `Int' exceptionOnMinusOne* #}++getDomainInfo :: Domain -> IO DomainInfo+getDomainInfo dptr = do+  allocaBytes {# sizeof virDomainInfo #} $ \iptr -> do+         i <- {# call virDomainGetInfo #} (domainToPtr dptr) iptr+         state   <- {# get DomainInfo->state #}     iptr+         maxmem  <- {# get DomainInfo->maxMem #}    iptr+         memory  <- {# get DomainInfo->memory #}    iptr+         ncpus   <- {# get DomainInfo->nrVirtCpu #} iptr+         cputime <- {# get DomainInfo->cpuTime #}   iptr+         return $ DomainInfo {+                    diState     = cuchar2state state,+                    diMaxMem    = fromIntegral maxmem,+                    diMemory    = fromIntegral memory,+                    diNrVirtCPU = fromIntegral ncpus,+                    diCPUTime   = fromIntegral cputime }++{# fun virDomainDefineXML as defineDomainXML+    { connectionToPtr `Connection',+                      `String'      } -> `Domain' ptrToDomain* #}++{# fun virDomainUndefine as undefineDomain+    { domainToPtr `Domain' } -> `Int' exceptionOnMinusOne* #}++{# fun virDomainCreate as createDomain+    { domainToPtr `Domain' } -> `Int' exceptionOnMinusOne* #}++{# fun virDomainCreateXML as createDomainXML+    { connectionToPtr `Connection',+                      `String',+      flags2int       `[DomainCreateFlags]' } -> `Domain' ptrToDomain* #}++{# fun virDomainGetXMLDesc as getDomainXML+    { domainToPtr `Domain',+      flags2int   `[DomainXMLFlags]' } -> `String' #}++{# fun virDomainShutdown as shutdownDomain+    { domainToPtr `Domain' } -> `Int' exceptionOnMinusOne* #}++{# fun virDomainReboot as rebootDomain+    { domainToPtr `Domain',+      id          `CUInt'  } -> `Int' exceptionOnMinusOne* #}++{# fun virDomainDestroy as destroyDomain+    { domainToPtr `Domain' } -> `Int' exceptionOnMinusOne* #}++{# fun virDomainRef as refDomain+    { domainToPtr `Domain' } -> `Int' exceptionOnMinusOne* #}++{# fun virDomainFree as freeDomain+    { domainToPtr `Domain' } -> `Int' exceptionOnMinusOne* #}++{# fun virDomainSuspend as suspendDomain+    { domainToPtr `Domain' } -> `Int' exceptionOnMinusOne* #}++{# fun virDomainResume as resumeDomain+    { domainToPtr `Domain' } -> `Int' exceptionOnMinusOne* #}++{# fun virDomainSave as saveDomain+    { domainToPtr `Domain',+                  `String' } -> `Int' exceptionOnMinusOne* #}++{# fun virDomainRestore as restoreDomain+    { connectionToPtr `Connection',+                      `String'      } -> `Int' exceptionOnMinusOne* #}++{# fun virNetworkGetConnect as getNetworkConnection+    { networkToPtr `Network' } -> `Connection' ptrToConnection* #}++{# fun virConnectNumOfNetworks as runningNetworksCount+    { connectionToPtr `Connection' } -> `Int' exceptionOnMinusOne* #}++runningNetworksNames :: Connection -> IO [String]+runningNetworksNames conn = do+  cn <- {# call virConnectNumOfNetworks #} (connectionToPtr conn)+  let n = fromIntegral cn+  allocaArray n $ \nptr -> do+    {# call virConnectListNetworks #} (connectionToPtr conn) nptr cn+    mapM peekCString =<< peekArray n nptr++{# fun virConnectNumOfDefinedNetworks as definedNetworksCount+    { connectionToPtr `Connection' } -> `Int' exceptionOnMinusOne* #}++definedNetworksNames :: Connection -> IO [String]+definedNetworksNames conn = do+  cn <- {# call virConnectNumOfDefinedNetworks #} (connectionToPtr conn)+  let n = fromIntegral cn+  allocaArray n $ \nptr -> do+    {# call virConnectListDefinedNetworks #} (connectionToPtr conn) nptr cn+    mapM peekCString =<< peekArray n nptr++{# fun virNetworkLookupByName as lookupNetworkName+    { connectionToPtr `Connection', `String' } -> `Network' ptrToNetwork* #}++withCUString :: String -> (Ptr CUChar -> IO a) -> IO a+withCUString str fn = withCString str (fn . castPtr)++{# fun virNetworkLookupByUUID as lookupNetworkUUID+    { connectionToPtr `Connection', withCUString* `String' } -> `Network' ptrToNetwork* #}++{# fun virNetworkCreateXML as createNetworkXML+    { connectionToPtr `Connection', `String' } -> `Network' ptrToNetwork* #}++{# fun virNetworkDefineXML as defineNetworkXML+    { connectionToPtr `Connection', `String' } -> `Network' ptrToNetwork* #}++{# fun virNetworkUndefine as undefineNetwork+    { networkToPtr `Network' } -> `Int' exceptionOnMinusOne* #}++{# fun virNetworkCreate as createNetwork+    { networkToPtr `Network' } -> `Int' exceptionOnMinusOne* #}++{# fun virNetworkDestroy as destroyNetwork+    { networkToPtr `Network' } -> `Int' exceptionOnMinusOne* #}++{# fun virNetworkRef as refNetwork+    { networkToPtr `Network' } -> `Int' exceptionOnMinusOne* #}++{# fun virNetworkFree as freeNetwork+    { networkToPtr `Network' } -> `Int' exceptionOnMinusOne* #}++{# fun virNetworkGetName as getNetworkName+    { networkToPtr `Network' } -> `String' #}++{# fun virNetworkGetXMLDesc as getNetworkXML+    { networkToPtr `Network', +      flags2int    `[NetworkXMLFlags]' } -> `String' #}+
+ System/LibVirt/Internal.chs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ForeignFunctionInterface, StandaloneDeriving, DeriveDataTypeable #-}++{# context lib="virt" prefix="vir" #}++#include <libvirt/libvirt.h>++-- | Internal types definitions and low-level functions.+-- This module is not supposed to be imported by client code.+module System.LibVirt.Internal+  (Connection (..), Domain (..), Network (..)+  ) where++import Data.Generics+import Foreign+import Foreign.C.Types+import Foreign.C.String++{# pointer *virConnectPtr as Connection newtype #}++deriving instance Eq Connection+deriving instance Data Connection+deriving instance Typeable Connection++instance Show Connection where+  show (Connection ptr) = "<Connection: " ++ show ptr ++ ">"++{# pointer *virDomainPtr as Domain newtype #}++deriving instance Eq Domain+deriving instance Data Domain+deriving instance Typeable Domain++instance Show Domain where+  show (Domain ptr) = "<Domain: " ++ show ptr ++ ">"++{# pointer *virNetworkPtr as Network newtype #}++deriving instance Eq Network+deriving instance Data Network+deriving instance Typeable Network++instance Show Network where+  show (Network ptr) = "<Network: " ++ show ptr ++ ">"+
+ Test.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE ScopedTypeVariables #-}++import Control.Monad+import System.Environment++import System.LibVirt++uri = "qemu:///system"++main :: IO ()+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>"++start :: String -> Connection -> IO ()+start domain conn = do+  putStrLn $ "Running " ++ domain ++ "..."+  dom <- lookupDomainName conn domain+  createDomain dom `catchVirtError` (\e -> do+                                           putStrLn "Error:"+                                           print e)+  return ()++stop :: String -> Connection -> IO ()+stop domain conn = do+  putStrLn $ "Shutting down  " ++ domain ++ "..."+  dom <- lookupDomainName conn domain+  shutdownDomain dom `catchVirtError` (\e -> do+                                             putStrLn "Error:"+                                             print e)+  return ()++doTest :: Connection -> IO ()+doTest conn = do+  putStrLn $ "Defined domains:"+  names <- definedDomainsNames conn+  forM_ names $ \name -> do+    putStrLn $ "  Domain: " ++ name+    di <- getDomainInfo =<< lookupDomainName conn name+    putStrLn $ "  Info: " ++ show di++  nr <- runningDomainsCount conn+  putStrLn $ "Number of running domains: " ++ show nr++listNets :: Connection -> IO ()+listNets conn = do+  putStrLn $ "Defined networks:"+  names <- definedNetworksNames conn+  forM_ names putStrLn+  putStrLn ""+  nr <- runningNetworksCount conn+  putStrLn $ "Number of running networks: " ++ show nr+  putStrLn "Running networks:"+  names <- runningNetworksNames conn+  forM_ names putStrLn+
+ libvirt-hs.cabal view
@@ -0,0 +1,49 @@+Name:                libvirt-hs+Version:             0.1++Synopsis:            FFI bindings to libvirt virtualization API (http://libvirt.org)++Description:         This package provides low-level (at this moment, at least) FFI bindings to libvirt library.++Homepage:            http://redmine.iportnov.ru/projects/libvirt-hs++License:             BSD3++License-file:        LICENSE++Author:              IlyaPortnov++Maintainer:          portnov84@rambler.ru++-- A copyright notice.+-- Copyright:           ++Category:            System++Build-type:          Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+Extra-source-files:  Test.hs++-- Constraint on the version of Cabal needed to build this package.+Cabal-version:       >=1.6+++Library+  Exposed-modules:     System.LibVirt.Internal+                       System.LibVirt.Errors+                       System.LibVirt.Foreign+                       System.LibVirt+  +  -- Packages needed in order to build this package.+  Build-depends:       base >= 4 && < 5, syb >= 0.1.0.2+  +  Build-tools:         c2hs++  Extra-libraries:     "virt"++Source-repository head+  type: git+  location: git://home.iportnov.ru/libvirt-hs.git+