hsXenCtrl (empty) → 0.0.2
raw patch · 4 files changed
+272/−0 lines, 4 filesdep +arraydep +basedep +bytestringsetup-changed
Dependencies added: array, base, bytestring, mtl
Files
- LICENSE +30/−0
- Setup.lhs +3/−0
- System/Xen/CBindings.hsc +220/−0
- hsXenCtrl.cabal +19/−0
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ System/Xen/CBindings.hsc view
@@ -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 <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
+ hsXenCtrl.cabal view
@@ -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