diff --git a/hen.cabal b/hen.cabal --- a/hen.cabal +++ b/hen.cabal @@ -1,5 +1,5 @@ Name: hen -Version: 0.1.0.1 +Version: 0.1.1 Synopsis: Haskell bindings to Xen hypervisor interface Description: Haskell bindings to Xen hypervisor interface License: MIT @@ -24,7 +24,7 @@ Build-depends: base == 4.6.* || == 4.5.* , transformers == 0.3.* , mtl == 2.1.* || == 2.0.* - , exceptions == 0.1.* + , exceptions == 0.3.* , uuid == 1.2.* , bitset == 1.4.* @@ -35,7 +35,7 @@ System.Xen.Errors System.Xen.Mid System.Xen.Low - Extra-libraries: xenctrl +-- Extra-libraries: xenctrl Test-suite hen-tests Main-is: Tests.hs @@ -46,14 +46,14 @@ Build-depends: base == 4.6.* || == 4.5.* , transformers == 0.3.* , mtl == 2.1.* || == 2.0.* - , exceptions == 0.1.* + , exceptions == 0.3.* , uuid == 1.2.* , bitset == 1.4.* , hen - , test-framework == 0.8.* - , test-framework-quickcheck2 == 0.3.* - , QuickCheck == 2.5.* + , tasty == 0.3.* + , tasty-quickcheck == 0.3.* + , QuickCheck == 2.6.* Source-repository head Type: git diff --git a/src/System/Xen.hs b/src/System/Xen.hs --- a/src/System/Xen.hs +++ b/src/System/Xen.hs @@ -31,14 +31,23 @@ , DomainShutdownReason(..) , DomainInfo(..) -- * High-level API + -- ** Monad stuff , XenT , Xen - , domainGetInfo , runXenT + -- ** Domain + , domainGetInfo + -- *** Domain pause + , domainPause + , domainUnpause + -- *** Domain powerstate + , domainShutdown + , domainDestroy ) where import System.Xen.Errors (XcHandleOpenError(..), InvalidDomainShutdownReason(..), DomainGetInfoError(..)) -import System.Xen.High (XenT, Xen, domainGetInfo, runXenT) +import System.Xen.High (XenT, Xen, domainGetInfo, domainPause, domainUnpause, domainShutdown, + domainDestroy, runXenT) import System.Xen.Types (DomId(..), DomainFlag(..), DomainShutdownReason(..), DomainInfo(..)) diff --git a/src/System/Xen/High.hs b/src/System/Xen/High.hs --- a/src/System/Xen/High.hs +++ b/src/System/Xen/High.hs @@ -1,14 +1,23 @@ -- | High-level interface to @XenCtrl@. Contains `Xen` monad and provides a safe way -- to run any `Xen` computation. module System.Xen.High - ( XenT + ( + -- * Monad stuff + XenT , Xen - , domainGetInfo , runXenT + -- * Domain + , domainGetInfo + -- ** Domain pause + , domainPause + , domainUnpause + -- ** Domain powerstate + , domainShutdown + , domainDestroy ) where import System.Xen.High.Internal (XenT, Xen, MonadXen(withXenHandle), runXenT) -import System.Xen.Types (DomainInfo) +import System.Xen.Types (DomainInfo, DomId, DomainShutdownReason) import qualified System.Xen.Mid as Mid -- | Returns a lift of domains, this function can fail with @@ -16,3 +25,22 @@ -- 'System.Xen.Errors.DomainGetInfoError'. domainGetInfo :: MonadXen m => m [DomainInfo] domainGetInfo = withXenHandle Mid.domainGetInfo + +-- | Pause domain. A paused domain still exists in memory +-- however it does not receive any timeslices from the hypervisor. +domainPause :: MonadXen m => DomId -> m Bool +domainPause = withXenHandle . Mid.domainPause + +-- | Unpause a domain. The domain should have been previously paused. +domainUnpause :: MonadXen m => DomId -> m Bool +domainUnpause = withXenHandle . Mid.domainUnpause + +-- | Shutdown domain. This is intended for use in fully-virtualized domains where +-- this operation is analogous to the sched_op operations in a paravirtualized domain. +domainShutdown :: MonadXen m => DomId -> DomainShutdownReason -> m Bool +domainShutdown domid reason = withXenHandle $ Mid.domainShutdown domid reason + +-- | Destroy a domain. Destroying a domain removes the domain completely from memory. +-- This function should be called after 'domainShutdown' to free up the domain resources. +domainDestroy :: MonadXen m => DomId -> m Bool +domainDestroy = withXenHandle . Mid.domainDestroy diff --git a/src/System/Xen/High/Internal.hs b/src/System/Xen/High/Internal.hs --- a/src/System/Xen/High/Internal.hs +++ b/src/System/Xen/High/Internal.hs @@ -22,16 +22,16 @@ import Control.Monad.State (MonadState(..)) import Control.Monad.Writer (MonadWriter(..)) -import Control.Monad.Trans.Identity (IdentityT(..)) import Control.Monad.Trans (MonadIO, MonadTrans(lift)) -import qualified Control.Monad.Trans.Cont as Cont -import qualified Control.Monad.Trans.Error as Error -import qualified Control.Monad.Trans.State.Lazy as LazyState -import qualified Control.Monad.Trans.State.Strict as StrictState -import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter -import qualified Control.Monad.Trans.Writer.Strict as StrictWriter -import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS -import qualified Control.Monad.Trans.RWS.Strict as StrictRWS +import Control.Monad.Trans.Identity (IdentityT(..)) +import qualified Control.Monad.Cont as Cont +import qualified Control.Monad.Error as Error +import qualified Control.Monad.State.Lazy as LazyState +import qualified Control.Monad.State.Strict as StrictState +import qualified Control.Monad.Writer.Lazy as LazyWriter +import qualified Control.Monad.Writer.Strict as StrictWriter +import qualified Control.Monad.RWS.Lazy as LazyRWS +import qualified Control.Monad.RWS.Strict as StrictRWS import System.Xen.Types (XcHandle) import qualified System.Xen.Mid as Mid @@ -76,9 +76,12 @@ -- * The @transformers@-style monad transfomer ------------------------------------------------------------------------------ +-- | A Xen transformer. This transformers keeps connection to the Xen +-- hypervisor interface. newtype XenT m a = XenT { unXenT :: ReaderT XcHandle m a } deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadCatch) +-- | Most simple 'XenT' implementation. type Xen = XenT IO instance (Functor m, MonadIO m, MonadCatch m) => MonadXen (XenT m) where diff --git a/src/System/Xen/Low.hsc b/src/System/Xen/Low.hsc --- a/src/System/Xen/Low.hsc +++ b/src/System/Xen/Low.hsc @@ -4,9 +4,18 @@ -- a ffi call to corresponding c function. module System.Xen.Low - ( xc_interface_open + ( + -- * Interface + xc_interface_open , xc_interface_close + -- * Domain , xc_domain_getinfo + -- ** Domain pause + , xc_domain_pause + , xc_domain_unpause + -- ** Domain powerstate + , xc_domain_shutdown + , xc_domain_destroy ) where #include @@ -45,10 +54,40 @@ -- one exists. It is, therefore, important in this case to make sure the -- domain requested was the one returned. foreign import ccall unsafe "xenctrl.h xc_domain_getinfo" - xc_domain_getinfo :: XcHandle -- ^ Handle to the open hypervisor interface - -> DomId -- ^ First domain to enumerate from. - -> CUInt -- ^ The number of requested domains + xc_domain_getinfo :: XcHandle -- ^ Handle to the open hypervisor interface + -> DomId -- ^ First domain to enumerate from. + -> CUInt -- ^ The number of requested domains -> Ptr DomainInfo -- ^ Pointer to the structure that will -- contain the information for -- enumerated domains - -> IO CInt -- ^ Number of domains enumerated, -1 on error + -> IO CInt -- ^ Number of domains enumerated, -1 on error + +-- | This function pauses a domain. A paused domain still exists in memory +-- however it does not receive any timeslices from the hypervisor. +foreign import ccall unsafe "xenctrl.h xc_domain_pause" + xc_domain_pause :: XcHandle -- ^ Handle to the open hypervisor interface + -> DomId -- ^ Domain to pause + -> IO CInt -- ^ 0 if success, -1 if error + +-- | This function unpauses a domain. The domain should have been previously paused. +foreign import ccall unsafe "xenctrl.h xc_domain_unpause" + xc_domain_unpause :: XcHandle -- ^ Handle to the open hypervisor interface + -> DomId -- ^ Domain to unpause + -> IO CInt -- ^ 0 if success, -1 if error + +-- | This function will shutdown a domain. This is intended for use in +-- fully-virtualized domains where this operation is analogous to the +-- sched_op operations in a paravirtualized domain. +foreign import ccall unsafe "xenctrl.h xc_domain_shutdown" + xc_domain_shutdown :: XcHandle -- ^ Handle to the open hypervisor interface + -> DomId -- ^ Domain to shutdown + -> CInt -- ^ Shutdown reason + -> IO CInt -- ^ 0 if success, -1 if error + +-- | This function will destroy a domain. Destroying a domain removes the domain +-- completely from memory. This function should be called after sending the +-- domain a SHUTDOWN control message to free up the domain resources. +foreign import ccall unsafe "xenctrl.h xc_domain_destroy" + xc_domain_destroy :: XcHandle -- ^ Handle to the open hypervisor interface + -> DomId -- ^ Domain to destroy + -> IO CInt -- ^ 0 if success, -1 if error diff --git a/src/System/Xen/Mid.hsc b/src/System/Xen/Mid.hsc --- a/src/System/Xen/Mid.hsc +++ b/src/System/Xen/Mid.hsc @@ -5,33 +5,47 @@ -- error codes and @errno@. module System.Xen.Mid - ( interfaceOpen + ( + -- * Interface + interfaceOpen , interfaceClose + -- * Domain , domainGetInfo + -- ** Domain pause + , domainPause + , domainUnpause + -- ** Domain powerstate + , domainShutdown + , domainDestroy ) where #include -import Control.Monad (void, when, forM) +import Prelude hiding (sequence) + +import Control.Applicative (Alternative(..), pure) +import Control.Monad (void, when) +import Data.Traversable (Traversable(sequenceA)) import Foreign.Marshal.Alloc (allocaBytes) -import Foreign.Storable (peekElemOff, sizeOf) +import Foreign.Storable (peekElemOff, peek, poke, sizeOf) +import Foreign.Ptr (castPtr) import Control.Monad.Catch (throwM) import Control.Monad.Trans (MonadIO(liftIO)) import System.Xen.Errors (DomainGetInfoError(..), XcHandleOpenError(..), getErrno) -import System.Xen.Low (xc_interface_open, xc_interface_close, xc_domain_getinfo) -import System.Xen.Types (XcHandle(..), DomId(..), DomainInfo) +import System.Xen.Types (XcHandle(..), DomId(..), DomainShutdownReason, DomainInfo) +import qualified System.Xen.Low as Low -- | Open the connection to the hypervisor interface, can fail with -- 'System.Xen.Errors.XcHandleOpenError'. interfaceOpen :: MonadIO m => m XcHandle interfaceOpen = liftIO $ do #if XEN_SYSCTL_INTERFACE_VERSION == 8 - i@(XcHandle ptr) <- xc_interface_open 0 0 0 + i@(XcHandle ptr) <- Low.xc_interface_open 0 0 0 when (ptr `elem` [-1, 0]) $ getErrno >>= throwM . XcHandleOpenError #elif XEN_SYSCTL_INTERFACE_VERSION == 6 - i@(XcHandle h) <- xc_interface_open + i@(XcHandle h) <- Low.xc_interface_open when (h == -1) $ getErrno >>= throwM . XcHandleOpenError #endif return i @@ -39,18 +53,46 @@ -- | Close an open hypervisor interface, ignores all possible errors but all the -- same can fail with segfault or sutin. interfaceClose :: (MonadIO m, Functor m) => XcHandle -> m () -interfaceClose = void . liftIO . xc_interface_close +interfaceClose = void . liftIO . Low.xc_interface_close -- | Returns a list of currently runing domains, 1024 maximum, can fail with -- 'System.Xen.Errors.InvalidDomainShutdownReason' and -- 'System.Xen.Errors.DomainGetInfoError'. -domainGetInfo :: MonadIO m => XcHandle -> m [DomainInfo] +domainGetInfo :: (MonadIO m, Alternative t, Traversable t) => XcHandle -> m (t DomainInfo) domainGetInfo handle = liftIO $ allocaBytes size $ \ptr -> do - wrote <- fmap fromIntegral $ xc_domain_getinfo handle (dom0) count ptr + wrote <- fmap fromIntegral $ Low.xc_domain_getinfo handle (dom0) count ptr when (wrote == -1) $ getErrno >>= throwM . DomainGetInfoError - forM [0 .. wrote - 1] $ peekElemOff ptr + sequenceA $ generateA wrote $ peekElemOff ptr where dom0 = DomId 0 count :: Num a => a count = 1024 size = count * sizeOf (undefined :: DomainInfo) + generateA c = go empty c c + where + go t 0 _ _ = t + go t n l a = n `seq` go (pure (a (l - n)) <|> t) l (n - 1) a + +-- | Pause domain. A paused domain still exists in memory +-- however it does not receive any timeslices from the hypervisor. +domainPause :: MonadIO m => DomId -> XcHandle -> m Bool +domainPause domid handle = liftIO $ fmap (== 0) $ Low.xc_domain_pause handle domid + +-- | Unpause a domain. The domain should have been previously paused. +domainUnpause :: MonadIO m => DomId -> XcHandle -> m Bool +domainUnpause domid handle = liftIO $ fmap (== 0) $ Low.xc_domain_unpause handle domid + +-- | Shutdown domain. This is intended for use in fully-virtualized domains where +-- this operation is analogous to the sched_op operations in a paravirtualized domain. +domainShutdown :: MonadIO m => DomId -> DomainShutdownReason -> XcHandle -> m Bool +domainShutdown domid reason handle = liftIO $ fmap (== 0) $ allocaBytes size $ \ptr -> do + poke ptr reason + intReason <- peek $ castPtr ptr + Low.xc_domain_shutdown handle domid intReason + where + size = sizeOf (undefined :: DomainShutdownReason) + +-- | Destroy a domain. Destroying a domain removes the domain completely from memory. +-- This function should be called after 'domainShutdown' to free up the domain resources. +domainDestroy :: MonadIO m => DomId -> XcHandle -> m Bool +domainDestroy domid handle = liftIO $ fmap (== 0) $ Low.xc_domain_destroy handle domid diff --git a/src/System/Xen/Types.hsc b/src/System/Xen/Types.hsc --- a/src/System/Xen/Types.hsc +++ b/src/System/Xen/Types.hsc @@ -22,7 +22,6 @@ import Control.Applicative ((<$>)) import Data.Bits (testBit, bit, (.|.)) import Data.Maybe (catMaybes) -import Data.Foldable (foldl) import Data.Word (Word32, Word64) import Foreign.C (CInt(..), CUInt(..)) #if XEN_SYSCTL_INTERFACE_VERSION == 8 @@ -77,8 +76,8 @@ data DomainInfo = DomainInfo { domainInfoId :: {-# UNPACK #-} !DomId , domainInfoSsidRef :: {-# UNPACK #-} !Word32 - , domainInfoFlags :: BitSet DomainFlag - , domainInfoShutdownReason :: Maybe DomainShutdownReason + , domainInfoFlags :: !(BitSet DomainFlag) + , domainInfoShutdownReason :: !(Maybe DomainShutdownReason) , domainInfoNumberOfPages :: {-# UNPACK #-} !Word32 #if XEN_SYSCTL_INTERFACE_VERSION == 8 , domainInfoNumberOfSharedPages :: {-# UNPACK #-} !Word32 @@ -154,7 +153,7 @@ #{poke xc_dominfo_t, domid} ptr domainInfoId #{poke xc_dominfo_t, ssidref} ptr domainInfoSsidRef let off = sizeOf domainInfoId + sizeOf domainInfoSsidRef - let flags :: CUInt = foldl (\a b -> a .|. bit (fromEnum b)) 0 domainInfoFlags + let flags :: CUInt = BitSet.foldl' (\a b -> a .|. bit (fromEnum b)) 0 domainInfoFlags pokeByteOff ptr off flags case domainInfoShutdownReason of Nothing -> return () diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,10 +1,10 @@ module Main where -import Test.Framework (defaultMain) +import Test.Tasty (defaultMain, testGroup) import qualified System.Xen.Types.Tests main :: IO () -main = defaultMain +main = defaultMain $ testGroup "Tests" [ System.Xen.Types.Tests.tests ]