{-# 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 {
    DockerSettings -> Bool
dEnableStartStop :: Bool       -- ^ Automatic start\/stop of containers can be disabled in config file
  , DockerSettings -> Maybe String
dUnixSocket :: Maybe FilePath  -- ^ This should be usually specified for default docker installation on local host
  , DockerSettings -> URL
dBaseUrl :: URL                -- ^ Docker API URL
  }
  deriving (Int -> DockerSettings -> ShowS
[DockerSettings] -> ShowS
DockerSettings -> String
(Int -> DockerSettings -> ShowS)
-> (DockerSettings -> String)
-> ([DockerSettings] -> ShowS)
-> Show DockerSettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DockerSettings] -> ShowS
$cshowList :: [DockerSettings] -> ShowS
show :: DockerSettings -> String
$cshow :: DockerSettings -> String
showsPrec :: Int -> DockerSettings -> ShowS
$cshowsPrec :: Int -> DockerSettings -> ShowS
Show)

instance FromJSON DockerSettings where
  parseJSON :: Value -> Parser DockerSettings
parseJSON (Object Object
v) = do
    URL
driver <- Object
v Object -> URL -> Parser URL
forall a. FromJSON a => Object -> URL -> Parser a
.: URL
"driver"
    Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (URL
driver URL -> URL -> Bool
forall a. Eq a => a -> a -> Bool
/= (URL
"docker" :: T.Text)) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$
      String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ()) -> String -> Parser ()
forall a b. (a -> b) -> a -> b
$ String
"incorrect driver specification"
    Bool
enable <- Object
v Object -> URL -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> URL -> Parser (Maybe a)
.:? URL
"enable_start_stop" Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
True
    Maybe String
socket <- Object
v Object -> URL -> Parser (Maybe String)
forall a. FromJSON a => Object -> URL -> Parser (Maybe a)
.:? URL
"unix_socket"
    URL
url <- Object
v Object -> URL -> Parser (Maybe URL)
forall a. FromJSON a => Object -> URL -> Parser (Maybe a)
.:? URL
"base_url" Parser (Maybe URL) -> URL -> Parser URL
forall a. Parser (Maybe a) -> a -> Parser a
.!= URL
defaultDockerUrl
    DockerSettings -> Parser DockerSettings
forall (m :: * -> *) a. Monad m => a -> m a
return (DockerSettings -> Parser DockerSettings)
-> DockerSettings -> Parser DockerSettings
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe String -> URL -> DockerSettings
DockerSettings Bool
enable Maybe String
socket URL
url

-- | Default Docker API URL.
defaultDockerUrl :: URL
defaultDockerUrl :: URL
defaultDockerUrl = DockerClientOpts -> URL
baseUrl DockerClientOpts
defaultClientOpts

getHttpHandler :: (MonadIO m, MonadMask m, MonadUnliftIO m) => DockerSettings -> m (HttpHandler m)
getHttpHandler :: DockerSettings -> m (HttpHandler m)
getHttpHandler DockerSettings
d = do
  case DockerSettings -> Maybe String
dUnixSocket DockerSettings
d of
    Maybe String
Nothing -> m (HttpHandler m)
forall (m :: * -> *).
(MonadUnliftIO m, MonadIO m, MonadMask m) =>
m (HttpHandler m)
defaultHttpHandler
    Just String
path -> String -> m (HttpHandler m)
forall (m :: * -> *).
(MonadUnliftIO m, MonadIO m, MonadMask m) =>
String -> m (HttpHandler m)
unixHttpHandler String
path

-- | Initialize Docker host controller
dockerDriver :: HostDriver
dockerDriver :: HostDriver
dockerDriver =
  String
