batchd-docker (empty) → 0.1.0.0

raw patch · 5 files changed

+152/−0 lines, 5 filesdep +aesondep +basedep +batchd-coresetup-changed

Dependencies added: aeson, base, batchd-core, docker, exceptions, mtl, text, unliftio-core

Files

• LICENSE +30/−0
• README.md +4/−0
• Setup.hs +2/−0
• batchd-docker.cabal +31/−0
• src/Batchd/Ext/Docker.hs +85/−0

@@ -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.

@@ -0,0 +1,4 @@+batchd-docker README+====================++This is an adapter package, which allows `batchd` to work with docker containers.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,31 @@+name:                batchd-docker+version:             0.1.0.0+synopsis:            docker containers host controller for batchd+-- description:+homepage:            https://github.com/portnov/batchd/batchd-docker#readme+license:             BSD3+license-file:        LICENSE+author:              Ilya Portnov+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.Docker+  build-depends:       base >= 4.7 && < 5,+                       mtl >= 2.2,+                       unliftio-core >= 0.1.2.0,+                       exceptions >= 0.8.3,+                       text >= 1.2.2.2,+                       aeson >= 1.1.2.0,+                       batchd-core >= 0.1.0.0,+                       docker >= 0.6.0.0+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/portnov/batchd/

@@ -0,0 +1,85 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+-- | This module contains an implementation of batchd host controllers,+-- which controls docker containers.+module Batchd.Ext.Docker+  (DockerSettings (..),+   dockerDriver,+   defaultDockerUrl+  ) where++import Control.Monad (when)+import Control.Monad.Trans+import Control.Monad.Catch+import Control.Monad.IO.Unlift+import Control.Exception+import Data.Maybe+import Data.Typeable+import qualified Data.Text as T+import Data.Aeson+import Batchd.Core+import Docker.Client++deriving instance Typeable DockerError+instance Exception DockerError++-- | Settings of Docker host controller+data DockerSettings = DockerSettings {+    dEnableStartStop :: Bool       -- ^ Automatic start\/stop of containers can be disabled in config file+  , dUnixSocket :: Maybe FilePath  -- ^ This should be usually specified for default docker installation on local host+  , dBaseUrl :: URL                -- ^ Docker API URL+  }+  deriving (Show)++instance FromJSON DockerSettings where+  parseJSON (Object v) = do+    driver <- v .: "driver"+    when (driver /= ("docker" :: T.Text)) $+      fail $ "incorrect driver specification"+    enable <- v .:? "enable_start_stop" .!= True+    socket <- v .:? "unix_socket"+    url <- v .:? "base_url" .!= defaultDockerUrl+    return $ DockerSettings enable socket url++-- | Default Docker API URL.+defaultDockerUrl :: URL+defaultDockerUrl = baseUrl defaultClientOpts++getHttpHandler :: (MonadIO m, MonadMask m, MonadUnliftIO m) => DockerSettings -> m (HttpHandler m)+getHttpHandler d = do+  case dUnixSocket d of+    Nothing -> defaultHttpHandler+    Just path -> unixHttpHandler path++-- | Initialize Docker host controller+dockerDriver :: HostDriver+dockerDriver =+  controllerFromConfig "docker" $ \d lts -> HostController {++    controllerDriverName = driverName dockerDriver,++    getActualHostName = \_ -> return Nothing,++    doesSupportStartStop = dEnableStartStop d,++    startHost = \host -> do+      handler <- getHttpHandler d+      let opts = defaultClientOpts {baseUrl = dBaseUrl d}+      r <- runDockerT (opts, handler) $ do+             startContainer defaultStartOpts $ fromJust $ toContainerID $ hControllerId host+      case r of+        Right _ -> return $ Right ()+        Left err -> return $ Left $ UnknownError $ show err,++    stopHost = \name -> do+      handler <- getHttpHandler d+      let opts = defaultClientOpts {baseUrl = dBaseUrl d}+      r <- runDockerT (opts, handler) $ do+             stopContainer DefaultTimeout $ fromJust $ toContainerID name+      case r of+        Right _ -> return $ Right ()+        Left err -> return $ Left $ UnknownError $ show err+  }+