batchd-libvirt (empty) → 0.1.0.0
raw patch · 5 files changed
+161/−0 lines, 5 filesdep +aesondep +basedep +batchd-coresetup-changed
Dependencies added: aeson, base, batchd-core, heavy-logger, libvirt-hs, text, text-format-heavy, time
Files
- LICENSE +30/−0
- README.md +4/−0
- Setup.hs +2/−0
- batchd-libvirt.cabal +30/−0
- src/Batchd/Ext/LibVirt.hs +95/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT+OWNER 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.
+ README.md view
@@ -0,0 +1,4 @@+batchd-libvirt README+=====================++This is an adapter package, containing `batchd` host controller implementation based on libvirt.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ batchd-libvirt.cabal view
@@ -0,0 +1,30 @@+name: batchd-libvirt+version: 0.1.0.0+synopsis: host controller for batchd, which controls virtual machines via libvirt library.+homepage: https://github.com/portnov/batchd/batchd-libvirt#readme+license: BSD3+license-file: LICENSE+author: ILyaPortnov+maintainer: portnov84@rambler.ru+copyright: 2017-2022 Ilya Portnov+category: System+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Batchd.Ext.LibVirt+ build-depends: base >= 4.7 && < 5,+ time >= 1.6,+ text >= 1.2.2.2,+ aeson >= 1.1.2.0,+ text-format-heavy >= 0.1.5.0,+ heavy-logger >= 0.3.1.0,+ batchd-core >= 0.1.0.0,+ libvirt-hs >= 0.2.1+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/portnov/batchd
+ src/Batchd/Ext/LibVirt.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | This module contains an implementation of batchd host controller,+-- which controls VMs supported by LibVirt.+module Batchd.Ext.LibVirt+ (+ LibVirtSettings (..),+ libVirtDriver+ ) where++import Control.Monad (when)+import Control.Exception+import Control.Concurrent+import Data.Time+import qualified Data.Text as T+import Data.Text.Format.Heavy+import Data.Aeson+import System.Log.Heavy+import Batchd.Core+import System.LibVirt as V++-- | Settings of LibVirt host controller+data LibVirtSettings = LibVirtSettings {+ lvEnableStartStop :: Bool -- ^ Automatic start\/stop of VMs can be disabled in config file.+ , lvConnectionString :: String -- ^ Libvirt connection string. Default is @"qemu:///system"@.+ }+ deriving (Show)++instance FromJSON LibVirtSettings where+ parseJSON (Object v) = do+ driver <- v .: "driver"+ when (driver /= ("libvirt" :: T.Text)) $+ fail $ "incorrect driver specification"+ enable <- v .:? "enable_start_stop" .!= True+ conn <- v .:? "connection_string" .!= "qemu:///system"+ return $ LibVirtSettings enable conn++-- | Initialize LibVirt host controller+libVirtDriver :: HostDriver+libVirtDriver = controllerFromConfig "libvirt" mkLibVirt++mkLibVirt :: LibVirtSettings -> LoggingTState -> HostController+mkLibVirt l lts = HostController {++ controllerDriverName = driverName libVirtDriver,++ doesSupportStartStop = lvEnableStartStop l,++ getActualHostName = \_ -> return Nothing,++ startHost = \host -> do+ let name = T.unpack $ hControllerId host+ withConnection (lvConnectionString l) $ \conn -> do+ infoIO lts $(here) "Connection to libvirt URI {} succeeded" (Single $ lvConnectionString l)+ mbdom <- do+ x <- try $ lookupDomainName conn name+ case x of+ Left (e :: V.Error) -> do+ reportErrorIO lts $(here) "Cannot get domain ID by name `{}': {}" (name, show e)+ return Nothing+ Right dom -> return (Just dom)+ case mbdom of+ Just dom -> do+ di <- getDomainInfo dom+ debugIO lts $(here) "Domain information obtained: {}" (Single $ show di)+ case diState di of+ DomainRunning -> return $ Right ()+ DomainPaused -> resumeDomain dom >> (return $ Right ())+ DomainShutoff -> do+ createDomain dom+ return $ Right ()+ st -> return $ Left $ UnknownError $ "Don't know what to do with virtual domain " ++ name ++ " in state " ++ show st+ Nothing -> return $ Left $ UnknownError $ "Domain is not defined in hypervisor: " ++ name ,++ stopHost = \name -> do+ withConnection (lvConnectionString l) $ \conn -> do+ infoIO lts $(here) "Connection to libvirt URI {} succeeded" (Single $ lvConnectionString l)+ mbdom <- do+ x <- try $ lookupDomainName conn (T.unpack name)+ case x of+ Left (e :: V.Error) -> do+ reportErrorIO lts $(here) "Cannot get domain ID by name `{}': {}" (name, show e)+ return Nothing+ Right dom -> return (Just dom)+ case mbdom of+ Nothing -> return $ Left $ UnknownError $ "No such domain on hypervisor: " ++ T.unpack name+ Just dom -> do+ shutdownDomain dom+ return $ Right ()+ }+