Migrating horde types

horde-types-migartion.hs

-- | Horde data types. These data types are serializable using the `safecopy`
-- package. Serialization/deserialization should be done with the `safeEncode`
-- and `safeDecode` functions.
--
-- Using `safecopy`, we can change these data types and migrate already
-- serialized data structures. To do so, we change the
-- `deriveSafeCopy 1 'extension` (and
-- `deriveSafeCopy 0 'base`) to `deriveSafeCopy 2 'extension` (and to
-- `deriveSafeCopy 1 'extension`) and provide migrations.
--
-- See the first migration below for an example.

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} -- For instance Migrate.
module System.Docker.Horde.Types where

import Data.ByteString (ByteString)
import Data.Data (Data, Typeable)
import Data.SafeCopy
import Data.Serialize
import GHC.Generics (Generic)

type Hostname = String

-- | A service describes a particular invokation of a Docker image.
data Service = Service
  { serviceImage :: String
  , serviceCommand :: [String]
  , serviceName :: String
  -- ^ How the service must be registered in SkyDNS.
  , serviceBindHordeDirectory :: Bool
  -- ^ Bind the horde directory to /HORDE within the container ?
  , serviceBindDNS :: Bool
  -- ^ Pass the SkyDNS IP to the container ?
  , serviceBindDirectories :: [(String, String)]
  -- ^ Directories to share with the host.
  , serviceHost :: Hostname
  -- ^ Where the service must be run.
  , servicePrivileged :: Bool
  -- ^ Whether the service must be run with "--privileged".
  , serviceExposedPorts :: [Int]
  -- ^ Expose container ports on the host. This is a temporary measure
  -- to expose the HAProxy to the outside world directly. Normally
  -- it should be a host-level (i.e. unique) container.
  }
  deriving (Show, Generic, Data, Typeable)

instance Serialize Service

deriveSafeCopy 1 'extension ''Service

defaultService :: Service
defaultService = Service
  { serviceImage = "base"
  , serviceCommand = []
  , serviceName = "base"
  , serviceBindHordeDirectory = False
  , serviceBindDNS = False
  , serviceBindDirectories = []
  , serviceHost = "host-0"
  , servicePrivileged = False
  , serviceExposedPorts = []
  }

-- | Registering services into SkyDNS or dnsmasq is done differently, so we
-- to distinguish them.
data NameServiceType = NameServiceSkyDNS | NameServiceDnsmasq
  deriving (Show, Generic, Data, Typeable)

instance Serialize NameServiceType

deriveSafeCopy 0 'base ''NameServiceType

data Host =
    Here
  | Host String String Int
  -- ^ SSH username@hostname port, ssh-agent should provide the private key.
  deriving (Show, Generic, Data, Typeable)

instance Serialize Host

deriveSafeCopy 0 'base ''Host

-- | A container describes a running Docker image.
data Container = Container
  { containerId :: String
  , containerIp :: String
  , containerService :: Service
  -- ^ Describe the container (e.g. the host where it runs).
  }
  deriving (Show, Generic)

instance Serialize Container

deriveSafeCopy 1 'extension ''Container

-- | A horde describes a set of containers.
data Horde = Horde
  { hordeName :: String
  , hordeDomain :: String
  , hordeNameServiceType :: NameServiceType
  , hordeServices :: [Service]
  , hordeContainers :: [Container]
  , hordeCounter :: Int
  -- ^ Used to name containers uniquely.
  }
  deriving (Show, Generic)

instance Serialize Horde

deriveSafeCopy 1 'extension ''Horde

safeCoerce :: (SafeCopy a, SafeCopy b) => a -> Either String b
safeCoerce = safeDecode . safeEncode

-- | Same as cereal's encode, but using SafeCopy.
safeEncode :: SafeCopy a => a -> ByteString
safeEncode = runPut . safePut

-- | Same as cereal's decode, but using SafeCopy.
safeDecode :: SafeCopy a => ByteString -> Either String a
safeDecode = runGet safeGet

(~>) :: Service -> Hostname -> Service
sv ~> h = sv { serviceHost = h }

