Merge branch 'stable-2.14' into stable-2.15
[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 qualified Data.ByteString.UTF8 as UTF8
41 import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
42 import Data.List (isPrefixOf, isInfixOf)
43 import Language.Haskell.TH.Syntax
44 import Text.JSON (showJSON, readJSON, JSValue(..))
45 import qualified Text.JSON as J
46
47 import Ganeti.JSON (Container, fromObj)
48 import Ganeti.THH
49 import Ganeti.THH.Field
50 import Ganeti.Types
51 import Ganeti.Utils.Validate
52
53 -- | Constant for the dev_type key entry in the disk config.
54 devType :: String
55 devType = "dev_type"
56
57 -- | The disk parameters type.
58 type DiskParams = Container JSValue
59
60 -- | An alias for DRBD secrets
61 type DRBDSecret = String
62
63 -- Represents a group name and a volume name.
64 --
65 -- From @man lvm@:
66 --
67 -- The following characters are valid for VG and LV names: a-z A-Z 0-9 + _ . -
68 --
69 -- VG and LV names cannot begin with a hyphen. There are also various reserved
70 -- names that are used internally by lvm that can not be used as LV or VG names.
71 -- A VG cannot be called anything that exists in /dev/ at the time of
72 -- creation, nor can it be called '.' or '..'. A LV cannot be called '.' '..'
73 -- 'snapshot' or 'pvmove'. The LV name may also not contain the strings '_mlog'
74 -- or '_mimage'
75 data LogicalVolume = LogicalVolume { lvGroup :: String
76 , lvVolume :: String
77 }
78 deriving (Eq, Ord)
79
80 instance Show LogicalVolume where
81 showsPrec _ (LogicalVolume g v) =
82 showString g . showString "/" . showString v
83
84 -- | Check the constraints for a VG/LV names (except the @\/dev\/@ check).
85 instance Validatable LogicalVolume where
86 validate (LogicalVolume g v) = do
87 let vgn = "Volume group name"
88 -- Group name checks
89 nonEmpty vgn g
90 validChars vgn g
91 notStartsDash vgn g
92 notIn vgn g [".", ".."]
93 -- Volume name checks
94 let lvn = "Volume name"
95 nonEmpty lvn v
96 validChars lvn v
97 notStartsDash lvn v
98 notIn lvn v [".", "..", "snapshot", "pvmove"]
99 reportIf ("_mlog" `isInfixOf` v) $ lvn ++ " must not contain '_mlog'."
100 reportIf ("_mimage" `isInfixOf` v) $ lvn ++ "must not contain '_mimage'."
101 where
102 nonEmpty prefix x = reportIf (null x) $ prefix ++ " must be non-empty"
103 notIn prefix x =
104 mapM_ (\y -> reportIf (x == y)
105 $ prefix ++ " must not be '" ++ y ++ "'")
106 notStartsDash prefix x = reportIf ("-" `isPrefixOf` x)
107 $ prefix ++ " must not start with '-'"
108 validChars prefix x =
109 reportIf (not . all validChar $ x)
110 $ prefix ++ " must consist only of [a-z][A-Z][0-9][+_.-]"
111 validChar c = isAsciiLower c || isAsciiUpper c || isDigit c
112 || (c `elem` "+_.-")
113
114 instance J.JSON LogicalVolume where
115 showJSON = J.showJSON . show
116 readJSON (J.JSString s) | (g, _ : l) <- break (== '/') (J.fromJSString s) =
117 either fail return . evalValidate . validate' $ LogicalVolume g l
118 readJSON v = fail $ "Invalid JSON value " ++ show v
119 ++ " for a logical volume"
120
121 -- | The disk configuration type. This includes the disk type itself,
122 -- for a more complete consistency. Note that since in the Python
123 -- code-base there's no authoritative place where we document the
124 -- logical id, this is probably a good reference point. There is a bijective
125 -- correspondence between the 'DiskLogicalId' constructors and 'DiskTemplate'.
126 data DiskLogicalId
127 = LIDPlain LogicalVolume -- ^ Volume group, logical volume
128 | LIDDrbd8 String String Int Int Int (Private DRBDSecret)
129 -- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
130 | LIDFile FileDriver String -- ^ Driver, path
131 | LIDSharedFile FileDriver String -- ^ Driver, path
132 | LIDGluster FileDriver String -- ^ Driver, path
133 | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
134 | LIDRados String String -- ^ Unused, path
135 | LIDExt String String -- ^ ExtProvider, unique name
136 deriving (Show, Eq)
137
138 -- | Mapping from a logical id to a disk type.
139 lidDiskType :: DiskLogicalId -> DiskTemplate
140 lidDiskType (LIDPlain {}) = DTPlain
141 lidDiskType (LIDDrbd8 {}) = DTDrbd8
142 lidDiskType (LIDFile {}) = DTFile
143 lidDiskType (LIDSharedFile {}) = DTSharedFile
144 lidDiskType (LIDGluster {}) = DTGluster
145 lidDiskType (LIDBlockDev {}) = DTBlock
146 lidDiskType (LIDRados {}) = DTRbd
147 lidDiskType (LIDExt {}) = DTExt
148
149 -- | Builds the extra disk_type field for a given logical id.
150 lidEncodeType :: DiskLogicalId -> [(String, JSValue)]
151 lidEncodeType v = [(devType, showJSON . lidDiskType $ v)]
152
153 -- | Custom encoder for DiskLogicalId (logical id only).
154 encodeDLId :: DiskLogicalId -> JSValue
155 encodeDLId (LIDPlain (LogicalVolume vg lv)) =
156 JSArray [showJSON vg, showJSON lv]
157 encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
158 JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
159 , showJSON minorA, showJSON minorB, showJSON key ]
160 encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
161 encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
162 encodeDLId (LIDSharedFile driver name) =
163 JSArray [showJSON driver, showJSON name]
164 encodeDLId (LIDGluster driver name) = JSArray [showJSON driver, showJSON name]
165 encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
166 encodeDLId (LIDExt extprovider name) =
167 JSArray [showJSON extprovider, showJSON name]
168
169 -- | Custom encoder for DiskLogicalId, composing both the logical id
170 -- and the extra disk_type field.
171 encodeFullDLId :: DiskLogicalId -> (JSValue, [(String, JSValue)])
172 encodeFullDLId v = (encodeDLId v, lidEncodeType v)
173
174 -- | Custom decoder for DiskLogicalId. This is manual for now, since
175 -- we don't have yet automation for separate-key style fields.
176 decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
177 decodeDLId obj lid = do
178 dtype <- fromObj obj devType
179 case dtype of
180 DTDrbd8 ->
181 case lid of
182 JSArray [nA, nB, p, mA, mB, k] ->
183 LIDDrbd8
184 <$> readJSON nA
185 <*> readJSON nB
186 <*> readJSON p
187 <*> readJSON mA
188 <*> readJSON mB
189 <*> readJSON k
190 _ -> fail "Can't read logical_id for DRBD8 type"
191 DTPlain ->
192 case lid of
193 JSArray [vg, lv] -> LIDPlain <$>
194 (LogicalVolume <$> readJSON vg <*> readJSON lv)
195 _ -> fail "Can't read logical_id for plain type"
196 DTFile ->
197 case lid of
198 JSArray [driver, path] ->
199 LIDFile
200 <$> readJSON driver
201 <*> readJSON path
202 _ -> fail "Can't read logical_id for file type"
203 DTSharedFile ->
204 case lid of
205 JSArray [driver, path] ->
206 LIDSharedFile
207 <$> readJSON driver
208 <*> readJSON path
209 _ -> fail "Can't read logical_id for shared file type"
210 DTGluster ->
211 case lid of
212 JSArray [driver, path] ->
213 LIDGluster
214 <$> readJSON driver
215 <*> readJSON path
216 _ -> fail "Can't read logical_id for shared file type"
217 DTBlock ->
218 case lid of
219 JSArray [driver, path] ->
220 LIDBlockDev
221 <$> readJSON driver
222 <*> readJSON path
223 _ -> fail "Can't read logical_id for blockdev type"
224 DTRbd ->
225 case lid of
226 JSArray [driver, path] ->
227 LIDRados
228 <$> readJSON driver
229 <*> readJSON path
230 _ -> fail "Can't read logical_id for rdb type"
231 DTExt ->
232 case lid of
233 JSArray [extprovider, name] ->
234 LIDExt
235 <$> readJSON extprovider
236 <*> readJSON name
237 _ -> fail "Can't read logical_id for extstorage type"
238 DTDiskless ->
239 fail "Retrieved 'diskless' disk."
240
241 -- | Disk data structure.
242
243 $(buildObjectWithForthcoming "Disk" "disk" $
244 [ customField 'decodeDLId 'encodeFullDLId ["dev_type"] $
245 simpleField "logical_id" [t| DiskLogicalId |]
246 , defaultField [| [] |]
247 $ simpleField "children" (return . AppT ListT . ConT $ mkName "Disk")
248 , defaultField [| [] |] $ simpleField "nodes" [t| [String] |]
249 , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
250 , simpleField "size" [t| Int |]
251 , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
252 , optionalField $ simpleField "name" [t| String |]
253 , optionalField $ simpleField "spindles" [t| Int |]
254 , optionalField $ simpleField "params" [t| DiskParams |]
255 ]
256 ++ uuidFields
257 ++ serialFields
258 ++ timeStampFields)
259
260 instance UuidObject Disk where
261 uuidOf = UTF8.toString . diskUuid
262
263 instance ForthcomingObject Disk where
264 isForthcoming = diskForthcoming
265
266 -- | Determines whether a disk or one of his children has the given logical id
267 -- (determined by the volume group name and by the logical volume name).
268 -- This can be true only for DRBD or LVM disks.
269 includesLogicalId :: LogicalVolume -> Disk -> Bool
270 includesLogicalId lv disk =
271 case diskLogicalId disk of
272 Just (LIDPlain lv') -> lv' == lv
273 Just (LIDDrbd8 {}) ->
274 any (includesLogicalId lv) $ diskChildren disk
275 _ -> False