diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +batchd-core README +================== + +This package exports core definition of batchd package, which are used by batchd extension packages. + 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/batchd-core.cabal b/batchd-core.cabal new file mode 100644 --- /dev/null +++ b/batchd-core.cabal @@ -0,0 +1,59 @@ +name: batchd-core +version: 0.1.0.0 +synopsis: Core modules of batchd, to use in batchd extensions +description: This package contains minimal set of batchd modules, that + is required for batchd extensions, such as host controllers. +homepage: https://github.com/portnov/batchd/batchd-core#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.Core + Batchd.Core.Common.Types + Batchd.Core.Common.Config + Batchd.Core.Common.Localize + Batchd.Core.Daemon.Hosts + Batchd.Core.Daemon.Logging + + other-extensions: TypeFamilies, DeriveDataTypeable, TemplateHaskell, StandaloneDeriving, RecordWildCards + + build-depends: base >=4.7 && <5.0, + template-haskell >= 2.10, + th-lift >= 0.7.7, + persistent >= 2.2, + persistent-template >= 2, + hsyslog >= 5, + text-format-heavy >= 0.1.5.3, + heavy-logger >= 0.3.2.2, + localize >= 0.2, + mtl >=2.2 && <2.3, + dates >=0.2 && <0.3, + filepath >= 1.3, + directory >= 1.2, + time >=1.4 && <1.10, + syb >=0.6, + containers >=0.5 && <0.7, + unordered-containers >= 0.2, + resourcet >= 1.1.7, + wai >= 3.0, + scotty >= 0.10, + aeson >= 0.11, + yaml >= 0.8.4, + text >= 1.2, + bytestring >= 0.10 + -- hs-source-dirs: + ghc-options: -fwarn-unused-imports -fwarn-missing-signatures + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/portnov/batchd diff --git a/src/Batchd/Core.hs b/src/Batchd/Core.hs new file mode 100644 --- /dev/null +++ b/src/Batchd/Core.hs @@ -0,0 +1,14 @@ +-- | This module re-exports all required interfaces for batchd extensions. +module Batchd.Core + ( + module Batchd.Core.Common.Types, + module Batchd.Core.Daemon.Hosts, + module Batchd.Core.Daemon.Logging, + loadHostControllerConfig + ) where + +import Batchd.Core.Common.Types +import Batchd.Core.Common.Config (loadHostControllerConfig) +import Batchd.Core.Daemon.Hosts +import Batchd.Core.Daemon.Logging + diff --git a/src/Batchd/Core/Common/Config.hs b/src/Batchd/Core/Common/Config.hs new file mode 100644 --- /dev/null +++ b/src/Batchd/Core/Common/Config.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module contains utility functions for locating and loading +-- configuration files. +module Batchd.Core.Common.Config where + +import Control.Monad +import Data.Yaml +import qualified Data.Text as T +import System.FilePath +import System.Environment +import System.Directory + +import Batchd.Core.Common.Types + +-- | Get list of directories in which to look up for configs +-- of certain type. Example: +-- @getConfigDirs "hosts" == ["/home/user/.config/batchd/hosts", "/etc/batchd/hosts"]@ +getConfigDirs :: String -> IO [FilePath] +getConfigDirs t = do + home <- getEnv "HOME" + let homeCfg = home ".config" "batchd" t + homeExists <- doesDirectoryExist homeCfg + let etc = "/etc" "batchd" t + etcExists <- doesDirectoryExist etc + return $ (if homeExists then [homeCfg] else []) ++ + (if etcExists then [etc] else []) + +-- | Locate config file of certain type. +-- Returns Nothing if no files found. +locateConfig :: String -- ^ Config type + -> T.Text -- ^ Config file name (e.g. @"host.yaml"@) + -> IO (Maybe FilePath) +locateConfig t name = do + paths <- getConfigDirs t + let nameStr = T.unpack name + rs <- forM paths $ \path -> do + let file = path nameStr + ex <- doesFileExist file + return $ if ex then [file] else [] + case concat rs of + [] -> return Nothing + (result:_) -> return $ Just result + +-- | Load configuration file of certain type. +loadConfig :: FromJSON config + => String -- ^ Config type + -> T.Text -- ^ Config file name without extension (@"host"@) + -> (ParseException -> Error) -- ^ Wrap YAML parsing error. This is usually one of @Error@ constructors. + -> IO (Either Error config) +loadConfig t name exc = do + mbPath <- locateConfig t (name <> ".yaml") + case mbPath of + Nothing -> return $ Left $ FileNotExists (T.unpack name ++ ".yaml") + Just path -> do + r <- decodeFileEither path + case r of + Left err -> return $ Left $ exc err + Right cfg -> return $ Right cfg + +-- | Load config file of host controller. +loadHostControllerConfig :: FromJSON config => T.Text -> IO (Either Error config) +loadHostControllerConfig name = loadConfig "controllers" name InvalidHostControllerConfig + +-- | Load host config file +loadHost :: T.Text -> IO (Either Error Host) +loadHost name = loadConfig "hosts" name InvalidHost + diff --git a/src/Batchd/Core/Common/Localize.hs b/src/Batchd/Core/Common/Localize.hs new file mode 100644 --- /dev/null +++ b/src/Batchd/Core/Common/Localize.hs @@ -0,0 +1,33 @@ +-- | This module contains utilities for localization. +-- This also re-exports commonly used modules from @localize@ package. +module Batchd.Core.Common.Localize + ( + translationPolicy, + __, __f, + __s, __sf, + Localized (..), + module Text.Localize.IO + ) where + +import qualified Data.Text.Lazy as TL +import Data.Text.Format.Heavy +import Text.Localize +import Text.Localize.IO + +-- | Standard batchd translation files location policy: +-- first check @"mo"@ subdirectory in current directory, +-- then check standard linux locations. +translationPolicy :: LocatePolicy +translationPolicy = + let local = localLocation "mo" + global = linuxLocation "batchd" + in global {lcBasePaths = lcBasePaths local ++ lcBasePaths global} + +-- | Variant of @__@, returning String. +__s :: (Localized m, MonadFail m) => TranslationSource -> m String +__s str = TL.unpack `fmap` (__ str) + +-- | Variant of @__f@, returning String. +__sf :: (Localized m, MonadFail m, VarContainer vars) => TranslationSource -> vars -> m String +__sf str vars = TL.unpack `fmap` (__f str vars) + diff --git a/src/Batchd/Core/Common/Types.hs b/src/Batchd/Core/Common/Types.hs new file mode 100644 --- /dev/null +++ b/src/Batchd/Core/Common/Types.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, TemplateHaskell, GeneralizedNewtypeDeriving, DeriveGeneric, StandaloneDeriving, OverloadedStrings, FlexibleInstances, RecordWildCards #-} +-- | This module contains data type declarations that are used both by batchd daemon and client. +module Batchd.Core.Common.Types + ( + -- * Data types + Host (..), Variables, + -- * Exceptions + Error (..), + -- * Utility functions + bstrToString, stringToBstr, + -- * Logging levels + event_level, verbose_level, config_level + ) where + +import GHC.Generics +import Control.Exception +import Data.Generics hiding (Generic) +import Data.Char +import qualified Data.Map as M +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Aeson as Aeson +import Data.Aeson.Types +import Data.Yaml (ParseException (..)) +import qualified System.Posix.Syslog as Syslog +import System.Log.Heavy + +-- | Recognized error types. +data Error = + QueueExists String + | QueueNotExists String + | QueueNotEmpty + | ScheduleUsed + | ScheduleNotExists String + | JobNotExists + | InvalidJobType ParseException + | InvalidHost ParseException + | InvalidDbCfg ParseException + | InvalidHostControllerConfig ParseException + | InvalidConfig ParseException + | InvalidJobStatus (Maybe B.ByteString) + | FileNotExists FilePath + | MetricNotExists String + | InsufficientRights String + | InvalidStartTime + | SqlError SomeException + | HostInitializationError Int + | UnknownError String + +instance Show Error where + show (QueueNotExists name) = "Queue does not exist: " ++ name + show (QueueExists name) = "Queue already exists: " ++ name + show QueueNotEmpty = "Queue is not empty" + show (ScheduleNotExists name) = "Schedule does not exist: " ++ name + show ScheduleUsed = "Schedule is used by queues" + show JobNotExists = "Job does not exist" + show (InvalidJobType e) = "Invalid job type: " ++ show e + show (InvalidHost e) = "Invalid host description: " ++ show e + show (InvalidDbCfg e) = "Invalid database config: " ++ show e + show (InvalidHostControllerConfig e) = "Invalid host controller config: " ++ show e + show (InvalidConfig e) = "Invalid config: " ++ show e + show (InvalidJobStatus Nothing) = "Invalid job status" + show (InvalidJobStatus (Just s)) = "Invalid job status: " ++ show s + show (FileNotExists path) = "File does not exist: " ++ path + show (MetricNotExists path) = "Metric does not exist: " ++ path + show (InsufficientRights msg) = "Insufficient privileges: " ++ msg + show InvalidStartTime = "Job start time does not match queue schedule" + show (SqlError exc) = "SQL exception: " ++ show exc + show (HostInitializationError rc) = "Failed to execute initialization commands on host: " ++ show rc + show (UnknownError e) = "Unhandled error: " ++ e + +instance Exception Error + +type Variables = M.Map TL.Text T.Text + +-- | Remote host description +data Host = Host { + hName :: T.Text -- ^ Name (identifier) + , hHostName :: T.Text -- ^ Network host name + , hControllerId :: T.Text -- ^ ID by which this host is known to the controller + , hPublicKey :: Maybe FilePath -- ^ Path to SSH public key file + , hPrivateKey :: Maybe FilePath -- ^ Path to SSH private key file + , hPassphrase :: T.Text -- ^ Passphrase for SSH private key + , hUserName :: T.Text -- ^ SSH user name + , hPort :: Int -- ^ SSH port (default 22) + , hMaxJobs :: Maybe Int -- ^ Maximum number of jobs which this host can execute + -- in parallel. + , hController :: T.Text -- ^ Name of host controller. Default is local. + , hStartupTime :: Int -- ^ Startup\/initialization time, in seconds. + -- Batchd will wait this time after host starttup + -- before executing actual commands. Default is 5. + , hShutdownTimeout :: Int -- ^ Only shut down the host if it is not used for this + -- time (in seconds). This is used to prevent too + -- frequent shutdown\/start of one host. Default is 5*60. + , hInputDirectory :: FilePath -- ^ Directory (on the host) for input files. Default is @"."@. + , hOutputDirectory :: FilePath -- ^ Directory (on the host) with output files. Default is @"."@. + , hScriptsDirectory :: Maybe FilePath -- ^ Directory (on the host) for temporary scripts. + , hStartupHostCommands :: [T.Text] + , hStartupDispatcherCommands :: [T.Text] + , hVariables :: Variables + , hControllerSpecific :: Maybe Aeson.Value + } + deriving (Eq, Show, Data, Typeable, Generic) + +instance FromJSON Host where + parseJSON (Object v) = do + name <- v .: "name" + host_name <- v .: "host_name" + controller_id <- v .:? "controller_id" .!= name + public_key <- v .:? "public_key" + private_key <- v .:? "private_key" + passphrase <- v .:? "passphrase" .!= "" + user_name <- v .: "user_name" + port <- v .:? "port" .!= 22 + max_jobs <- v .:? "max_jobs" + controller <- v .:? "controller" .!= "local" + startup_time <- v .:? "startup_time" .!= 5 + shutdown_timeout <- v .:? "shutdown_timeout" .!= (5*60) + input_directory <- v .:? "input_directory" .!= "." + output_directory <- v .:? "output_directory" .!= "." + scripts_directory <- v .:? "scripts_directory" + startup_host_commands <- v .:? "startup_commands_on_host" .!= [] + startup_dispatcher_commands <- v .:? "startup_commands_on_dispatcher" .!= [] + variables <- v .:? "variables" .!= M.empty + specific <- v .:? controller + return $ Host { + hName = name + , hHostName = host_name + , hControllerId = controller_id + , hPublicKey = public_key + , hPrivateKey = private_key + , hPassphrase = passphrase + , hUserName = user_name + , hPort = port + , hMaxJobs = max_jobs + , hController = controller + , hStartupTime = startup_time + , hShutdownTimeout = shutdown_timeout + , hInputDirectory = input_directory + , hOutputDirectory = output_directory + , hScriptsDirectory = scripts_directory + , hStartupHostCommands = startup_host_commands + , hStartupDispatcherCommands = startup_dispatcher_commands + , hVariables = variables + , hControllerSpecific = specific + } + parseJSON invalid = typeMismatch "host definition" invalid + +-- | EVENT logging level +event_level :: Level +event_level = Level "EVENT" 350 Syslog.Info + +-- | VERBOSE logging level +verbose_level :: Level +verbose_level = Level "VERBOSE" 450 Syslog.Info + +-- | CONFIG logging level +config_level :: Level +config_level = Level "CONFIG" 700 Syslog.Debug + +instance FromJSON Level where + parseJSON (Aeson.String "config") = return config_level + parseJSON (Aeson.String "debug") = return debug_level + parseJSON (Aeson.String "verbose") = return verbose_level + parseJSON (Aeson.String "info") = return info_level + parseJSON (Aeson.String "warning") = return warn_level + parseJSON (Aeson.String "error") = return error_level + parseJSON (Aeson.String "fatal") = return fatal_level + parseJSON (Aeson.String "disable") = return disable_logging + parseJSON invalid = typeMismatch "logging level" invalid + +instance ToJSON Level where + toJSON l = + case levelName l of + "CONFIG" -> Aeson.String "config" + "DEBUG" -> Aeson.String "debug" + "VERBOSE" -> Aeson.String "verbose" + "INFO" -> Aeson.String "info" + "WARN" -> Aeson.String "warning" + "ERROR" -> Aeson.String "error" + "FATAL" -> Aeson.String "fatal" + name -> Aeson.String name + +-- | Utility conversion function. This assumes 1-byte encoding. +bstrToString :: B.ByteString -> String +bstrToString bstr = map (chr . fromIntegral) $ B.unpack bstr + +-- | Utility conversion function. This assumes 1-byte encoding. +stringToBstr :: String -> B.ByteString +stringToBstr str = B.pack $ map (fromIntegral . ord) str + diff --git a/src/Batchd/Core/Daemon/Hosts.hs b/src/Batchd/Core/Daemon/Hosts.hs new file mode 100644 --- /dev/null +++ b/src/Batchd/Core/Daemon/Hosts.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TemplateHaskell #-} +-- | This module contains generic definitions about remote hosts. +module Batchd.Core.Daemon.Hosts + ( -- * Host-related data types + HostStatus (..), + HostState (..), + HostName, + HostsPool, + -- * Host controllers + -- $drivers + HostController (..), + HostDriver (..), + controllerFromConfig, + -- * Local hosts driver + localDriver + ) where + +import Control.Concurrent +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Time +import Data.Aeson as Aeson +import System.Log.Heavy + +import Batchd.Core.Common.Types + +-- | Host status +data HostStatus = + Free -- ^ Does not have any jobs, free for use + | Active -- ^ Has some jobs, but can accept one more. + | Busy -- ^ Has maximum allowed count of jobs. To give it a job, one has to wait for Active or Released status. + | Released -- ^ Has no jobs. Waiting to be stopped or for a new job. + deriving (Eq, Show) + +-- | Host state +data HostState = HostState { + hsStatus :: HostStatus + , hsReleaseTime :: Maybe UTCTime -- ^ Time of last transition to Released state + , hsJobCount :: Int -- ^ Count of jobs currently executed by the host + , hsHostConfig :: Host + } + deriving (Show) + +-- | Host name +type HostName = T.Text + +-- | Pool of used hosts and their states. +type HostsPool = MVar (M.Map HostName (MVar HostState)) + +-- $drivers +-- +-- Host driver is a programmatic component (technically, an instance of +-- @HostDriver@ data type), which contains an implementation of +-- host-controlling functions. I.e., this component knows how to start and +-- stop hosts of certain type. +-- +-- Host controller is a configuration object, which refers to host driver which should +-- be actuall driving the hosts. Moreover, the host controller contains specific settings +-- used by the driver. There can exist many host controllers, using the same driver, but +-- with different settings. +-- +-- Programmatically, batchd always deals with @HostController@, which is built from +-- configuration file by @HostDriver@. +-- + +-- | Host controller. Implementation of all functions is actually +-- located in host driver definition. These functions are already +-- aware of all settings in the host controller config file. +data HostController = HostController { + -- | Name of host driver + controllerDriverName :: String, + + -- | Does this controller support starting and stopping hosts? + doesSupportStartStop :: Bool, + + -- | Try to obtain actual network hostname for the host. + -- May be useful if VMs can change their IPs at each startup. + getActualHostName :: HostName -> IO (Maybe HostName), + + -- | Start the host. Should not return error if the + -- host is already started. + startHost :: Host -> IO (Either Error ()), + + -- | Shutdown the host. Should wait until the host is + -- actually shut down. + stopHost :: HostName -> IO (Either Error ()) + } + +instance Show HostController where + show c = controllerDriverName c + +-- | Host driver definition data type +data HostDriver = HostDriver { + -- | Get name of the driver + driverName :: String + + -- | Initialize host controllers from configuration file. + -- This actually `plugs' knowledge of configuration into + -- instance of @HostController@. + , initController :: LoggingTState + -> Value -- Configuration file contents + -> Either Error HostController + } + +-- | Utility function to construct host controller from configuration file. +controllerFromConfig :: FromJSON settings + => String -- ^ Driver name + -> (settings -> LoggingTState -> HostController) -- ^ How to create controller from settings + -> HostDriver +controllerFromConfig name maker = + let init lts config = + case fromJSON config of + Aeson.Error err -> Left $ UnknownError err + Aeson.Success settings -> Right $ maker settings lts + in HostDriver name init + +-- | Local hosts driver +localDriver :: HostDriver +localDriver = HostDriver "local" $ \_ _ -> Right local + +-- | Local hosts controller +local :: HostController +local = HostController { + controllerDriverName = driverName localDriver, + + doesSupportStartStop = False, + + getActualHostName = \_ -> return Nothing, + + startHost = \_ -> return $ Right (), + stopHost = \_ -> return $ Right () + } + diff --git a/src/Batchd/Core/Daemon/Logging.hs b/src/Batchd/Core/Daemon/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Batchd/Core/Daemon/Logging.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies, OverloadedStrings #-} +-- | This module contains utilities for logging, used by batchd daemon. +-- This also reexports required modules from @heavy-logger@ package. +module Batchd.Core.Daemon.Logging + ( + translateString, + logIO, debugIO, infoIO, reportErrorIO, + -- * Reexports + module System.Log.Heavy.Types, + module System.Log.Heavy.Level, + module System.Log.Heavy.Util, + module System.Log.Heavy.TH, + module System.Log.Heavy.Backends + ) where + +import Control.Monad (when) +import qualified Control.Monad.Trans as Trans +import Control.Monad.Trans (MonadIO) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Format.Heavy as F +import Language.Haskell.TH hiding (reportError) +import System.Log.Heavy +import System.Log.Heavy.Types +import System.Log.Heavy.Level +import System.Log.Heavy.Util +import System.Log.Heavy.TH +import System.Log.Heavy.Backends +import Text.Localize (translate, Localized) + +import Batchd.Core.Common.Types + +-- | Variant of @translate@, which takes String argument. +translateString :: Localized m => String -> m TL.Text +translateString str = translate $ stringToBstr str + +-- | Write a message to log within IO monad. +logIO :: (F.ClosedVarContainer vars, MonadIO m) => LoggingTState -> Loc -> Level -> TL.Text -> vars -> m () +logIO lts loc level msg vars = Trans.liftIO $ + do + let src = splitDots (loc_module loc) + let message = LogMessage level src loc msg vars [] + when (checkContextFilter (ltsContext lts) message) $ do + ltsLogger lts message + +-- | Write a debug message to log within IO monad. +debugIO :: (F.ClosedVarContainer vars, MonadIO m) + => LoggingTState -- ^ Logging state + -> Loc -- ^ Message location in Haskell source. Usually filled by @\$(here)@ TH macros. + -> TL.Text -- ^ Message string, with placeholders if needed. + -> vars -- ^ Message variables. Use @()@ if you do not have variables. + -> m () +debugIO lts loc = logIO lts loc debug_level + +-- | Write an info message to log within IO monad. +infoIO :: (F.ClosedVarContainer vars, MonadIO m) + => LoggingTState -- ^ Logging state + -> Loc -- ^ Message location in Haskell source. Usually filled by @\$(here)@ TH macros. + -> TL.Text -- ^ Message string, with placeholders if needed. + -> vars -- ^ Message variables. Use @()@ if you do not have variables. + -> m () +infoIO lts loc = logIO lts loc info_level + +-- | Write an error message to log within IO monad. +reportErrorIO :: (F.ClosedVarContainer vars, MonadIO m) + => LoggingTState -- ^ Logging state + -> Loc -- ^ Message location in Haskell source. Usually filled by @\$(here)@ TH macros. + -> TL.Text -- ^ Message string, with placeholders if needed. + -> vars -- ^ Message variables. Use @()@ if you do not have variables. + -> m () +reportErrorIO lts loc = logIO lts loc error_level +