diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2013 Selectel + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hen.cabal b/hen.cabal new file mode 100644 --- /dev/null +++ b/hen.cabal @@ -0,0 +1,43 @@ +Name: hen +Version: 0.0.0 +Synopsis: Haskell bindings to Xen hypervisor interface +Description: Haskell bindings to Xen hypervisor interface +License: MIT +License-file: LICENSE +Copyright: Selectel +Author: Fedor Gogolev + Sergei Lebedev +Maintainer: Fedor Gogolev +Homepage: https://github.com/selectel/hen +Bug-reports: https://github.com/selectel/hen/issues +Category: System +Stability: Alpha +Build-type: Simple +Cabal-version: >= 1.12 +Tested-with: GHC == 7.6.* + +Library + Hs-source-dirs: src + Ghc-options: -Wall -fno-warn-orphans + Default-language: Haskell2010 + + Build-depends: base == 4.6.* || == 4.5.* + , containers == 0.5.* + , mtl == 2.1.* + , transformers-base == 0.4.* + , lifted-base == 0.2.* + , monad-control == 0.3.* + , uuid == 1.2.* + , bitset == 1.1.* + + Exposed-modules: System.Xen + System.Xen.High + System.Xen.Types + System.Xen.Errors + System.Xen.Mid + System.Xen.Low + Extra-libraries: xenctrl + +Source-repository head + Type: git + Location: https://github.com/selectel/hen diff --git a/src/System/Xen.hs b/src/System/Xen.hs new file mode 100644 --- /dev/null +++ b/src/System/Xen.hs @@ -0,0 +1,43 @@ +-- | Haskell bidings to Xen hypervisor interface. There are three interface levels +-- in this library: +-- +-- * Low-level interface. "System.Xen.Low". It just provides bindings to c-calls. +-- +-- * Mid-level interface. "System.Xen.Mid". Contains helper functions and allow to +-- use your favorite `Monad`. +-- +-- * High-level interface. "System.Xen.High". Contains `Xen` monad and provides a +-- safe way to run any `Xen` computation. +-- +-- Last one is also re-exported by current module and intend for common usage. +-- Usage example: +-- +-- > module Main (main) where +-- > +-- > import System.Xen (runXen, domainGetInfo) +-- > +-- > main :: IO () +-- > main = print =<< runXen domainGetInfo + +module System.Xen + ( + -- * Errors + XcHandleOpenError(..) + , InvalidDomainShutdownReason(..) + , DomainGetInfoError(..) + -- * Domain info + , DomId(..) + , DomainFlag(..) + , DomainShutdownReason(..) + , DomainInfo(..) + -- * High-level API + , Xen + , domainGetInfo + , runXen + ) where + +import System.Xen.Errors (XcHandleOpenError(..), InvalidDomainShutdownReason(..), + DomainGetInfoError(..)) +import System.Xen.High (Xen, domainGetInfo, runXen) +import System.Xen.Types (DomId(..), DomainFlag(..), DomainShutdownReason(..), + DomainInfo(..)) diff --git a/src/System/Xen/Errors.hs b/src/System/Xen/Errors.hs new file mode 100644 --- /dev/null +++ b/src/System/Xen/Errors.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | This module provides every special exception that can be raised in Mid and +-- High-level interfaces. + +module System.Xen.Errors + ( XcHandleOpenError(..) + , InvalidDomainShutdownReason(..) + , DomainGetInfoError(..) + , getErrno + ) where + +import Control.Exception.Lifted (Exception) +import Data.Typeable (Typeable) +import Foreign.C (CInt) +import Foreign.C.Error (Errno(..)) +import qualified Foreign.C.Error as Error + +import Control.Monad.Base (MonadBase(liftBase)) + +deriving instance Ord Errno +deriving instance Show Errno +deriving instance Typeable Errno + +-- | This error can be raised if handle can not be opened, insufficient rights +-- for example. +data XcHandleOpenError = XcHandleOpenError Errno + deriving (Eq, Ord, Show, Typeable) + +instance Exception XcHandleOpenError + +-- | This error can be raised if peecked value of +-- 'System.Xen.Types.DomainShutdownReason' is not expected. +data InvalidDomainShutdownReason = InvalidDomainShutdownReason + CInt -- ^ Peeked value + deriving (Eq, Ord, Show, Typeable) + +instance Exception InvalidDomainShutdownReason + +-- | This error can be raised if any error occured during receiving the list, +-- for example: try to to fetch a list in domU. +data DomainGetInfoError = DomainGetInfoError Errno + deriving (Eq, Ord, Show, Typeable) + +instance Exception DomainGetInfoError + +-- | Generalized version of 'Foreign.C.Error.getErrno' +getErrno :: MonadBase IO m => m Errno +getErrno = liftBase Error.getErrno diff --git a/src/System/Xen/High.hs b/src/System/Xen/High.hs new file mode 100644 --- /dev/null +++ b/src/System/Xen/High.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} + +-- | High-level interface to @XenCtrl@. Contains `Xen` monad and provides a safe way +-- to run any `Xen` computation. +module System.Xen.High + ( Xen + , domainGetInfo + , withXenHandle + , runXen + ) where + +import Control.Applicative (Applicative) +import Control.Exception.Lifted (SomeException, bracket, try) +import Control.Monad (liftM) + +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Reader (ReaderT, runReaderT, ask) +import Control.Monad.Trans.Control (MonadBaseControl(..)) + +import System.Xen.Types (XcHandle, DomainInfo) +import qualified System.Xen.Mid as Mid + +-- | This is a special monad for operations with @XenCtrl@, it's a wrapper around +-- 'ReaderT' transformer and it controls the connection to the hypervisor. +-- Because 'Xen' has instances of and 'MonadBase' and 'MonadBaseControl' over 'IO', +-- you can use any functions of @lifted-base@ library, or any 'IO' with 'liftBase'. +newtype Xen a = Xen { unXen :: ReaderT XcHandle IO a } + deriving (Functor, Applicative, Monad, MonadBase IO) + +instance MonadBaseControl IO Xen where + newtype StM Xen a = StXen { unStXen :: StM (ReaderT XcHandle IO) a } + liftBaseWith f = Xen $ liftBaseWith $ \runInIO -> + f $ liftM StXen . runInIO . unXen + restoreM = Xen . restoreM . unStXen + +-- | Returns a lift of domains, this function can fail with +-- 'System.Xen.Errors.InvalidDomainShutdownReason' and +-- 'System.Xen.Errors.DomainGetInfoError'. +domainGetInfo :: Xen [DomainInfo] +domainGetInfo = withXenHandle Mid.domainGetInfo + +-- | Helper function for creating high-level interface functions from mid-level. +-- Generally high-level function is just @highLevel = withXenHandle midLevel@. +withXenHandle :: (XcHandle -> Xen a) -> Xen a +withXenHandle f = f =<< Xen ask + +-- | Open new connection to the hypervisor, run any 'Xen' action and close +-- connection if nessesary. This function can fail with @Either SomeException@ with +-- 'System.Xen.Errors.XcHandleOpenError' and any error of providing 'Xen' action. +runXen :: MonadBaseControl IO m => Xen a -> m (Either SomeException a) +runXen (Xen f) = try $ withNewHandle $ liftBase . runReaderT f + where + withNewHandle = bracket Mid.interfaceOpen Mid.interfaceClose diff --git a/src/System/Xen/Low.hsc b/src/System/Xen/Low.hsc new file mode 100644 --- /dev/null +++ b/src/System/Xen/Low.hsc @@ -0,0 +1,54 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | Low-level interface to @XenCtrl@. Each function defined in this module is +-- a ffi call to corresponding c function. + +module System.Xen.Low + ( xc_interface_open + , xc_interface_close + , xc_domain_getinfo + ) where + +#include + +import Foreign.C (CInt(..), CUInt(..)) +#if XEN_SYSCTL_INTERFACE_VERSION == 8 +import Foreign.C (CIntPtr(..)) +#endif +import Foreign.Ptr (Ptr) + +import System.Xen.Types (XcHandle(..), DomainInfo(..), DomId(..)) + +-- | This function opens the handle to the hypervisor interface. Each successful call +-- to this function should have a corresponding call to 'xc_interface_close'. +foreign import ccall unsafe "xc_interface_open" +-- There are some changes in xen 4 in comparsion with 3, 'XcHandle' is not a +-- file descriptor, but a pointer to special structure. +#if XEN_SYSCTL_INTERFACE_VERSION == 8 + xc_interface_open :: CInt -- ^ Logger, @NULL@ if stderr + -> CInt -- ^ Domain builder logger + -> CInt -- ^ Open flags + -> IO XcHandle +#elif XEN_SYSCTL_INTERFACE_VERSION == 6 + xc_interface_open :: IO XcHandle +#endif + +-- | This function closes an open hypervisor interface. This function can fail if the +-- handle does not represent an open interface or if there were problems closing the +-- interface. In the latter case the interface is still closed. +foreign import ccall unsafe "xc_interface_close" + xc_interface_close :: XcHandle -> IO CInt + +-- | This function will return information about one or more domains. It is +-- designed to iterate over the list of domains. If a single domain is +-- requested, this function will return the next domain in the list - if +-- one exists. It is, therefore, important in this case to make sure the +-- domain requested was the one returned. +foreign import ccall unsafe "xenctrl.h xc_domain_getinfo" + xc_domain_getinfo :: XcHandle -- ^ Handle to the open hypervisor interface + -> DomId -- ^ First domain to enumerate from. + -> CUInt -- ^ The number of requested domains + -> Ptr DomainInfo -- ^ Pointer to the structure that will + -- contain the information for + -- enumerated domains + -> IO CInt -- ^ Number of domains enumerated, -1 on error diff --git a/src/System/Xen/Mid.hsc b/src/System/Xen/Mid.hsc new file mode 100644 --- /dev/null +++ b/src/System/Xen/Mid.hsc @@ -0,0 +1,57 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Mid-level interface to @XenCtrl@. Functions that provided by this module are +-- version-independent from @Xen@ and raise real exceptions instead of confusing +-- error codes and @errno@. + +module System.Xen.Mid + ( interfaceOpen + , interfaceClose + , domainGetInfo + ) where + +#include + +import Control.Monad (void, when, forM) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Storable (peekElemOff, sizeOf) + +import Control.Exception.Lifted (throwIO) +import Control.Monad.Base (MonadBase(liftBase)) + +import System.Xen.Errors (DomainGetInfoError(..), XcHandleOpenError(..), getErrno) +import System.Xen.Low (xc_interface_open, xc_interface_close, xc_domain_getinfo) +import System.Xen.Types (XcHandle(..), DomId(..), DomainInfo) + +-- | Open the connection to the hypervisor interface, can fail with +-- 'System.Xen.Errors.XcHandleOpenError'. +interfaceOpen :: MonadBase IO m => m XcHandle +interfaceOpen = liftBase $ do +#if XEN_SYSCTL_INTERFACE_VERSION == 8 + i@(XcHandle ptr) <- xc_interface_open 0 0 0 + when (ptr `elem` [-1, 0]) $ getErrno >>= throwIO . XcHandleOpenError +#elif XEN_SYSCTL_INTERFACE_VERSION == 6 + i@(XcHandle h) <- xc_interface_open + when (h == -1) $ getErrno >>= throwIO . XcHandleOpenError +#endif + return i + +-- | Close an open hypervisor interface, ignores all possible errors but all the +-- same can fail with segfault or sutin. +interfaceClose :: MonadBase IO m => XcHandle -> m () +interfaceClose = void . liftBase . xc_interface_close + +-- | Returns a list of currently runing domains, 1024 maximum, can fail with +-- 'System.Xen.Errors.InvalidDomainShutdownReason' and +-- 'System.Xen.Errors.DomainGetInfoError'. +domainGetInfo :: MonadBase IO m => XcHandle -> m [DomainInfo] +domainGetInfo handle = liftBase $ allocaBytes size $ \ptr -> do + wrote <- fmap fromIntegral $ xc_domain_getinfo handle (dom0) count ptr + when (wrote == -1) $ getErrno >>= throwIO . DomainGetInfoError + forM [0 .. wrote - 1] $ peekElemOff ptr + where + dom0 = DomId 0 + count :: Num a => a + count = 1024 + size = count * sizeOf (undefined :: DomainInfo) diff --git a/src/System/Xen/Types.hsc b/src/System/Xen/Types.hsc new file mode 100644 --- /dev/null +++ b/src/System/Xen/Types.hsc @@ -0,0 +1,152 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Types for working with 'XenCtrl' data and accoring 'Storable' instances. +module System.Xen.Types + ( XcHandle(..) + , DomId(..) + , DomainFlag(..) + , DomainShutdownReason(..) + , DomainInfo(..) + ) where + +#include +#include + +#let alignment t = "%lu", (unsigned long) offsetof(struct {char x__; t (y__); }, y__) + +import Prelude hiding (elem) + +import Control.Applicative ((<$>)) +import Data.Bits (testBit) +import Data.Maybe (catMaybes) +import Data.Word (Word32, Word64) +import Foreign.C (CInt(..), CUInt(..)) +#if XEN_SYSCTL_INTERFACE_VERSION == 8 +import Foreign.C (CIntPtr(..)) +#endif +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Storable (Storable(..)) + +import Control.Exception.Lifted (throwIO) +import Data.UUID (UUID) +import Data.BitSet (BitSet) +import qualified Data.BitSet as BitSet + +import System.Xen.Errors (InvalidDomainShutdownReason(..)) + +-- | Entry point of the hypervisor interface connection, it's a file descriptor +-- in xen 3 and pointer to corresponging structure in xen 4. +#if XEN_SYSCTL_INTERFACE_VERSION == 8 +newtype XcHandle = XcHandle CIntPtr +#elif XEN_SYSCTL_INTERFACE_VERSION == 6 +newtype XcHandle = XcHandle CInt +#endif + deriving (Eq, Ord, Show, Storable) + +-- | Domain id, wrapper around 'Word32'. +newtype DomId = DomId { unDomId :: Word32 } + deriving (Eq, Ord, Show, Storable) + +-- | Domain flags. It's translated from xc_dominfo structure, so it's possible to +-- be mutual exclusion flags in one domain, e.g. 'DomainFlagShutdown' and +-- 'DomainFlagRunning'. +data DomainFlag = DomainFlagDying + | DomainFlagCrashed + | DomainFlagShutdown + | DomainFlagPaused + | DomainFlagBlocked + | DomainFlagRunning + | DomainFlagHVM + | DomainFlagDebugged + deriving (Enum, Eq, Ord, Show) + +-- | Domain shutdown reason it's only meaningful if domain has 'DomainFlagShutdown' +-- flag. +data DomainShutdownReason = DomainShutdownReasonPoweroff + | DomainShutdownReasonReboot + | DomainShutdownReasonSuspend + | DomainShutdownReasonCrash + | DomainShutdownReasonWatchdog + deriving (Eq, Ord, Show) + +-- | Information about a single domain. +data DomainInfo = DomainInfo + { domainInfoId :: {-# UNPACK #-} !DomId + , domainInfoSsidRef :: {-# UNPACK #-} !Word32 + , domainInfoFlags :: BitSet DomainFlag + , domainInfoShutdownReason :: Maybe DomainShutdownReason + , domainInfoNumberOfPages :: {-# UNPACK #-} !Word32 +#if XEN_SYSCTL_INTERFACE_VERSION == 8 + , domainInfoNumberOfSharedPages :: {-# UNPACK #-} !Word32 +#endif + , domainInfoSharedInfoFrame :: {-# UNPACK #-} !Word32 + , domainInfoCpuTime :: {-# UNPACK #-} !Word64 + , domainInfoMaxMemKb :: {-# UNPACK #-} !Word32 + , domainInfoNubmerOfOnlineVcpus :: {-# UNPACK #-} !Word32 + , domainInfoMaxVcpuId :: {-# UNPACK #-} !Word32 + , domainInfoDomHandle :: UUID +#if XEN_SYSCTL_INTERFACE_VERSION == 8 + , domainInfoCpuPool :: {-# UNPACK #-} !Word32 +#endif + } deriving (Eq, Ord, Show) + +-- | Constats used in this instance defined in . +instance Storable DomainShutdownReason where + sizeOf _ = sizeOf (undefined :: CInt) + alignment _ = alignment (undefined :: CInt) + peek ptr = peek (castPtr ptr :: Ptr CInt) >>= \i -> case i of + #{const SHUTDOWN_poweroff} -> return DomainShutdownReasonPoweroff + #{const SHUTDOWN_reboot} -> return DomainShutdownReasonReboot + #{const SHUTDOWN_suspend} -> return DomainShutdownReasonSuspend + #{const SHUTDOWN_crash} -> return DomainShutdownReasonCrash + #{const SHUTDOWN_watchdog} -> return DomainShutdownReasonWatchdog + invalid -> throwIO $ InvalidDomainShutdownReason invalid + poke ptr a = poke (castPtr ptr :: Ptr CInt) $ case a of + DomainShutdownReasonPoweroff -> #{const SHUTDOWN_poweroff} + DomainShutdownReasonReboot -> #{const SHUTDOWN_reboot} + DomainShutdownReasonSuspend -> #{const SHUTDOWN_suspend} + DomainShutdownReasonCrash -> #{const SHUTDOWN_crash} + DomainShutdownReasonWatchdog -> #{const SHUTDOWN_watchdog} + +instance Storable DomainInfo where + sizeOf _ = #{size xc_dominfo_t} + alignment _ = #{alignment xc_dominfo_t} + peek ptr = do + domainInfoId <- #{peek xc_dominfo_t, domid} ptr + domainInfoSsidRef <- #{peek xc_dominfo_t, ssidref} ptr + domainInfoFlags <- do + b :: CUInt <- peekByteOff ptr $ + sizeOf domainInfoId + sizeOf domainInfoSsidRef + let maybeBit n v = if testBit b n then Just v else Nothing + return $ BitSet.fromList $ catMaybes + [ maybeBit 0 DomainFlagDying + , maybeBit 1 DomainFlagCrashed + , maybeBit 2 DomainFlagShutdown + , maybeBit 3 DomainFlagPaused + , maybeBit 4 DomainFlagBlocked + , maybeBit 5 DomainFlagRunning + , maybeBit 6 DomainFlagHVM + , maybeBit 7 DomainFlagDebugged + ] + domainInfoShutdownReason <- + if DomainFlagShutdown `BitSet.member` domainInfoFlags + then Just <$> #{peek xc_dominfo_t, shutdown_reason} ptr + else return Nothing + domainInfoNumberOfPages <- #{peek xc_dominfo_t, nr_pages} ptr +#if XEN_SYSCTL_INTERFACE_VERSION == 8 + domainInfoNumberOfSharedPages <- #{peek xc_dominfo_t, nr_shared_pages} ptr +#endif + domainInfoSharedInfoFrame <- #{peek xc_dominfo_t, shared_info_frame} ptr + domainInfoCpuTime <- #{peek xc_dominfo_t, cpu_time} ptr + domainInfoMaxMemKb <- #{peek xc_dominfo_t, max_memkb} ptr + domainInfoNubmerOfOnlineVcpus <- #{peek xc_dominfo_t, nr_online_vcpus} ptr + domainInfoMaxVcpuId <- #{peek xc_dominfo_t, max_vcpu_id} ptr + domainInfoDomHandle <- #{peek xc_dominfo_t, handle} ptr +#if XEN_SYSCTL_INTERFACE_VERSION == 8 + domainInfoCpuPool <- #{peek xc_dominfo_t, cpupool} ptr +#endif + return $ DomainInfo { .. } + poke = error "Storable DomainInfo poke: not implemented"