diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) Thomas M. DuBuisson + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/System/Xen/CBindings.hsc b/System/Xen/CBindings.hsc new file mode 100644 --- /dev/null +++ b/System/Xen/CBindings.hsc @@ -0,0 +1,220 @@ +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 diff --git a/hsXenCtrl.cabal b/hsXenCtrl.cabal new file mode 100644 --- /dev/null +++ b/hsXenCtrl.cabal @@ -0,0 +1,19 @@ +name: hsXenCtrl +version: 0.0.2 +synopsis: FFI bindings to the Xen Control library. +description: FFI bindings to xenctrl.h and perhaps more. + This is an early (incomplete) release, but in general + the System.Xen.CBindings should provide direct access + to the C API while System.Xen will eventually provide + a higher level abstraction. +category: System +license: BSD3 +license-file: LICENSE +author: Thomas M. DuBuisson +maintainer: thomas.dubuisson@gmail.com +stability: experimental +build-Depends: base, bytestring, mtl, array +build-type: Simple +ghc-options: +exposed-modules: System.Xen.CBindings +extensions: ForeignFunctionInterface, FlexibleInstances