-> (DockerSettings -> LoggingTState -> HostController)
-> HostDriver
forall settings.
FromJSON settings =>
String
-> (settings -> LoggingTState -> HostController) -> HostDriver
controllerFromConfig String
"docker" ((DockerSettings -> LoggingTState -> HostController) -> HostDriver)
-> (DockerSettings -> LoggingTState -> HostController)
-> HostDriver
forall a b. (a -> b) -> a -> b
$ \DockerSettings
d LoggingTState
lts -> HostController :: String
-> Bool
-> (URL -> IO (Maybe URL))
-> (Host -> IO (Either Error ()))
-> (URL -> IO (Either Error ()))
-> HostController
HostController {

    controllerDriverName :: String
controllerDriverName = HostDriver -> String
driverName HostDriver
dockerDriver,

    getActualHostName :: URL -> IO (Maybe URL)
getActualHostName = \URL
_ -> Maybe URL -> IO (Maybe URL)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe URL
forall a. Maybe a
Nothing,

    doesSupportStartStop :: Bool
doesSupportStartStop = DockerSettings -> Bool
dEnableStartStop DockerSettings
d,

    startHost :: Host -> IO (Either Error ())
startHost = \Host
host -> do
      HttpHandler IO
handler <- DockerSettings -> IO (HttpHandler IO)
forall (m :: * -> *).
(MonadIO m, MonadMask m, MonadUnliftIO m) =>
DockerSettings -> m (HttpHandler m)
getHttpHandler DockerSettings
d
      let opts :: DockerClientOpts
opts = DockerClientOpts
defaultClientOpts {baseUrl :: URL
baseUrl = DockerSettings -> URL
dBaseUrl DockerSettings
d}
      Either DockerError ()
r <- (DockerClientOpts, HttpHandler IO)
-> DockerT IO (Either DockerError ()) -> IO (Either DockerError ())
forall (m :: * -> *) a.
Monad m =>
(DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
runDockerT (DockerClientOpts
opts, HttpHandler IO
handler) (DockerT IO (Either DockerError ()) -> IO (Either DockerError ()))
-> DockerT IO (Either DockerError ()) -> IO (Either DockerError ())
forall a b. (a -> b) -> a -> b
$ do
             StartOpts -> ContainerID -> DockerT IO (Either DockerError ())
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
StartOpts -> ContainerID -> DockerT m (Either DockerError ())
startContainer StartOpts
defaultStartOpts (ContainerID -> DockerT IO (Either DockerError ()))
-> ContainerID -> DockerT IO (Either DockerError ())
forall a b. (a -> b) -> a -> b
$ Maybe ContainerID -> ContainerID
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ContainerID -> ContainerID)
-> Maybe ContainerID -> ContainerID
forall a b. (a -> b) -> a -> b
$ URL -> Maybe ContainerID
toContainerID (URL -> Maybe ContainerID) -> URL -> Maybe ContainerID
forall a b. (a -> b) -> a -> b
$ Host -> URL
hControllerId Host
host
      case Either DockerError ()
r of
        Right ()
_ -> Either Error () -> IO (Either Error ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error () -> IO (Either Error ()))
-> Either Error () -> IO (Either Error ())
forall a b. (a -> b) -> a -> b
$ () -> Either Error ()
forall a b. b -> Either a b
Right ()
        Left DockerError
err -> Either Error () -> IO (Either Error ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error () -> IO (Either Error ()))
-> Either Error () -> IO (Either Error ())
forall a b. (a -> b) -> a -> b
$ Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ()) -> Error -> Either Error ()
forall a b. (a -> b) -> a -> b
$ String -> Error
UnknownError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$ DockerError -> String
forall a. Show a => a -> String
show DockerError
err,

    stopHost :: URL -> IO (Either Error ())
stopHost = \URL
name -> do
      HttpHandler IO
handler <- DockerSettings -> IO (HttpHandler IO)
forall (m :: * -> *).
(MonadIO m, MonadMask m, MonadUnliftIO m) =>
DockerSettings -> m (HttpHandler m)
getHttpHandler DockerSettings
d
      let opts :: DockerClientOpts
opts = DockerClientOpts
defaultClientOpts {baseUrl :: URL
baseUrl = DockerSettings -> URL
dBaseUrl DockerSettings
d}
      Either DockerError ()
r <- (DockerClientOpts, HttpHandler IO)
-> DockerT IO (Either DockerError ()) -> IO (Either DockerError ())
forall (m :: * -> *) a.
Monad m =>
(DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
runDockerT (DockerClientOpts
opts, HttpHandler IO
handler) (DockerT IO (Either DockerError ()) -> IO (Either DockerError ()))
-> DockerT IO (Either DockerError ()) -> IO (Either DockerError ())
forall a b. (a -> b) -> a -> b
$ do
             Timeout -> ContainerID -> DockerT IO (Either DockerError ())
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
Timeout -> ContainerID -> DockerT m (Either DockerError ())
stopContainer Timeout
DefaultTimeout (ContainerID -> DockerT IO (Either DockerError ()))
-> ContainerID -> DockerT IO (Either DockerError ())
forall a b. (a -> b) -> a -> b
$ Maybe ContainerID -> ContainerID
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ContainerID -> ContainerID)
-> Maybe ContainerID -> ContainerID
forall a b. (a -> b) -> a -> b
$ URL -> Maybe ContainerID
toContainerID URL
name
      case Either DockerError ()
r of
        Right ()
_ -> Either Error () -> IO (Either Error ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error () -> IO (Either Error ()))
-> Either Error () -> IO (Either Error ())
forall a b. (a -> b) -> a -> b
$ () -> Either Error ()
forall a b. b -> Either a b
Right ()
        Left DockerError
err -> Either Error () -> IO (Either Error ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error () -> IO (Either Error ()))
-> Either Error () -> IO (Either Error ())
forall a b. (a -> b) -> a -> b
$ Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ()) -> Error -> Either Error ()
forall a b. (a -> b) -> a -> b
$ String -> Error
UnknownError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$ DockerError -> String
forall a. Show a => a -> String
show DockerError
err
  }