module System.Xen.Mid
(
interfaceOpen
, interfaceClose
, domainGetInfo
, domainPause
, domainUnpause
, domainShutdown
, domainDestroy
) where
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, 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.Types (XcHandle(..), DomId(..), DomainShutdownReason, DomainInfo)
import qualified System.Xen.Low as Low
interfaceOpen :: MonadIO m => m XcHandle
interfaceOpen = liftIO $ do
i@(XcHandle ptr) <- Low.xc_interface_open 0 0 0
when (ptr `elem` [1, 0]) $ getErrno >>= throwM . XcHandleOpenError
return i
interfaceClose :: (MonadIO m, Functor m) => XcHandle -> m ()
interfaceClose = void . liftIO . Low.xc_interface_close
domainGetInfo :: (MonadIO m, Alternative t, Traversable t) => XcHandle -> m (t DomainInfo)
domainGetInfo handle = liftIO $ allocaBytes size $ \ptr -> do
wrote <- fmap fromIntegral $ Low.xc_domain_getinfo handle (dom0) count ptr
when (wrote == 1) $ getErrno >>= throwM . DomainGetInfoError
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
domainPause :: MonadIO m => DomId -> XcHandle -> m Bool
domainPause domid handle = liftIO $ fmap (== 0) $ Low.xc_domain_pause handle domid
domainUnpause :: MonadIO m => DomId -> XcHandle -> m Bool
domainUnpause domid handle = liftIO $ fmap (== 0) $ Low.xc_domain_unpause handle domid
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)
domainDestroy :: MonadIO m => DomId -> XcHandle -> m Bool
domainDestroy domid handle = liftIO $ fmap (== 0) $ Low.xc_domain_destroy handle domid