packages feed

batchd-core (empty) → 0.1.0.0

raw patch · 10 files changed

+610/−0 lines, 10 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, containers, dates, directory, filepath, heavy-logger, hsyslog, localize, mtl, persistent, persistent-template, resourcet, scotty, syb, template-haskell, text, text-format-heavy, th-lift, time, unordered-containers, wai, yaml

Files

+ 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,5 @@+batchd-core README+==================++This package exports core definition of batchd package, which are used by batchd extension packages.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ batchd-core.cabal view
@@ -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
+ src/Batchd/Core.hs view
@@ -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+
+ src/Batchd/Core/Common/Config.hs view
@@ -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+
+ src/Batchd/Core/Common/Localize.hs view
@@ -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)+
+ src/Batchd/Core/Common/Types.hs view
@@ -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+
+ src/Batchd/Core/Daemon/Hosts.hs view
@@ -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 ()+  }+
+ src/Batchd/Core/Daemon/Logging.hs view
@@ -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+