module System.Xen
( Xen
, runXen
, runXen_
, execXen
, mkCallback
, xcInterfaceOpen
, xcInterfaceClose
, xcFindDeviceNumber
, xcDomainCreate
, xcDomainDumpcore
, xcDomainDumpcoreViaCallback
, xcDomainMaxVCPUs
, xcDomainPause
, xcDomainUnpause
, xcDomainResume
, xcDomainShutdown
, xcVCPUSetAffinity
, xcVCPUGetAffinity
, xcDomainGetInfo
, xcDomainGetInfoList
, xcDomainHVMGetContext
, xcDomainHVMSetContext
, xcVCPUGetInfo
, xcDomainSetCPUWeight
, xcDomainGetCPUUsage
, xcDomainSetHandle
, xcSedfDomainSet
, xcSedfDomainGet
, xcDomainSendTrigger
, xcEvtChanAllocUnbound
, xcEvtChanReset
, xcEvtChanOpen
, xcEvtChanClose
, xcEvtChanNotify
, xcEvtChanBindUnboundPort
, xcEvtChanBindInterdomain
, xcEvtChanBindVIRQ
, xcEvtChanUnbind
, xcEvtChanPending
, xcEvtChanUnmask
, System.Xen.CBindings.DomId(..)
, DumpcoreCallback
, XCEHandle
, EventChannelPort
) where
import System.Xen.CBindings
import Control.Monad (liftM, ap)
import Control.Monad.Writer
import Control.Monad.Error
import Control.Monad.Trans (lift)
import Data.DList hiding (unfoldr)
import Data.List (foldl', unfoldr)
import Data.Bits ((.|.), testBit, shiftR)
import Data.Word
import Foreign.C (Errno(..), getErrno, CInt)
import Foreign.Ptr
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.C.String (withCString, CString)
import Foreign.C.Types (CChar)
import Foreign.C (CInt, CUInt)
import Foreign.Storable (peek, sizeOf)
import qualified Data.ByteString as B
instance Ord Errno where
(Errno a) `compare` (Errno b) = a `compare` b
data XenMessage = XmFunctionCall String | XmError String | XmWarn String | XmInfo String
deriving (Eq, Ord, Show)
type XenMessages = DList XenMessage
instance Show Errno where
showsPrec _ (Errno e) = \s -> ("Errno " ++ (show e)) ++ s
data XenError = XeErrno Errno | XeUnspec | XeString String | XeHandleTNot16Bytes
deriving (Eq, Ord, Show)
instance Error XenError where
noMsg = XeUnspec
strMsg = XeString
newtype Xen a = X { unXen :: ErrorT XenError (WriterT XenMessages IO) a }
deriving (Monad, MonadIO, MonadWriter XenMessages, MonadError XenError)
runXen :: Xen a -> a -> IO a
runXen act def = do
res <- execXen act
case res of
(Left _, _) -> return def
(Right x, _) -> return x
runXen_ :: Xen a -> IO ()
runXen_ act = execXen act >> return ()
execXen :: Xen a -> IO (Either XenError a, XenMessages)
execXen act = do
err <- runWriterT (runErrorT $ unXen act)
case err of
(Right a,w) -> return (Right a,w)
(Left e,w) -> return (Left e,w)
errnoOnNegOne :: CInt -> a -> Xen a
errnoOnNegOne (1) _ = liftIO getErrno >>= throwError . XeErrno
errnoOnNegOne e a = return a
lxf = tell . singleton . XmFunctionCall
xcInterfaceOpen :: Xen XCHandle
xcInterfaceOpen = do
lxf "xcInterfaceOpen"
h <- liftIO xc_interface_open
errnoOnNegOne h (XCHdl h)
xcInterfaceClose :: XCHandle -> Xen ()
xcInterfaceClose hdl = do
lxf "xcInterfaceClose"
r <- liftIO $ xc_interface_close hdl
errnoOnNegOne r ()
xcFindDeviceNumber :: String -> Xen ()
xcFindDeviceNumber str = do
lxf "xcFindDeviceNumber"
r <- liftIO (withCString str xc_find_device_number)
errnoOnNegOne r ()
xcDomainCreate :: XCHandle -> Word32 -> XenDomainHandleT -> Word32 -> Ptr Word32 -> Xen ()
xcDomainCreate xh ssid domHdl flags ptr = do
lxf "xcDomainCreate"
r <- liftIO $ xc_domain_create xh ssid domHdl flags ptr
errnoOnNegOne r ()
xcDomainDumpcore :: XCHandle -> DomId -> String -> Xen ()
xcDomainDumpcore hdl dom str = do
lxf "xcDomainDumpcore"
r <- liftIO (withCString str (xc_domain_dumpcore hdl dom))
errnoOnNegOne r ()
type DumpcoreCallback = B.ByteString -> IO Int
xcDomainDumpcoreViaCallback :: XCHandle -> DomId -> DumpcoreCallback -> Xen ()
xcDomainDumpcoreViaCallback hdl dom cb = do
lxf "xcDomainDumpCoreviaCallback"
r <- liftIO doDump
errnoOnNegOne r ()
where
cbWrapper :: Ptr Word8 -> CString -> CUInt -> IO CInt
cbWrapper _ buf len = do
bs <- B.packCStringLen (buf, fromIntegral len)
r <- cb bs
return $ fromIntegral r
doDump = do
c <- mkCallback cbWrapper
r <- xc_domain_dumpcore_via_callback hdl dom nullPtr c
return $ fromIntegral r
foreign import ccall "wrapper"
mkCallback :: Dumpcore_rtn_t -> IO (FunPtr Dumpcore_rtn_t)
xcDomainMaxVCPUs :: XCHandle -> DomId -> Int -> Xen ()
xcDomainMaxVCPUs hdl dom nr = do
lxf "xcDomainMaxVCPUs"
r <- liftIO $ xc_domain_max_vcpus hdl dom (fromIntegral nr)
errnoOnNegOne r ()
xcDomainPause :: XCHandle -> DomId -> Xen ()
xcDomainPause hdl dom = do
lxf "xcDomainPause"
r <- liftIO $ xc_domain_pause hdl dom
errnoOnNegOne r ()
xcDomainUnpause :: XCHandle -> DomId -> Xen ()
xcDomainUnpause hdl dom = do
lxf "xcDomainUnpause"
r <- liftIO $ xc_domain_unpause hdl dom
errnoOnNegOne r ()
xcDomainDestroy :: XCHandle -> DomId -> Xen ()
xcDomainDestroy hdl dom = do
lxf "xcDomainDestroy"
r <- liftIO $ xc_domain_destroy hdl dom
errnoOnNegOne r ()
xcDomainResume :: XCHandle -> DomId -> Bool -> Xen ()
xcDomainResume hdl dom fast = do
lxf "xcDomainResume"
r <- liftIO $ xc_domain_resume hdl dom (fromIntegral $ fromEnum fast)
errnoOnNegOne r ()
xcDomainShutdown :: XCHandle -> DomId -> XCShutdown -> Xen ()
xcDomainShutdown hdl dom s = do
lxf "xcDomainShutdown"
r <- liftIO $ xc_domain_shutdown hdl dom (fromIntegral $ fromEnum s)
errnoOnNegOne r ()
xcVCPUSetAffinity :: XCHandle -> DomId -> Int -> [Int] -> Xen ()
xcVCPUSetAffinity hdl dom cpu mapping = do
lxf "xcVCPUSetAffinity"
let w = foldl' (\a b -> a .|. fromIntegral b) 0 mapping
r <- liftIO $ xc_vcpu_setaffinity hdl dom (fromIntegral cpu) w
errnoOnNegOne r ()
xcVCPUGetAffinity :: XCHandle -> DomId -> Int -> Xen [Int]
xcVCPUGetAffinity hdl dom cpu = do
lxf "xcVCPUGetAffinity"
(r,m) <- liftIO $ allocaBytes 8 $ \ptr -> do
r <- xc_vcpu_getaffinity hdl dom (fromIntegral cpu) ptr
w <- peek ptr
let mapping = unfoldr bitDecomp (w,0)
return (r,mapping)
errnoOnNegOne r m
where
bitDecomp :: (Word64, Int) -> Maybe (Int, (Word64, Int))
bitDecomp (0,_) = Nothing
bitDecomp (w,c) = if (testBit w 0) then Just (c, (w `shiftR` 1, c + 1)) else bitDecomp (w `shiftR` 1, c + 1)
xcDomainGetInfo :: XCHandle -> DomId -> Int -> Xen XCDomInfo
xcDomainGetInfo hdl dom s = do
lxf "xcDomainGetInfo"
(r,i) <- liftIO $ allocaBytes (s * sizeOf (undefined :: XCDomInfo)) $ \ptr -> do
r <- xc_domain_getinfo hdl dom (fromIntegral s) ptr
i <- peek ptr
return (r,i)
errnoOnNegOne r i
xcDomainGetInfoList :: XCHandle -> DomId -> Int -> Xen XCDomInfo
xcDomainGetInfoList hdl dom s = do
lxf "xcDomainGetInfoList"
(r,i) <- liftIO $ allocaBytes (s * sizeOf (undefined :: XCDomInfo)) $ \ptr -> do
r <- xc_domain_getinfo hdl dom (fromIntegral s) ptr
i <- peek ptr
return (r,i)
errnoOnNegOne r i
xcDomainHVMGetContext :: XCHandle -> DomId -> Xen B.ByteString
xcDomainHVMGetContext hdl dom = do
lxf "xcDomainHVMGetContext"
r <- liftIO $ xc_domain_hvm_getcontext hdl dom nullPtr 0
errnoOnNegOne r ()
(r',bs) <- liftIO $ allocaBytes (fromIntegral r) $ \ptr -> do
res <- xc_domain_hvm_getcontext hdl dom ptr (fromIntegral r)
bs <- B.packCStringLen (castPtr ptr, fromIntegral r)
return (res, bs)
errnoOnNegOne r' bs
xcDomainHVMSetContext :: XCHandle -> DomId -> B.ByteString -> Xen ()
xcDomainHVMSetContext hdl dom ctx = do
lxf "xcDomainHVMSetContext"
r <- liftIO $ B.useAsCStringLen ctx $ \(ptr,len) ->
xc_domain_hvm_setcontext hdl dom (castPtr ptr) (fromIntegral len)
errnoOnNegOne r ()
xcVCPUGetInfo :: XCHandle -> DomId -> Int -> Xen VCPUInfo
xcVCPUGetInfo hdl dom cpu = do
lxf "xcVCPUGetInfo"
(r,i) <- liftIO $ allocaBytes (sizeOf (undefined :: VCPUInfo)) $ \ptr -> do
r <- xc_vcpu_getinfo hdl dom (fromIntegral cpu) ptr
i <- peek ptr
return (r,i)
errnoOnNegOne r i
xcDomainSetCPUWeight :: XCHandle -> DomId -> Float -> Xen ()
xcDomainSetCPUWeight hdl dom w = do
lxf "xcDomainSetCPUWeight"
r <- liftIO $ xc_domain_setcpuweight hdl dom (realToFrac w)
errnoOnNegOne r ()
xcDomainGetCPUUsage :: XCHandle -> DomId -> Int -> Xen Integer
xcDomainGetCPUUsage hdl dom cpu = do
lxf "xcDomainGetCPUUsage"
r <- liftIO $ xc_domain_get_cpu_usage hdl dom (fromIntegral cpu)
errnoOnNegOne (fromIntegral r) (fromIntegral r)
xcDomainSetHandle :: XCHandle -> DomId -> B.ByteString -> Xen ()
xcDomainSetHandle hdl dom h = do
lxf "xcDomainSetHandle"
if B.length h /= 16
then throwError XeHandleTNot16Bytes
else do r <- liftIO $ B.useAsCString h $ \ptr -> xc_domain_sethandle hdl dom (castPtr ptr)
errnoOnNegOne r ()
xcSedfDomainSet :: XCHandle -> DomId ->
Word64 ->
Word64 ->
Word64 ->
Word16 ->
Word16 ->
Xen ()
xcSedfDomainSet hdl dom per slice latency et weight = do
lxf "xcSedfDomainSet"
r <- liftIO $ xc_sedf_domain_set hdl dom per slice latency et weight
errnoOnNegOne r ()
xcSedfDomainGet :: XCHandle -> DomId -> Xen (Word64,Word64,Word64,Word16,Word16)
xcSedfDomainGet hdl dom = do
lxf "xcSedfDomainGet"
(r,p,s,l,e,w) <- liftIO $ do
let w64 = sizeOf (undefined :: Word64)
w16 = sizeOf (undefined :: Word16)
allocaBytes w64 $ \period -> allocaBytes w64 $ \slice -> allocaBytes w64 $ \latency -> do
allocaBytes w16 $ \extraTime -> allocaBytes w16 $ \weight -> do
r <- xc_sedf_domain_get hdl dom period slice latency extraTime weight
p <- peek period
s <- peek slice
l <- peek latency
e <- peek extraTime
w <- peek weight
return (r,p,s,l,e,w)
errnoOnNegOne r (p,s,l,e,w)
xcDomainSendTrigger :: XCHandle -> DomId -> Int -> Int -> Xen ()
xcDomainSendTrigger hdl dom triggerType vcpu = do
lxf "xcDomainSendTrigger"
r <- liftIO $ xc_domain_send_trigger hdl dom (fromIntegral triggerType) (fromIntegral vcpu)
errnoOnNegOne r ()
xcEvtChanAllocUnbound :: XCHandle -> DomId -> DomId -> Xen XCEHandle
xcEvtChanAllocUnbound hdl domA domB = do
lxf "xcEvtChanAllocUnbound"
r <- liftIO $ xc_evtchn_alloc_unbound hdl domA domB
errnoOnNegOne r (XCEHandle r)
xcEvtChanReset :: XCHandle -> DomId -> Xen ()
xcEvtChanReset hdl dom = do
lxf "xcEvtChanReset"
r <- liftIO $ xc_evtchn_reset hdl dom
errnoOnNegOne r ()
xcEvtChanOpen :: Xen XCEHandle
xcEvtChanOpen = do
lxf "xcEvtChanOpen"
r <- liftIO xc_evtchn_open
errnoOnNegOne r (XCEHandle r)
xcEvtChanClose :: XCEHandle -> Xen ()
xcEvtChanClose hdl = do
lxf "xcEvtChanClose"
r <- liftIO $ xc_evtchn_close hdl
errnoOnNegOne r ()
xcEvtChanNotify :: XCEHandle -> EventChannelPort -> Xen ()
xcEvtChanNotify hdl port = do
lxf "xcEvChanNotify"
r <- liftIO $ xc_evtchn_notify hdl port
errnoOnNegOne r ()
xcEvtChanBindUnboundPort :: XCEHandle -> DomId -> Xen EventChannelPort
xcEvtChanBindUnboundPort hdl dom = do
lxf "xcEvtChanBindUnboundPort"
r <- liftIO $ xc_evtchn_bind_unbound_port hdl dom
errnoOnNegOne r (ECPort $ fromIntegral r)
xcEvtChanBindInterdomain :: XCEHandle -> DomId -> EventChannelPort -> Xen EventChannelPort
xcEvtChanBindInterdomain hdl dom port = do
lxf "xcEvtChanBindInterdomain"
r <- liftIO $ xc_evtchn_bind_interdomain hdl dom port
errnoOnNegOne r (ECPort $ fromIntegral r)
xcEvtChanBindVIRQ :: XCEHandle -> Int -> Xen EventChannelPort
xcEvtChanBindVIRQ hdl virq = do
lxf "xcEvtChanBindVIRQ"
r <- liftIO $ xc_evtchn_bind_virq hdl (fromIntegral virq)
errnoOnNegOne r (ECPort $ fromIntegral r)
xcEvtChanUnbind :: XCEHandle -> EventChannelPort -> Xen ()
xcEvtChanUnbind hdl port = do
lxf "xcEvtChanUnbind"
r <- liftIO $ xc_evtchn_unbind hdl port
errnoOnNegOne r ()
xcEvtChanPending :: XCEHandle -> Xen EventChannelPort
xcEvtChanPending hdl = do
lxf "xcEvtChanPending"
r <- liftIO $ xc_evtchn_pending hdl
errnoOnNegOne r (ECPort $ fromIntegral r)
xcEvtChanUnmask :: XCEHandle -> EventChannelPort -> Xen ()
xcEvtChanUnmask hdl port = do
lxf "xcEvtChanUnmask"
r <- liftIO $ xc_evtchn_unmask hdl port
errnoOnNegOne r ()