Merge branch 'stable-2.13' into stable-2.14
authorHrvoje Ribicic <riba@google.com>
Thu, 3 Dec 2015 22:55:20 +0000 (22:55 +0000)
committerHrvoje Ribicic <riba@google.com>
Fri, 4 Dec 2015 14:55:45 +0000 (14:55 +0000)
* stable-2.13
  (no changes)

* stable-2.12
  Restrict showing of DRBD secret using types
  Calculate correct affected nodes set in InstanceChangeGroup

* stable-2.11
  (no changes)

* stable-2.10
  (no changes)

* stable-2.9
  QA: Ensure the DRBD secret is not retrievable via RAPI
  Redact the DRBD secret in instance queries
  Do not attempt to use the DRBD secret in gnt-instance info

Conflicts:
  src/Ganeti/Objects.hs - Followed code to Disk.hs
  test/hs/Test/Ganeti/Objects.hs - Added Private to disk definition

Signed-off-by: Hrvoje Ribicic <riba@google.com>
Reviewed-by: Helga Velroyen <helgav@google.com>

1  2 
lib/client/gnt_instance.py
lib/cmdlib/instance.py
lib/cmdlib/instance_query.py
lib/objects.py
lib/storage/drbd.py
qa/ganeti-qa.py
src/Ganeti/Config.hs
src/Ganeti/Objects.hs
src/Ganeti/Objects/Disk.hs
test/hs/Test/Ganeti/Objects.hs

