Merge branch 'stable-2.13' into stable-2.14
[ganeti-github.git] / src / Ganeti / Objects / Disk.hs
1 {-# LANGUAGE TemplateHaskell, FunctionalDependencies #-}
2
3 {-| Implementation of the Ganeti Disk config object.
4
5 -}
6
7 {-
8
9 Copyright (C) 2014 Google Inc.
10 All rights reserved.
11
12 Redistribution and use in source and binary forms, with or without
13 modification, are permitted provided that the following conditions are
14 met:
15
16 1. Redistributions of source code must retain the above copyright notice,
17 this list of conditions and the following disclaimer.
18
19 2. Redistributions in binary form must reproduce the above copyright
20 notice, this list of conditions and the following disclaimer in the
21 documentation and/or other materials provided with the distribution.
22
23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
24 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
25 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
26 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
27 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
28 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
29 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
30 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
31 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34
35 -}
36
37 module Ganeti.Objects.Disk where
38
39 import Control.Applicative ((<*>), (<$>))
40 import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
41 import Data.List (isPrefixOf, isInfixOf)
42 import Language.Haskell.TH.Syntax
43 import Text.JSON (showJSON, readJSON, JSValue(..))
44 import qualified Text.JSON as J
45
46 import Ganeti.JSON (Container, fromObj)
47 import Ganeti.THH
48 import Ganeti.THH.Field
49 import Ganeti.Types
50 import Ganeti.Utils.Validate
51
52 -- | Constant for the dev_type key entry in the disk config.
53 devType :: String
54 devType = "dev_type"
55
56 -- | The disk parameters type.
57 type DiskParams = Container JSValue
58
59 -- | An alias for DRBD secrets
60 type DRBDSecret = String
61
62 -- Represents a group name and a volume name.
63 --
64 -- From @man lvm@:
65 --
66 -- The following characters are valid for VG and LV names: a-z A-Z 0-9 + _ . -
67 --
68 -- VG and LV names cannot begin with a hyphen. There are also various reserved
69 -- names that are used internally by lvm that can not be used as LV or VG names.
70 -- A VG cannot be called anything that exists in /dev/ at the time of
71 -- creation, nor can it be called '.' or '..'. A LV cannot be called '.' '..'
72 -- 'snapshot' or 'pvmove'. The LV name may also not contain the strings '_mlog'
73 -- or '_mimage'
74 data LogicalVolume = LogicalVolume { lvGroup :: String
75 , lvVolume :: String
76 }
77 deriving (Eq, Ord)
78
79 instance Show LogicalVolume where
80 showsPrec _ (LogicalVolume g v) =
81 showString g . showString "/" . showString v
82
83 -- | Check the constraints for a VG/LV names (except the @\/dev\/@ check).
84 instance Validatable LogicalVolume where
85 validate (LogicalVolume g v) = do
86 let vgn = "Volume group name"
87 -- Group name checks
88 nonEmpty vgn g
89 validChars vgn g
90 notStartsDash vgn g
91 notIn vgn g [".", ".."]
92 -- Volume name checks
93 let lvn = "Volume name"
94 nonEmpty lvn v
95 validChars lvn v
96 notStartsDash lvn v
97 notIn lvn v [".", "..", "snapshot", "pvmove"]
98 reportIf ("_mlog" `isInfixOf` v) $ lvn ++ " must not contain '_mlog'."
99 reportIf ("_mimage" `isInfixOf` v) $ lvn ++ "must not contain '_mimage'."
100 where
101 nonEmpty prefix x = reportIf (null x) $ prefix ++ " must be non-empty"
102 notIn prefix x =
103 mapM_ (\y -> reportIf (x == y)
104 $ prefix ++ " must not be '" ++ y ++ "'")
105 notStartsDash prefix x = reportIf ("-" `isPrefixOf` x)
106 $ prefix ++ " must not start with '-'"
107 validChars prefix x =
108 reportIf (not . all validChar $ x)
109 $ prefix ++ " must consist only of [a-z][A-Z][0-9][+_.-]"
110 validChar c = isAsciiLower c || isAsciiUpper c || isDigit c
111 || (c `elem` "+_.-")
112
113 instance J.JSON LogicalVolume where
114 showJSON = J.showJSON . show
115 readJSON (J.JSString s) | (g, _ : l) <- break (== '/') (J.fromJSString s) =
116 either fail return . evalValidate . validate' $ LogicalVolume g l
117 readJSON v = fail $ "Invalid JSON value " ++ show v
118 ++ " for a logical volume"
119
120 -- | The disk configuration type. This includes the disk type itself,
121 -- for a more complete consistency. Note that since in the Python
122 -- code-base there's no authoritative place where we document the
123 -- logical id, this is probably a good reference point. There is a bijective
124 -- correspondence between the 'DiskLogicalId' constructors and 'DiskTemplate'.
125 data DiskLogicalId
126 = LIDPlain LogicalVolume -- ^ Volume group, logical volume
127 | LIDDrbd8 String String Int Int Int (Private DRBDSecret)
128 -- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
129 | LIDFile FileDriver String -- ^ Driver, path
130 | LIDSharedFile FileDriver String -- ^ Driver, path
131 | LIDGluster FileDriver String -- ^ Driver, path
132 | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
133 | LIDRados String String -- ^ Unused, path
134 | LIDExt String String -- ^ ExtProvider, unique name
135 deriving (Show, Eq)
136
137 -- | Mapping from a logical id to a disk type.
138 lidDiskType :: DiskLogicalId -> DiskTemplate
139 lidDiskType (LIDPlain {}) = DTPlain
140 lidDiskType (LIDDrbd8 {}) = DTDrbd8
141 lidDiskType (LIDFile {}) = DTFile
142 lidDiskType (LIDSharedFile {}) = DTSharedFile
143 lidDiskType (LIDGluster {}) = DTGluster
144 lidDiskType (LIDBlockDev {}) = DTBlock
145 lidDiskType (LIDRados {}) = DTRbd
146 lidDiskType (LIDExt {}) = DTExt
147
148 -- | Builds the extra disk_type field for a given logical id.
149 lidEncodeType :: DiskLogicalId -> [(String, JSValue)]
150 lidEncodeType v = [(devType, showJSON . lidDiskType $ v)]
151
152 -- | Custom encoder for DiskLogicalId (logical id only).
153 encodeDLId :: DiskLogicalId -> JSValue
154 encodeDLId (LIDPlain (LogicalVolume vg lv)) =
155 JSArray [showJSON vg, showJSON lv]
156 encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
157 JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
158 , showJSON minorA, showJSON minorB, showJSON key ]
159 encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
160 encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
161 encodeDLId (LIDSharedFile driver name) =
162 JSArray [showJSON driver, showJSON name]
163 encodeDLId (LIDGluster driver name) = JSArray [showJSON driver, showJSON name]
164 encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
165 encodeDLId (LIDExt extprovider name) =
166 JSArray [showJSON extprovider, showJSON name]
167
168 -- | Custom encoder for DiskLogicalId, composing both the logical id
169 -- and the extra disk_type field.
170 encodeFullDLId :: DiskLogicalId -> (JSValue, [(String, JSValue)])
171 encodeFullDLId v = (encodeDLId v, lidEncodeType v)
172
173 -- | Custom decoder for DiskLogicalId. This is manual for now, since
174 -- we don't have yet automation for separate-key style fields.
175 decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
176 decodeDLId obj lid = do
177 dtype <- fromObj obj devType
178 case dtype of
179 DTDrbd8 ->
180 case lid of
181 JSArray [nA, nB, p, mA, mB, k] ->
182 LIDDrbd8
183 <$> readJSON nA
184 <*> readJSON nB
185 <*> readJSON p
186 <*> readJSON mA
187 <*> readJSON mB
188 <*> readJSON k
189 _ -> fail "Can't read logical_id for DRBD8 type"
190 DTPlain ->
191 case lid of
192 JSArray [vg, lv] -> LIDPlain <$>
193 (LogicalVolume <$> readJSON vg <*> readJSON lv)
194 _ -> fail "Can't read logical_id for plain type"
195 DTFile ->
196 case lid of
197 JSArray [driver, path] ->
198 LIDFile
199 <$> readJSON driver
200 <*> readJSON path
201 _ -> fail "Can't read logical_id for file type"
202 DTSharedFile ->
203 case lid of
204 JSArray [driver, path] ->
205 LIDSharedFile
206 <$> readJSON driver
207 <*> readJSON path
208 _ -> fail "Can't read logical_id for shared file type"
209 DTGluster ->
210 case lid of
211 JSArray [driver, path] ->
212 LIDGluster
213 <$> readJSON driver
214 <*> readJSON path
215 _ -> fail "Can't read logical_id for shared file type"
216 DTBlock ->
217 case lid of
218 JSArray [driver, path] ->
219 LIDBlockDev
220 <$> readJSON driver
221 <*> readJSON path
222 _ -> fail "Can't read logical_id for blockdev type"
223 DTRbd ->
224 case lid of
225 JSArray [driver, path] ->
226 LIDRados
227 <$> readJSON driver
228 <*> readJSON path
229 _ -> fail "Can't read logical_id for rdb type"
230 DTExt ->
231 case lid of
232 JSArray [extprovider, name] ->
233 LIDExt
234 <$> readJSON extprovider
235 <*> readJSON name
236 _ -> fail "Can't read logical_id for extstorage type"
237 DTDiskless ->
238 fail "Retrieved 'diskless' disk."
239
240 -- | Disk data structure.
241
242 $(buildObjectWithForthcoming "Disk" "disk" $
243 [ customField 'decodeDLId 'encodeFullDLId ["dev_type"] $
244 simpleField "logical_id" [t| DiskLogicalId |]
245 , defaultField [| [] |]
246 $ simpleField "children" (return . AppT ListT . ConT $ mkName "Disk")
247 , defaultField [| [] |] $ simpleField "nodes" [t| [String] |]
248 , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
249 , simpleField "size" [t| Int |]
250 , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
251 , optionalField $ simpleField "name" [t| String |]
252 , optionalField $ simpleField "spindles" [t| Int |]
253 , optionalField $ simpleField "params" [t| DiskParams |]
254 ]
255 ++ uuidFields
256 ++ serialFields
257 ++ timeStampFields)
258
259 instance UuidObject Disk where
260 uuidOf = diskUuid
261
262 instance ForthcomingObject Disk where
263 isForthcoming = diskForthcoming
264
265 -- | Determines whether a disk or one of his children has the given logical id
266 -- (determined by the volume group name and by the logical volume name).
267 -- This can be true only for DRBD or LVM disks.
268 includesLogicalId :: LogicalVolume -> Disk -> Bool
269 includesLogicalId lv disk =
270 case diskLogicalId disk of
271 Just (LIDPlain lv') -> lv' == lv
272 Just (LIDDrbd8 {}) ->
273 any (includesLogicalId lv) $ diskChildren disk
274 _ -> False