module System.Xen.CBindings ( xc_interface_open , xc_interface_close , xc_find_device_number , xc_domain_create , xc_domain_dumpcore , xc_domain_dumpcore_via_callback , xc_domain_max_vcpus , xc_domain_pause , xc_domain_unpause , xc_domain_destroy , xc_domain_resume , xc_domain_shutdown , xc_vcpu_setaffinity , xc_vcpu_getaffinity , xc_domain_getinfo , xc_domain_getinfolist , xc_CORE_MAGIC , xc_CORE_MAGIC_HVM , DomId(..) , XCHandle(..) ) where import Data.Bits import Data.List (foldl1') import Data.Word import Data.Array.IArray import Foreign.C import Foreign.Ptr import Foreign.Storable import Foreign.Marshal.Array #include xc_CORE_MAGIC :: CInt xc_CORE_MAGIC = 0xF00FEBED xc_CORE_MAGIC_HVM :: CInt xc_CORE_MAGIC_HVM = 0xF00FEBEE data DomainFlag = Dying | Crashed | Shutdown | Paused | Blocked | Running | HVM | Debugged deriving (Eq, Ord, Show, Enum) instance Storable [DomainFlag] where sizeOf _ = sizeOf (undefined :: CUInt) alignment _ = alignment (undefined :: CUInt) peek ptr = do v <- peek (castPtr ptr) return $ fromBits v poke ptr a = poke (castPtr ptr) (toBits a) toBits :: [DomainFlag] -> CUInt toBits flgs = foldl1' (.|.) (map (bit . fromEnum) flgs) fromBits :: CUInt -> [DomainFlag] fromBits v = map (toEnum . fst) flagsSet where flagsSet :: [(Int,Bool)] flagsSet = filter ((==True) . snd) (zip [0..] flgVals) flgVals :: [Bool] flgVals = map (uncurry testBit) (zip (repeat v) [0..31]) data XC_DomInfo = XC_DomInfo { diDomId :: Word32, diSSIDRef :: Word32, diFlags :: [DomainFlag], diShutdownReason :: XCShutdown, diNrPages :: CUInt, diSharedInfoFrame :: CUInt, diCpuTime :: Word64, diMaxMemKB :: CULong, diNrOnlineVCPUs :: CUInt, diMaxVCPUId :: CUInt, diDomHandle :: [XenDomainHandle] } deriving (Eq, Ord, Show) type XenDomainHandle = Word8 type XenDomainHandleT = Ptr Word8 instance Storable XC_DomInfo where sizeOf _= (#size xc_dominfo_t) alignment _ = alignment (undefined :: Word64) peek ptr = do domId <- (#peek xc_dominfo_t, domid) ptr ssidRef <- (#peek xc_dominfo_t, ssidref) ptr flags <- peekByteOff ptr (sizeOf domId + sizeOf ssidRef) sr <- (#peek xc_dominfo_t, shutdown_reason) ptr nrPgs <- (#peek xc_dominfo_t, nr_pages) ptr infoF <- (#peek xc_dominfo_t, shared_info_frame) ptr cpuT <- (#peek xc_dominfo_t, cpu_time) ptr maxM <- (#peek xc_dominfo_t, max_memkb) ptr nrOC <- (#peek xc_dominfo_t, nr_online_vcpus) ptr maxCI <- (#peek xc_dominfo_t, max_vcpu_id) ptr dh <- peekArray 16 (plusPtr ptr (#offset xc_dominfo_t, handle)) return $ XC_DomInfo domId ssidRef flags sr nrPgs infoF cpuT maxM nrOC maxCI dh poke ptr a = do (#poke xc_dominfo_t, domid) ptr (diDomId a) (#poke xc_dominfo_t, ssidref) ptr (diSSIDRef a) pokeByteOff ptr (sizeOf (diDomId a) + sizeOf (diSSIDRef a)) (diFlags a) (#poke xc_dominfo_t, shutdown_reason) ptr (diShutdownReason a) (#poke xc_dominfo_t, nr_pages) ptr (diNrPages a) (#poke xc_dominfo_t, shared_info_frame) ptr (diSharedInfoFrame a) (#poke xc_dominfo_t, cpu_time) ptr (diCpuTime a) (#poke xc_dominfo_t, max_memkb) ptr (diMaxMemKB a) (#poke xc_dominfo_t, nr_online_vcpus) ptr (diNrOnlineVCPUs a) (#poke xc_dominfo_t, max_vcpu_id) ptr (diMaxVCPUId a) let p = plusPtr ptr 76 domHandles = take 16 $ diDomHandle a ++ repeat 0 pokeArray p domHandles -- FIXME VCPU Guest Context Type -- SHUTDOWN constants can be found in data XCShutdown = SHUTDOWN_poweroff | SHUTDOWN_reboot | SHUTDOWN_suspend | SHUTDOWN_crash deriving (Eq, Ord, Show, Read, Enum) instance Storable XCShutdown where sizeOf _ = sizeOf (undefined :: CInt) alignment _ = alignment (undefined :: CInt) peek ptr = peek (castPtr ptr :: Ptr CInt) >>= return . toEnum . fromIntegral poke ptr a = poke (castPtr ptr :: Ptr CInt) (fromIntegral (fromEnum a)) newtype XCHandle = XCHdl CInt deriving (Eq, Ord, Show) instance Storable XCHandle where sizeOf _ = sizeOf (undefined :: CInt) alignment _ = alignment (undefined :: CInt) peek ptr = peek (castPtr ptr) >>= return . XCHdl poke ptr (XCHdl h) = poke (castPtr ptr) h newtype DomId = DomId Word32 deriving (Eq, Ord, Show) instance Storable DomId where sizeOf _ = sizeOf (undefined :: Word32) alignment _ = alignment (undefined :: Word32) peek ptr = peek (castPtr ptr) >>= return . DomId poke ptr i = poke (castPtr ptr) i foreign import ccall unsafe "xc_interface_open" xc_interface_open :: IO XCHandle foreign import ccall unsafe "xc_interface_close" xc_interface_close :: XCHandle -> IO CInt foreign import ccall unsafe "xc_find_device_number" xc_find_device_number :: CString -> IO CInt foreign import ccall unsafe "xenctrl.h xc_domain_create" xc_domain_create :: XCHandle -> DomId -> XenDomainHandleT -> Word32 -> IO CInt foreign import ccall unsafe "xenctrl.h xc_domain_dumpcore" xc_domain_dumpcore :: XCHandle -> DomId -> CString -> IO CInt type Dumpcore_rtn_t = FunPtr (Ptr Word8 -> CString -> CUInt -> IO CInt) foreign import ccall safe "xenctrl.h xc_domain_dumpcore_via_callback" xc_domain_dumpcore_via_callback :: XCHandle -> DomId -> Ptr Word8 -> IO Dumpcore_rtn_t foreign import ccall unsafe "xenctrl.h xc_domain_max_vcpus" xc_domain_max_vcpus :: XCHandle -> DomId -> CUInt -> IO CInt foreign import ccall unsafe "xenctrl.h xc_domain_pause" xc_domain_pause :: XCHandle -> DomId -> IO CInt foreign import ccall unsafe "xenctrl.h xc_domain_unpause" xc_domain_unpause :: XCHandle -> DomId -> IO CInt foreign import ccall unsafe "xenctrl.h xc_domain_destroy" xc_domain_destroy :: XCHandle -> DomId -> IO CInt foreign import ccall unsafe "xenctrl.h xc_domain_resume" xc_domain_resume :: XCHandle -> DomId -> CInt -> IO CInt foreign import ccall unsafe "xenctrl.h xc_domain_shutdown" xc_domain_shutdown :: XCHandle -> DomId -> CInt -> IO CInt foreign import ccall unsafe "xenctrl.h xc_vcpu_setaffinity" xc_vcpu_setaffinity :: XCHandle -> DomId -> CInt -> Word64 -> IO CInt foreign import ccall unsafe "xenctrl.h xc_vcpu_getaffinity" xc_vcpu_getaffinity :: XCHandle -> DomId -> CInt -> Ptr Word64 -> IO CInt foreign import ccall unsafe "xenctrl.h xc_domain_getinfo" xc_domain_getinfo :: XCHandle -> DomId -> CUInt -> Ptr XC_DomInfo -> IO CInt -- TODO need to base VCPU_Guest_Context on arch specific info -- how can I trick that info from cabal and use it here? -- -- foreign import ccall unsafe "xenctrl.h xc_vcpu_setcontext" -- xc_vcpu_setcontext :: XCHandle -> DomId -> Word32 -> Ptr VCPU_Guest_Context -> IO CInt foreign import ccall unsafe "xenctrl.h xc_domain_getinfolist" xc_domain_getinfolist :: XCHandle -> DomId -> CUInt -> Ptr XC_DomInfo -> CInt -- Data and functions for debugging data XC_Core_Header = XC_Core_Header { xchMagic :: CInt , xchNrVCPUs :: CInt , xchNrPages :: CInt , xchCTXTOffset :: CInt , xchIndexOffset :: CInt , xchPagesOffset :: CInt } deriving (Eq, Ord, Show) instance Storable XC_Core_Header where sizeOf _ = (#size xc_core_header_t) alignment _ = alignment (undefined :: CInt) peek ptr = do m <- (#peek xc_core_header_t, xch_magic) ptr v <- (#peek xc_core_header_t, xch_nr_vcpus) ptr p <- (#peek xc_core_header_t, xch_nr_pages) ptr c <- (#peek xc_core_header_t, xch_ctxt_offset) ptr i <- (#peek xc_core_header_t, xch_index_offset) ptr g <- (#peek xc_core_header_t, xch_pages_offset) ptr return (XC_Core_Header m v p c i g) poke ptr (XC_Core_Header m v p c i g) = do (#poke xc_core_header_t, xch_magic) ptr m (#poke xc_core_header_t, xch_nr_vcpus) ptr v (#poke xc_core_header_t, xch_nr_pages) ptr p (#poke xc_core_header_t, xch_ctxt_offset) ptr c (#poke xc_core_header_t, xch_index_offset) ptr i (#poke xc_core_header_t, xch_pages_offset) ptr g