Simple merge
Simple merge
Simple merge
diff --cc lib/objects.py
Simple merge
Simple merge
diff --cc qa/ganeti-qa.py
Simple merge
Simple merge
@@@ -292,7 -348,293 +292,6 @@@ instance Monoid DataCollectorConfig whe
      }
    mappend _ a = a
  
 --- * Disk definitions
 -
 --- | Constant for the dev_type key entry in the disk config.
 -devType :: String
 -devType = "dev_type"
 -
 --- | The disk parameters type.
 -type DiskParams = Container JSValue
 -
 --- | An alias for DRBD secrets
 -type DRBDSecret = String
 -
 --- Represents a group name and a volume name.
 ---
 --- From @man lvm@:
 ---
 --- The following characters are valid for VG and LV names: a-z A-Z 0-9 + _ . -
 ---
 --- VG  and LV names cannot begin with a hyphen.  There are also various reserved
 --- names that are used internally by lvm that can not be used as LV or VG names.
 --- A VG cannot be  called  anything  that exists in /dev/ at the time of
 --- creation, nor can it be called '.' or '..'.  A LV cannot be called '.' '..'
 --- 'snapshot' or 'pvmove'. The LV name may also not contain the strings '_mlog'
 --- or '_mimage'
 -data LogicalVolume = LogicalVolume { lvGroup :: String
 -                                   , lvVolume :: String
 -                                   }
 -  deriving (Eq, Ord)
 -
 -instance Show LogicalVolume where
 -  showsPrec _ (LogicalVolume g v) =
 -    showString g . showString "/" . showString v
 -
 --- | Check the constraints for a VG/LV names (except the @\/dev\/@ check).
 -instance Validatable LogicalVolume where
 -  validate (LogicalVolume g v) = do
 -      let vgn = "Volume group name"
 -      -- Group name checks
 -      nonEmpty vgn g
 -      validChars vgn g
 -      notStartsDash vgn g
 -      notIn vgn g [".", ".."]
 -      -- Volume name checks
 -      let lvn = "Volume name"
 -      nonEmpty lvn v
 -      validChars lvn v
 -      notStartsDash lvn v
 -      notIn lvn v [".", "..", "snapshot", "pvmove"]
 -      reportIf ("_mlog" `isInfixOf` v) $ lvn ++ " must not contain '_mlog'."
 -      reportIf ("_mimage" `isInfixOf` v) $ lvn ++ "must not contain '_mimage'."
 -    where
 -      nonEmpty prefix x = reportIf (null x) $ prefix ++ " must be non-empty"
 -      notIn prefix x =
 -        mapM_ (\y -> reportIf (x == y)
 -                              $ prefix ++ " must not be '" ++ y ++ "'")
 -      notStartsDash prefix x = reportIf ("-" `isPrefixOf` x)
 -                                 $ prefix ++ " must not start with '-'"
 -      validChars prefix x =
 -        reportIf (not . all validChar $ x)
 -                 $ prefix ++ " must consist only of [a-z][A-Z][0-9][+_.-]"
 -      validChar c = isAsciiLower c || isAsciiUpper c || isDigit c
 -                    || (c `elem` "+_.-")
 -
 -instance J.JSON LogicalVolume where
 -  showJSON = J.showJSON . show
 -  readJSON (J.JSString s) | (g, _ : l) <- break (== '/') (J.fromJSString s) =
 -    either fail return . evalValidate . validate' $ LogicalVolume g l
 -  readJSON v = fail $ "Invalid JSON value " ++ show v
 -                      ++ " for a logical volume"
 -
 --- | The disk configuration type. This includes the disk type itself,
 --- for a more complete consistency. Note that since in the Python
 --- code-base there's no authoritative place where we document the
 --- logical id, this is probably a good reference point.
 -data DiskLogicalId
 -  = LIDPlain LogicalVolume  -- ^ Volume group, logical volume
 -  | LIDDrbd8 String String Int Int Int (Private DRBDSecret)
 -  -- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
 -  | LIDFile FileDriver String -- ^ Driver, path
 -  | LIDSharedFile FileDriver String -- ^ Driver, path
 -  | LIDGluster FileDriver String -- ^ Driver, path
 -  | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
 -  | LIDRados String String -- ^ Unused, path
 -  | LIDExt String String -- ^ ExtProvider, unique name
 -    deriving (Show, Eq)
 -
 --- | Mapping from a logical id to a disk type.
 -lidDiskType :: DiskLogicalId -> DiskTemplate
 -lidDiskType (LIDPlain {}) = DTPlain
 -lidDiskType (LIDDrbd8 {}) = DTDrbd8
 -lidDiskType (LIDFile  {}) = DTFile
 -lidDiskType (LIDSharedFile  {}) = DTSharedFile
 -lidDiskType (LIDGluster  {}) = DTGluster
 -lidDiskType (LIDBlockDev {}) = DTBlock
 -lidDiskType (LIDRados {}) = DTRbd
 -lidDiskType (LIDExt {}) = DTExt
 -
 --- | Builds the extra disk_type field for a given logical id.
 -lidEncodeType :: DiskLogicalId -> [(String, JSValue)]
 -lidEncodeType v = [(devType, showJSON . lidDiskType $ v)]
 -
 --- | Custom encoder for DiskLogicalId (logical id only).
 -encodeDLId :: DiskLogicalId -> JSValue
 -encodeDLId (LIDPlain (LogicalVolume vg lv)) =
 -  JSArray [showJSON vg, showJSON lv]
 -encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB (Private key)) =
 -  JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
 -          , showJSON minorA, showJSON minorB, showJSON key ]
 -encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
 -encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
 -encodeDLId (LIDSharedFile driver name) =
 -  JSArray [showJSON driver, showJSON name]
 -encodeDLId (LIDGluster driver name) = JSArray [showJSON driver, showJSON name]
 -encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
 -encodeDLId (LIDExt extprovider name) =
 -  JSArray [showJSON extprovider, showJSON name]
 -
 --- | Custom encoder for DiskLogicalId, composing both the logical id
 --- and the extra disk_type field.
 -encodeFullDLId :: DiskLogicalId -> (JSValue, [(String, JSValue)])
 -encodeFullDLId v = (encodeDLId v, lidEncodeType v)
 -
 --- | Custom decoder for DiskLogicalId. This is manual for now, since
 --- we don't have yet automation for separate-key style fields.
 -decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
 -decodeDLId obj lid = do
 -  dtype <- fromObj obj devType
 -  case dtype of
 -    DTDrbd8 ->
 -      case lid of
 -        JSArray [nA, nB, p, mA, mB, k] -> do
 -          nA' <- readJSON nA
 -          nB' <- readJSON nB
 -          p'  <- readJSON p
 -          mA' <- readJSON mA
 -          mB' <- readJSON mB
 -          k'  <- readJSON k
 -          return . LIDDrbd8 nA' nB' p' mA' mB' $ Private k'
 -        _ -> fail "Can't read logical_id for DRBD8 type"
 -    DTPlain ->
 -      case lid of
 -        JSArray [vg, lv] -> do
 -          vg' <- readJSON vg
 -          lv' <- readJSON lv
 -          return $ LIDPlain (LogicalVolume vg' lv')
 -        _ -> fail "Can't read logical_id for plain type"
 -    DTFile ->
 -      case lid of
 -        JSArray [driver, path] -> do
 -          driver' <- readJSON driver
 -          path'   <- readJSON path
 -          return $ LIDFile driver' path'
 -        _ -> fail "Can't read logical_id for file type"
 -    DTSharedFile ->
 -      case lid of
 -        JSArray [driver, path] -> do
 -          driver' <- readJSON driver
 -          path'   <- readJSON path
 -          return $ LIDSharedFile driver' path'
 -        _ -> fail "Can't read logical_id for shared file type"
 -    DTGluster ->
 -      case lid of
 -        JSArray [driver, path] -> do
 -          driver' <- readJSON driver
 -          path'   <- readJSON path
 -          return $ LIDGluster driver' path'
 -        _ -> fail "Can't read logical_id for shared file type"
 -    DTBlock ->
 -      case lid of
 -        JSArray [driver, path] -> do
 -          driver' <- readJSON driver
 -          path'   <- readJSON path
 -          return $ LIDBlockDev driver' path'
 -        _ -> fail "Can't read logical_id for blockdev type"
 -    DTRbd ->
 -      case lid of
 -        JSArray [driver, path] -> do
 -          driver' <- readJSON driver
 -          path'   <- readJSON path
 -          return $ LIDRados driver' path'
 -        _ -> fail "Can't read logical_id for rdb type"
 -    DTExt ->
 -      case lid of
 -        JSArray [extprovider, name] -> do
 -          extprovider' <- readJSON extprovider
 -          name'   <- readJSON name
 -          return $ LIDExt extprovider' name'
 -        _ -> fail "Can't read logical_id for extstorage type"
 -    DTDiskless ->
 -      fail "Retrieved 'diskless' disk."
 -
 --- | Disk data structure.
 ---
 --- This is declared manually as it's a recursive structure, and our TH
 --- code currently can't build it.
 -data Disk = Disk
 -  { diskLogicalId  :: DiskLogicalId
 -  , diskChildren   :: [Disk]
 -  , diskIvName     :: String
 -  , diskSize       :: Int
 -  , diskMode       :: DiskMode
 -  , diskName       :: Maybe String
 -  , diskSpindles   :: Maybe Int
 -  , diskParams     :: Maybe DiskParams
 -  , diskUuid       :: String
 -  , diskSerial     :: Int
 -  , diskCtime      :: ClockTime
 -  , diskMtime      :: ClockTime
 -  } deriving (Show, Eq)
 -
 -$(buildObjectSerialisation "Disk" $
 -  [ customField 'decodeDLId 'encodeFullDLId ["dev_type"] $
 -      simpleField "logical_id"    [t| DiskLogicalId   |]
 -  , defaultField  [| [] |] $ simpleField "children" [t| [Disk] |]
 -  , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
 -  , simpleField "size" [t| Int |]
 -  , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
 -  , optionalField $ simpleField "name" [t| String |]
 -  , optionalField $ simpleField "spindles" [t| Int |]
 -  , optionalField $ simpleField "params" [t| DiskParams |]
 -  ]
 -  ++ uuidFields
 -  ++ serialFields
 -  ++ timeStampFields)
 -
 -instance UuidObject Disk where
 -  uuidOf = diskUuid
 -
 --- | Determines whether a disk or one of his children has the given logical id
 --- (determined by the volume group name and by the logical volume name).
 --- This can be true only for DRBD or LVM disks.
 -includesLogicalId :: LogicalVolume -> Disk -> Bool
 -includesLogicalId lv disk =
 -  case diskLogicalId disk of
 -    LIDPlain lv' -> lv' == lv
 -    LIDDrbd8 {} ->
 -      any (includesLogicalId lv) $ diskChildren disk
 -    _ -> False
 -
 --- * Instance definitions
 -
 -$(buildParam "Be" "bep"
 -  [ specialNumericalField 'parseUnitAssumeBinary
 -      $ simpleField "minmem"      [t| Int  |]
 -  , specialNumericalField 'parseUnitAssumeBinary
 -      $ simpleField "maxmem"      [t| Int  |]
 -  , simpleField "vcpus"           [t| Int  |]
 -  , simpleField "auto_balance"    [t| Bool |]
 -  , simpleField "always_failover" [t| Bool |]
 -  , simpleField "spindle_use"     [t| Int  |]
 -  ])
 -
 -$(buildObject "Instance" "inst" $
 -  [ simpleField "name"             [t| String             |]
 -  , simpleField "primary_node"     [t| String             |]
 -  , simpleField "os"               [t| String             |]
 -  , simpleField "hypervisor"       [t| Hypervisor         |]
 -  , simpleField "hvparams"         [t| HvParams           |]
 -  , simpleField "beparams"         [t| PartialBeParams    |]
 -  , simpleField "osparams"         [t| OsParams           |]
 -  , simpleField "osparams_private" [t| OsParamsPrivate    |]
 -  , simpleField "admin_state"      [t| AdminState         |]
 -  , simpleField "admin_state_source" [t| AdminStateSource   |]
 -  , simpleField "nics"             [t| [PartialNic]       |]
 -  , simpleField "disks"            [t| [String]           |]
 -  , simpleField "disk_template"    [t| DiskTemplate       |]
 -  , simpleField "disks_active"     [t| Bool               |]
 -  , optionalField $ simpleField "network_port" [t| Int  |]
 -  ]
 -  ++ timeStampFields
 -  ++ uuidFields
 -  ++ serialFields
 -  ++ tagsFields)
 -
 -instance TimeStampObject Instance where
 -  cTimeOf = instCtime
 -  mTimeOf = instMtime
 -
 -instance UuidObject Instance where
 -  uuidOf = instUuid
 -
 -instance SerialNoObject Instance where
 -  serialOf = instSerial
 -
 -instance TagsObject Instance where
 -  tagsOf = instTags
 -
  -- * IPolicy definitions
  
  $(buildParam "ISpec" "ispec"
index 4da84b0,0000000..181bf51
mode 100644,000000..100644
--- /dev/null
@@@ -1,274 -1,0 +1,274 @@@
 +{-# LANGUAGE TemplateHaskell, FunctionalDependencies #-}
 +
 +{-| Implementation of the Ganeti Disk config object.
 +
 +-}
 +
 +{-
 +
 +Copyright (C) 2014 Google Inc.
 +All rights reserved.
 +
 +Redistribution and use in source and binary forms, with or without
 +modification, are permitted provided that the following conditions are
 +met:
 +
 +1. Redistributions of source code must retain the above copyright notice,
 +this list of conditions and the following disclaimer.
 +
 +2. 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.
 +
 +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 HOLDER 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.
 +
 +-}
 +
 +module Ganeti.Objects.Disk where
 +
 +import Control.Applicative ((<*>), (<$>))
 +import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
 +import Data.List (isPrefixOf, isInfixOf)
 +import Language.Haskell.TH.Syntax
 +import Text.JSON (showJSON, readJSON, JSValue(..))
 +import qualified Text.JSON as J
 +
 +import Ganeti.JSON (Container, fromObj)
 +import Ganeti.THH
 +import Ganeti.THH.Field
 +import Ganeti.Types
 +import Ganeti.Utils.Validate
 +
 +-- | Constant for the dev_type key entry in the disk config.
 +devType :: String
 +devType = "dev_type"
 +
 +-- | The disk parameters type.
 +type DiskParams = Container JSValue
 +
 +-- | An alias for DRBD secrets
 +type DRBDSecret = String
 +
 +-- Represents a group name and a volume name.
 +--
 +-- From @man lvm@:
 +--
 +-- The following characters are valid for VG and LV names: a-z A-Z 0-9 + _ . -
 +--
 +-- VG  and LV names cannot begin with a hyphen.  There are also various reserved
 +-- names that are used internally by lvm that can not be used as LV or VG names.
 +-- A VG cannot be  called  anything  that exists in /dev/ at the time of
 +-- creation, nor can it be called '.' or '..'.  A LV cannot be called '.' '..'
 +-- 'snapshot' or 'pvmove'. The LV name may also not contain the strings '_mlog'
 +-- or '_mimage'
 +data LogicalVolume = LogicalVolume { lvGroup :: String
 +                                   , lvVolume :: String
 +                                   }
 +  deriving (Eq, Ord)
 +
 +instance Show LogicalVolume where
 +  showsPrec _ (LogicalVolume g v) =
 +    showString g . showString "/" . showString v
 +
 +-- | Check the constraints for a VG/LV names (except the @\/dev\/@ check).
 +instance Validatable LogicalVolume where
 +  validate (LogicalVolume g v) = do
 +      let vgn = "Volume group name"
 +      -- Group name checks
 +      nonEmpty vgn g
 +      validChars vgn g
 +      notStartsDash vgn g
 +      notIn vgn g [".", ".."]
 +      -- Volume name checks
 +      let lvn = "Volume name"
 +      nonEmpty lvn v
 +      validChars lvn v
 +      notStartsDash lvn v
 +      notIn lvn v [".", "..", "snapshot", "pvmove"]
 +      reportIf ("_mlog" `isInfixOf` v) $ lvn ++ " must not contain '_mlog'."
 +      reportIf ("_mimage" `isInfixOf` v) $ lvn ++ "must not contain '_mimage'."
 +    where
 +      nonEmpty prefix x = reportIf (null x) $ prefix ++ " must be non-empty"
 +      notIn prefix x =
 +        mapM_ (\y -> reportIf (x == y)
 +                              $ prefix ++ " must not be '" ++ y ++ "'")
 +      notStartsDash prefix x = reportIf ("-" `isPrefixOf` x)
 +                                 $ prefix ++ " must not start with '-'"
 +      validChars prefix x =
 +        reportIf (not . all validChar $ x)
 +                 $ prefix ++ " must consist only of [a-z][A-Z][0-9][+_.-]"
 +      validChar c = isAsciiLower c || isAsciiUpper c || isDigit c
 +                    || (c `elem` "+_.-")
 +
 +instance J.JSON LogicalVolume where
 +  showJSON = J.showJSON . show
 +  readJSON (J.JSString s) | (g, _ : l) <- break (== '/') (J.fromJSString s) =
 +    either fail return . evalValidate . validate' $ LogicalVolume g l
 +  readJSON v = fail $ "Invalid JSON value " ++ show v
 +                      ++ " for a logical volume"
 +
 +-- | The disk configuration type. This includes the disk type itself,
 +-- for a more complete consistency. Note that since in the Python
 +-- code-base there's no authoritative place where we document the
 +-- logical id, this is probably a good reference point. There is a bijective
 +-- correspondence between the 'DiskLogicalId' constructors and 'DiskTemplate'.
 +data DiskLogicalId
 +  = LIDPlain LogicalVolume  -- ^ Volume group, logical volume
-   | LIDDrbd8 String String Int Int Int DRBDSecret
++  | LIDDrbd8 String String Int Int Int (Private DRBDSecret)
 +  -- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
 +  | LIDFile FileDriver String -- ^ Driver, path
 +  | LIDSharedFile FileDriver String -- ^ Driver, path
 +  | LIDGluster FileDriver String -- ^ Driver, path
 +  | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
 +  | LIDRados String String -- ^ Unused, path
 +  | LIDExt String String -- ^ ExtProvider, unique name
 +    deriving (Show, Eq)
 +
 +-- | Mapping from a logical id to a disk type.
 +lidDiskType :: DiskLogicalId -> DiskTemplate
 +lidDiskType (LIDPlain {}) = DTPlain
 +lidDiskType (LIDDrbd8 {}) = DTDrbd8
 +lidDiskType (LIDFile  {}) = DTFile
 +lidDiskType (LIDSharedFile  {}) = DTSharedFile
 +lidDiskType (LIDGluster  {}) = DTGluster
 +lidDiskType (LIDBlockDev {}) = DTBlock
 +lidDiskType (LIDRados {}) = DTRbd
 +lidDiskType (LIDExt {}) = DTExt
 +
 +-- | Builds the extra disk_type field for a given logical id.
 +lidEncodeType :: DiskLogicalId -> [(String, JSValue)]
 +lidEncodeType v = [(devType, showJSON . lidDiskType $ v)]
 +
 +-- | Custom encoder for DiskLogicalId (logical id only).
 +encodeDLId :: DiskLogicalId -> JSValue
 +encodeDLId (LIDPlain (LogicalVolume vg lv)) =
 +  JSArray [showJSON vg, showJSON lv]
 +encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
 +  JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
 +          , showJSON minorA, showJSON minorB, showJSON key ]
 +encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
 +encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
 +encodeDLId (LIDSharedFile driver name) =
 +  JSArray [showJSON driver, showJSON name]
 +encodeDLId (LIDGluster driver name) = JSArray [showJSON driver, showJSON name]
 +encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
 +encodeDLId (LIDExt extprovider name) =
 +  JSArray [showJSON extprovider, showJSON name]
 +
 +-- | Custom encoder for DiskLogicalId, composing both the logical id
 +-- and the extra disk_type field.
 +encodeFullDLId :: DiskLogicalId -> (JSValue, [(String, JSValue)])
 +encodeFullDLId v = (encodeDLId v, lidEncodeType v)
 +
 +-- | Custom decoder for DiskLogicalId. This is manual for now, since
 +-- we don't have yet automation for separate-key style fields.
 +decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
 +decodeDLId obj lid = do
 +  dtype <- fromObj obj devType
 +  case dtype of
 +    DTDrbd8 ->
 +      case lid of
 +        JSArray [nA, nB, p, mA, mB, k] ->
 +          LIDDrbd8
 +            <$> readJSON nA
 +            <*> readJSON nB
 +            <*> readJSON p
 +            <*> readJSON mA
 +            <*> readJSON mB
 +            <*> readJSON k
 +        _ -> fail "Can't read logical_id for DRBD8 type"
 +    DTPlain ->
 +      case lid of
 +        JSArray [vg, lv] -> LIDPlain <$>
 +          (LogicalVolume <$> readJSON vg <*> readJSON lv)
 +        _ -> fail "Can't read logical_id for plain type"
 +    DTFile ->
 +      case lid of
 +        JSArray [driver, path] ->
 +          LIDFile
 +            <$> readJSON driver
 +            <*> readJSON path
 +        _ -> fail "Can't read logical_id for file type"
 +    DTSharedFile ->
 +      case lid of
 +        JSArray [driver, path] ->
 +          LIDSharedFile
 +            <$> readJSON driver
 +            <*> readJSON path
 +        _ -> fail "Can't read logical_id for shared file type"
 +    DTGluster ->
 +      case lid of
 +        JSArray [driver, path] ->
 +          LIDGluster
 +            <$> readJSON driver
 +            <*> readJSON path
 +        _ -> fail "Can't read logical_id for shared file type"
 +    DTBlock ->
 +      case lid of
 +        JSArray [driver, path] ->
 +          LIDBlockDev
 +            <$> readJSON driver
 +            <*> readJSON path
 +        _ -> fail "Can't read logical_id for blockdev type"
 +    DTRbd ->
 +      case lid of
 +        JSArray [driver, path] ->
 +          LIDRados
 +            <$> readJSON driver
 +            <*> readJSON path
 +        _ -> fail "Can't read logical_id for rdb type"
 +    DTExt ->
 +      case lid of
 +        JSArray [extprovider, name] ->
 +          LIDExt
 +            <$> readJSON extprovider
 +            <*> readJSON name
 +        _ -> fail "Can't read logical_id for extstorage type"
 +    DTDiskless ->
 +      fail "Retrieved 'diskless' disk."
 +
 +-- | Disk data structure.
 +
 +$(buildObjectWithForthcoming "Disk" "disk" $
 +  [ customField 'decodeDLId 'encodeFullDLId ["dev_type"] $
 +      simpleField "logical_id"    [t| DiskLogicalId   |]
 +  , defaultField  [| [] |]
 +      $ simpleField "children" (return . AppT ListT . ConT $ mkName "Disk")
 +  , defaultField  [| [] |] $ simpleField "nodes" [t| [String] |]
 +  , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
 +  , simpleField "size" [t| Int |]
 +  , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
 +  , optionalField $ simpleField "name" [t| String |]
 +  , optionalField $ simpleField "spindles" [t| Int |]
 +  , optionalField $ simpleField "params" [t| DiskParams |]
 +  ]
 +  ++ uuidFields
 +  ++ serialFields
 +  ++ timeStampFields)
 +
 +instance UuidObject Disk where
 +  uuidOf = diskUuid
 +
 +instance ForthcomingObject Disk where
 +  isForthcoming = diskForthcoming
 +
 +-- | Determines whether a disk or one of his children has the given logical id
 +-- (determined by the volume group name and by the logical volume name).
 +-- This can be true only for DRBD or LVM disks.
 +includesLogicalId :: LogicalVolume -> Disk -> Bool
 +includesLogicalId lv disk =
 +  case diskLogicalId disk of
 +    Just (LIDPlain lv') -> lv' == lv
 +    Just (LIDDrbd8 {}) ->
 +      any (includesLogicalId lv) $ diskChildren disk
 +    _ -> False
@@@ -740,19 -681,15 +740,20 @@@ caseIncludeLogicalIdDrbd 
    let vg_name = "xenvg" :: String
        lv_name = "1234sdf-qwef-2134-asff-asd2-23145d.data" :: String
        time = TOD 0 0
 -      d =
 -        Disk
 +      d = RealDisk $
 +        RealDiskData
-           (LIDDrbd8 "node1.example.com" "node2.example.com" 2000 1 5 "secret")
+           (LIDDrbd8 "node1.example.com" "node2.example.com" 2000 1 5
+            (Private "secret"))
 -          [ Disk (mkLIDPlain "onevg" "onelv") [] "disk1" 1000 DiskRdWr Nothing
 -              Nothing Nothing "145145-asdf-sdf2-2134-asfd-534g2x" 0 time time
 -          , Disk (mkLIDPlain vg_name lv_name) [] "disk2" 1000 DiskRdWr Nothing
 -              Nothing Nothing "6gd3sd-423f-ag2j-563b-dg34-gj3fse" 0 time time
 -          ] "diskname" 1000 DiskRdWr Nothing Nothing Nothing
 +          [ RealDisk $ RealDiskData (mkLIDPlain "onevg" "onelv") []
 +              ["node1.example.com", "node2.example.com"] "disk1" 1000 DiskRdWr
 +              Nothing Nothing Nothing "145145-asdf-sdf2-2134-asfd-534g2x"
 +              0 time time
 +          , RealDisk $ RealDiskData (mkLIDPlain vg_name lv_name) []
 +              ["node1.example.com", "node2.example.com"] "disk2" 1000 DiskRdWr
 +              Nothing Nothing Nothing "6gd3sd-423f-ag2j-563b-dg34-gj3fse"
 +              0 time time
 +          ] ["node1.example.com", "node2.example.com"] "diskname" 1000 DiskRdWr
 +          Nothing Nothing Nothing
            "asdfgr-1234-5123-daf3-sdfw-134f43" 0 time time
    in
      HUnit.assertBool "Unable to detect that plain Disk includes logical ID" $