----------------------------------------------------------------------
-- Migration v0 -> v1 (current).
--
-- This adds the `serviceExposedPorts` attribute to the `Service` data type.
-- We duplicate the previous data types (`Service`, but also enclosing ones)
-- with the suffix_v0, and write the migration. It is just copying
-- corresponding fields, adding a default value for `serviceExposedPorts`.
--
-- To confirm it works, `safeCoerce horde_v0 :: Either String Horde`
-- must be equal to (Right (Horde ...)).
----------------------------------------------------------------------

data Service_v0 = Service_v0
  { serviceImage_v0 :: String
  , serviceCommand_v0 :: [String]
  , serviceName_v0 :: String
  -- ^ How the service must be registered in SkyDNS.
  , serviceBindHordeDirectory_v0 :: Bool
  -- ^ Bind the horde directory to /HORDE within the container ?
  , serviceBindDNS_v0 :: Bool
  -- ^ Pass the SkyDNS IP to the container ?
  , serviceBindDirectories_v0 :: [(String, String)]
  -- ^ Directories to share with the host.
  , serviceHost_v0 :: Hostname
  -- ^ Where the service must be run.
  , servicePrivileged_v0 :: Bool
  -- ^ Whether the service must be run with "--privileged".
  }
  deriving (Show, Generic, Data, Typeable)

instance Serialize Service_v0

deriveSafeCopy 0 'base ''Service_v0

instance Migrate Service where
  type MigrateFrom Service = Service_v0
  migrate Service_v0{..} = Service
    { serviceImage = serviceImage_v0
    , serviceCommand = serviceCommand_v0
    , serviceName = serviceName_v0
    , serviceBindHordeDirectory = serviceBindHordeDirectory_v0
    , serviceBindDNS = serviceBindDNS_v0
    , serviceBindDirectories = serviceBindDirectories_v0
    , serviceHost = serviceHost_v0
    , servicePrivileged = servicePrivileged_v0
    , serviceExposedPorts = []
    }

data Container_v0 = Container_v0
  { containerId_v0 :: String
  , containerIp_v0 :: String
  , containerService_v0 :: Service_v0
  -- ^ Describe the container (e.g. the host where it runs).
  }
  deriving (Show, Generic)

instance Serialize Container_v0

deriveSafeCopy 0 'base ''Container_v0

instance Migrate Container where
  type MigrateFrom Container = Container_v0
  migrate Container_v0{..} = Container
    { containerId = containerId_v0
    , containerIp = containerIp_v0
    , containerService = migrate containerService_v0
    }

-- | A horde describes a set of containers.
data Horde_v0 = Horde_v0
  { hordeName_v0 :: String
  , hordeDomain_v0 :: String
  , hordeNameServiceType_v0 :: NameServiceType
  , hordeServices_v0 :: [Service_v0]
  , hordeContainers_v0 :: [Container_v0]
  , hordeCounter_v0 :: Int
  -- ^ Used to name containers uniquely.
  }
  deriving (Show, Generic)

instance Serialize Horde_v0

deriveSafeCopy 0 'base ''Horde_v0

instance Migrate Horde where
  type MigrateFrom Horde = Horde_v0
  migrate Horde_v0{..} = Horde
    { hordeName = hordeName_v0
    , hordeDomain = hordeDomain_v0
    , hordeNameServiceType = hordeNameServiceType_v0
    , hordeServices = map migrate hordeServices_v0
    , hordeContainers = map migrate hordeContainers_v0
    , hordeCounter = hordeCounter_v0
    }

defaultService_v0 :: Service_v0
defaultService_v0 = Service_v0
  { serviceImage_v0 = "base"
  , serviceCommand_v0 = []
  , serviceName_v0 = "base"
  , serviceBindHordeDirectory_v0 = False
  , serviceBindDNS_v0 = False
  , serviceBindDirectories_v0 = []
  , serviceHost_v0 = "host-0"
  , servicePrivileged_v0 = False
  }

horde_v0 :: Horde_v0
horde_v0 = Horde_v0 "horde-v0" "local.domain" NameServiceDnsmasq [defaultService_v0] [] 0