packages feed

hen (empty) → 0.0.0

raw patch · 9 files changed

+479/−0 lines, 9 filesdep +basedep +bitsetdep +containerssetup-changed

Dependencies added: base, bitset, containers, lifted-base, monad-control, mtl, transformers-base, uuid

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hen.cabal view
@@ -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 <knsd@knsd.net>+                    Sergei Lebedev <superbobry@gmail.com>+Maintainer:         Fedor Gogolev <knsd@knsd.net>+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
+ src/System/Xen.hs view
@@ -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(..))
+ src/System/Xen/Errors.hs view
@@ -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
+ src/System/Xen/High.hs view
@@ -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
+ src/System/Xen/Low.hsc view
@@ -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 <xenctrl.h>++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
+ src/System/Xen/Mid.hsc view
@@ -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 <xenctrl.h>++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)
+ src/System/Xen/Types.hsc view
@@ -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 <xenctrl.h>+#include <xen/sched.h>++#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 <xen/sched.h>.+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"