hen 0.0.3 → 0.1.0
raw patch · 8 files changed
+186/−79 lines, 8 filesdep +boxesdep +exceptionsdep +optparse-applicativedep −containersdep −lifted-basedep −monad-controldep ~bitsetnew-component:exe:he
Dependencies added: boxes, exceptions, optparse-applicative, transformers
Dependencies removed: containers, lifted-base, monad-control, transformers-base
Dependency ranges changed: bitset
Files
- bin/He.hs +21/−0
- hen.cabal +26/−11
- src/System/Xen.hs +5/−4
- src/System/Xen/Errors.hs +4/−5
- src/System/Xen/High.hs +6/−45
- src/System/Xen/High/Internal.hs +111/−0
- src/System/Xen/Mid.hsc +11/−12
- src/System/Xen/Types.hsc +2/−2
+ bin/He.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE RecordWildCards #-}++module Main (main) where++import Control.Exception (SomeException)+import Control.Monad (void)++import System.Xen (runXenT)++import He.Options (HeCommand(..), HeOptions(..), getOptions)+import qualified He.Commands.List as HeList++reportError :: SomeException -> IO ()+reportError = error . show++main :: IO ()+main = do+ HeOptions { .. } <- getOptions+ result <- runXenT $ case heOptionCommand of+ HeCommandList -> void $ HeList.run+ either reportError (const $ return ()) result
hen.cabal view
@@ -1,5 +1,5 @@ Name: hen-Version: 0.0.3+Version: 0.1.0 Synopsis: Haskell bindings to Xen hypervisor interface Description: Haskell bindings to Xen hypervisor interface License: MIT@@ -22,21 +22,20 @@ Default-language: Haskell2010 Build-depends: base == 4.6.* || == 4.5.*- , containers == 0.5.* || == 0.4.*+ , transformers == 0.3.* , mtl == 2.1.* || == 2.0.*- , transformers-base == 0.4.*- , lifted-base == 0.2.*- , monad-control == 0.3.*+ , exceptions == 0.1.* , uuid == 1.2.* , bitset == 1.4.* Exposed-modules: System.Xen System.Xen.High+ System.Xen.High.Internal System.Xen.Types System.Xen.Errors System.Xen.Mid System.Xen.Low- Extra-libraries: xenctrl+-- Extra-libraries: xenctrl Test-suite hen-tests Main-is: Tests.hs@@ -45,18 +44,34 @@ Type: exitcode-stdio-1.0 Build-depends: base == 4.6.* || == 4.5.*- , containers == 0.5.* || == 0.4.*+ , transformers == 0.3.* , mtl == 2.1.* || == 2.0.*- , transformers-base == 0.4.*- , lifted-base == 0.2.*- , monad-control == 0.3.*+ , exceptions == 0.1.* , uuid == 1.2.*- , bitset == 1.3.*+ , bitset == 1.4.* , hen , test-framework == 0.8.* , test-framework-quickcheck2 == 0.3.* , QuickCheck == 2.5.*++Executable he+ Main-is: He.hs+ Hs-source-dirs: src, bin+ Ghc-options: -Wall -fno-warn-orphans+ Default-language: Haskell2010++ Build-depends: base == 4.6.* || == 4.5.*+ , transformers == 0.3.*+ , mtl == 2.1.* || == 2.0.*+ , exceptions == 0.1.*+ , uuid == 1.2.*+ , bitset >= 1.4.0 || < 1.4.2+ , hen++ , optparse-applicative == 0.5.*+ , boxes == 0.1.*+ Source-repository head Type: git
src/System/Xen.hs view
@@ -14,10 +14,10 @@ -- -- > module Main (main) where -- >--- > import System.Xen (runXen, domainGetInfo)+-- > import System.Xen (runXenT, domainGetInfo) -- > -- > main :: IO ()--- > main = print =<< runXen domainGetInfo+-- > main = print =<< runXenT domainGetInfo module System.Xen (@@ -31,13 +31,14 @@ , DomainShutdownReason(..) , DomainInfo(..) -- * High-level API+ , XenT , Xen , domainGetInfo- , runXen+ , runXenT ) where import System.Xen.Errors (XcHandleOpenError(..), InvalidDomainShutdownReason(..), DomainGetInfoError(..))-import System.Xen.High (Xen, domainGetInfo, runXen)+import System.Xen.High (XenT, Xen, domainGetInfo, runXenT) import System.Xen.Types (DomId(..), DomainFlag(..), DomainShutdownReason(..), DomainInfo(..))
src/System/Xen/Errors.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-} -- | This module provides every special exception that can be raised in Mid and -- High-level interfaces.@@ -12,13 +11,13 @@ , getErrno ) where -import Control.Exception.Lifted (Exception)+import Control.Exception (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))+import Control.Monad.Trans (MonadIO(liftIO)) deriving instance Ord Errno deriving instance Show Errno@@ -47,5 +46,5 @@ instance Exception DomainGetInfoError -- | Generalized version of 'Foreign.C.Error.getErrno'-getErrno :: MonadBase IO m => m Errno-getErrno = liftBase Error.getErrno+getErrno :: MonadIO m => m Errno+getErrno = liftIO Error.getErrno
src/System/Xen/High.hs view
@@ -1,57 +1,18 @@-{-# 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+ ( XenT+ , Xen , domainGetInfo- , withXenHandle- , runXen+ , runXenT ) 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 System.Xen.High.Internal (XenT, Xen, MonadXen(withXenHandle), runXenT)+import System.Xen.Types (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 :: MonadXen m => m [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/High/Internal.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-}++module System.Xen.High.Internal+ ( XenT(..)+ , Xen+ , MonadXen(..)+ , runXenT+ ) where++import Control.Applicative (Applicative)+import Control.Exception (SomeException)+import Data.Monoid (Monoid)++import Control.Monad.Catch (MonadCatch, try, bracket)+import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT, mapReaderT, ask)+import Control.Monad.RWS (MonadRWS)+import Control.Monad.State (MonadState(..))+import Control.Monad.Writer (MonadWriter(..))++import Control.Monad.Trans.Identity (IdentityT(..))+import Control.Monad.Trans (MonadIO, MonadTrans(lift))+import qualified Control.Monad.Trans.Cont as Cont+import qualified Control.Monad.Trans.Error as Error+import qualified Control.Monad.Trans.State.Lazy as LazyState+import qualified Control.Monad.Trans.State.Strict as StrictState+import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter+import qualified Control.Monad.Trans.Writer.Strict as StrictWriter+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS++import System.Xen.Types (XcHandle)+import qualified System.Xen.Mid as Mid++------------------------------------------------------------------------------+-- * The mtl style typeclass++class (Functor m, MonadIO m) => MonadXen m where+ -- | Helper function for creating high-level interface functions from mid-level.+ -- Generally high-level function is just @highLevel = withXenHandle midLevel@.+ withXenHandle :: (XcHandle -> m a) -> m a++instance MonadXen m => MonadXen (Cont.ContT r m) where+ withXenHandle = Cont.mapContT id . withXenHandle++instance (MonadXen m, Error.Error e) => MonadXen (Error.ErrorT e m) where+ withXenHandle = Error.mapErrorT id . withXenHandle++deriving instance MonadXen m => MonadXen (IdentityT m)++instance MonadXen m => MonadXen (LazyState.StateT s m) where+ withXenHandle = LazyState.mapStateT id . withXenHandle++instance MonadXen m => MonadXen (StrictState.StateT s m) where+ withXenHandle = StrictState.mapStateT id . withXenHandle++instance MonadXen m => MonadXen (ReaderT r m) where+ withXenHandle = mapReaderT id . withXenHandle++instance (MonadXen m, Monoid w) => MonadXen (LazyWriter.WriterT w m) where+ withXenHandle = LazyWriter.mapWriterT id . withXenHandle++instance (MonadXen m, Monoid w) => MonadXen (StrictWriter.WriterT w m) where+ withXenHandle = StrictWriter.mapWriterT id . withXenHandle++instance (MonadXen m, Monoid w) => MonadXen (LazyRWS.RWST r w s m) where+ withXenHandle = LazyRWS.mapRWST id . withXenHandle++instance (MonadXen m, Monoid w) => MonadXen (StrictRWS.RWST r w s m) where+ withXenHandle = StrictRWS.mapRWST id . withXenHandle++-- * The @transformers@-style monad transfomer+------------------------------------------------------------------------------++newtype XenT m a = XenT { unXenT :: ReaderT XcHandle m a }+ deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadCatch)++type Xen = XenT IO++instance (Functor m, MonadIO m, MonadCatch m) => MonadXen (XenT m) where+ withXenHandle f = f =<< XenT ask++instance MonadState s m => MonadState s (XenT m) where+ get = lift get+ put = lift . put+#if MIN_VERSION_mtl(2,1,0)+ state = lift . state+#endif++instance MonadReader r m => MonadReader r (XenT m) where+ ask = lift ask+ local f = XenT . mapReaderT (local f) . unXenT++instance MonadWriter w m => MonadWriter w (XenT m) where+ tell = lift . tell+ listen = XenT . listen . unXenT+ pass = XenT . pass . unXenT++instance MonadRWS r w s m => MonadRWS r w s (XenT m)++-- | 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.+runXenT :: (Functor m, MonadIO m, MonadCatch m) => XenT m a -> m (Either SomeException a)+runXenT (XenT f) = try $ withNewHandle $ runReaderT f+ where+ withNewHandle = bracket Mid.interfaceOpen Mid.interfaceClose
src/System/Xen/Mid.hsc view
@@ -1,5 +1,4 @@ {-# 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@@ -17,8 +16,8 @@ import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Storable (peekElemOff, sizeOf) -import Control.Exception.Lifted (throwIO)-import Control.Monad.Base (MonadBase(liftBase))+import Control.Monad.Catch (throwM)+import Control.Monad.Trans (MonadIO(liftIO)) import System.Xen.Errors (DomainGetInfoError(..), XcHandleOpenError(..), getErrno) import System.Xen.Low (xc_interface_open, xc_interface_close, xc_domain_getinfo)@@ -26,29 +25,29 @@ -- | Open the connection to the hypervisor interface, can fail with -- 'System.Xen.Errors.XcHandleOpenError'.-interfaceOpen :: MonadBase IO m => m XcHandle-interfaceOpen = liftBase $ do+interfaceOpen :: MonadIO m => m XcHandle+interfaceOpen = liftIO $ do #if XEN_SYSCTL_INTERFACE_VERSION == 8 i@(XcHandle ptr) <- xc_interface_open 0 0 0- when (ptr `elem` [-1, 0]) $ getErrno >>= throwIO . XcHandleOpenError+ when (ptr `elem` [-1, 0]) $ getErrno >>= throwM . XcHandleOpenError #elif XEN_SYSCTL_INTERFACE_VERSION == 6 i@(XcHandle h) <- xc_interface_open- when (h == -1) $ getErrno >>= throwIO . XcHandleOpenError+ when (h == -1) $ getErrno >>= throwM . 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+interfaceClose :: (MonadIO m, Functor m) => XcHandle -> m ()+interfaceClose = void . liftIO . 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+domainGetInfo :: MonadIO m => XcHandle -> m [DomainInfo]+domainGetInfo handle = liftIO $ allocaBytes size $ \ptr -> do wrote <- fmap fromIntegral $ xc_domain_getinfo handle (dom0) count ptr- when (wrote == -1) $ getErrno >>= throwIO . DomainGetInfoError+ when (wrote == -1) $ getErrno >>= throwM . DomainGetInfoError forM [0 .. wrote - 1] $ peekElemOff ptr where dom0 = DomId 0
src/System/Xen/Types.hsc view
@@ -31,7 +31,7 @@ import Foreign.Ptr (Ptr, castPtr) import Foreign.Storable (Storable(..)) -import Control.Exception.Lifted (throwIO)+import Control.Monad.Catch (throwM) import Data.UUID (UUID) import Data.BitSet (BitSet) import qualified Data.BitSet as BitSet@@ -104,7 +104,7 @@ #{const SHUTDOWN_suspend} -> return DomainShutdownReasonSuspend #{const SHUTDOWN_crash} -> return DomainShutdownReasonCrash #{const SHUTDOWN_watchdog} -> return DomainShutdownReasonWatchdog- invalid -> throwIO $ InvalidDomainShutdownReason invalid+ invalid -> throwM $ InvalidDomainShutdownReason invalid poke ptr a = poke (castPtr ptr :: Ptr CInt) $ case a of DomainShutdownReasonPoweroff -> #{const SHUTDOWN_poweroff} DomainShutdownReasonReboot -> #{const SHUTDOWN_reboot}