CBindings.hsc

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 <xenctrl.h>

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 <xen/sched.h>
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