Store keys as ByteStrings
[ganeti-github.git] / src / Ganeti / WConfd / TempRes.hs
1 {-# LANGUAGE TemplateHaskell, RankNTypes, FlexibleContexts #-}
2
3 {-| Pure functions for manipulating reservations of temporary objects
4
5 NOTE: Reservations aren't released specifically, they're just all
6 released at the end of a job. This could be improved in the future.
7
8 -}
9
10 {-
11
12 Copyright (C) 2014 Google Inc.
13 All rights reserved.
14
15 Redistribution and use in source and binary forms, with or without
16 modification, are permitted provided that the following conditions are
17 met:
18
19 1. Redistributions of source code must retain the above copyright notice,
20 this list of conditions and the following disclaimer.
21
22 2. Redistributions in binary form must reproduce the above copyright
23 notice, this list of conditions and the following disclaimer in the
24 documentation and/or other materials provided with the distribution.
25
26 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
27 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
28 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
29 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
30 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
31 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
32 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
33 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
34 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
35 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
36 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
37
38 -}
39
40 module Ganeti.WConfd.TempRes
41 ( TempRes
42 , mkTempRes
43 , TempResState(..)
44 , emptyTempResState
45 , NodeUUID
46 , InstanceUUID
47 , DiskUUID
48 , NetworkUUID
49 , DRBDMinor
50 , DRBDMap
51 , trsDRBDL
52 , computeDRBDMap
53 , computeDRBDMap'
54 , allocateDRBDMinor
55 , releaseDRBDMinors
56 , MAC
57 , generateMAC
58 , reserveMAC
59 , generateDRBDSecret
60 , reserveLV
61 , IPv4ResAction(..)
62 , IPv4Reservation(..)
63 , reserveIp
64 , releaseIp
65 , generateIp
66 , commitReleaseIp
67 , commitReservedIps
68 , listReservedIps
69 , dropAllReservations
70 , isReserved
71 , reserve
72 , dropReservationsFor
73 , reserved
74 ) where
75
76 import Control.Applicative
77 import Control.Lens.At
78 import Control.Monad.Error
79 import Control.Monad.State
80 import Control.Monad.Trans.Maybe
81 import qualified Data.ByteString as BS
82 import qualified Data.ByteString.UTF8 as UTF8
83 import qualified Data.Foldable as F
84 import Data.Maybe
85 import Data.Map (Map)
86 import qualified Data.Map as M
87 import Data.Monoid
88 import qualified Data.Set as S
89 import System.Random
90 import qualified Text.JSON as J
91
92 import Ganeti.BasicTypes
93 import Ganeti.Config
94 import qualified Ganeti.Constants as C
95 import Ganeti.Errors
96 import qualified Ganeti.JSON as J
97 import Ganeti.Lens
98 import qualified Ganeti.Network as N
99 import Ganeti.Locking.Locks (ClientId)
100 import Ganeti.Logging
101 import Ganeti.Objects
102 import Ganeti.THH
103 import Ganeti.Objects.Lens (configNetworksL)
104 import Ganeti.Utils
105 import Ganeti.Utils.Monad
106 import Ganeti.Utils.Random
107 import qualified Ganeti.Utils.MultiMap as MM
108
109 -- * The main reservation state
110
111 -- ** Aliases to make types more meaningful:
112
113 type NodeUUID = BS.ByteString
114
115 type InstanceUUID = BS.ByteString
116
117 type DiskUUID = BS.ByteString
118
119 type NetworkUUID = BS.ByteString
120
121 type DRBDMinor = Int
122
123 -- | A map of the usage of DRBD minors
124 type DRBDMap = Map NodeUUID (Map DRBDMinor DiskUUID)
125
126 -- | A map of the usage of DRBD minors with possible duplicates
127 type DRBDMap' = Map NodeUUID (Map DRBDMinor [DiskUUID])
128
129 -- * The state data structure
130
131 -- | Types of IPv4 reservation actions.
132 data IPv4ResAction = IPv4Reserve | IPv4Release
133 deriving (Eq, Ord, Show, Bounded, Enum)
134
135 instance J.JSON IPv4ResAction where
136 showJSON IPv4Reserve = J.JSString . J.toJSString $ C.reserveAction
137 showJSON IPv4Release = J.JSString . J.toJSString $ C.releaseAction
138 readJSON = J.readEitherString
139 >=> \s -> case () of
140 _ | s == C.reserveAction -> return IPv4Reserve
141 | s == C.releaseAction -> return IPv4Release
142 | otherwise -> fail $ "Invalid IP reservation action: "
143 ++ s
144
145 -- | The values stored in the IPv4 reservation table.
146 data IPv4Reservation = IPv4Res
147 { ipv4ResAction :: IPv4ResAction
148 , ipv4ResNetwork :: NetworkUUID
149 , ipv4ResAddr :: Ip4Address
150 } deriving (Eq, Ord, Show)
151
152 instance J.JSON IPv4Reservation where
153 -- Notice that addr and net are in a different order, to be compatible
154 -- with the original Python representation (while it's used).
155 showJSON (IPv4Res a net addr) = J.showJSON (a, addr, net)
156 readJSON = fmap (\(a, addr, net) -> IPv4Res a net addr) . J.readJSON
157
158 -- | A polymorphic data structure for managing temporary resources assigned
159 -- to jobs.
160 newtype TempRes j a = TempRes { getTempRes :: MM.MultiMap j a }
161 deriving (Eq, Ord, Show)
162
163 instance (Ord j, Ord a) => Monoid (TempRes j a) where
164 mempty = TempRes mempty
165 mappend (TempRes x) (TempRes y) = TempRes $ x <> y
166
167 instance (J.JSON j, Ord j, J.JSON a, Ord a) => J.JSON (TempRes j a) where
168 showJSON = J.showJSON . getTempRes
169 readJSON = liftM TempRes . J.readJSON
170
171 -- | Create a temporary reservations from a given multi-map.
172 mkTempRes :: MM.MultiMap j a -> TempRes j a
173 mkTempRes = TempRes
174
175 -- | The state of the temporary reservations
176 $(buildObject "TempResState" "trs"
177 [ simpleField "dRBD" [t| DRBDMap |]
178 , simpleField "mACs" [t| TempRes ClientId MAC |]
179 , simpleField "dRBDSecrets" [t| TempRes ClientId DRBDSecret |]
180 , simpleField "lVs" [t| TempRes ClientId LogicalVolume |]
181 , simpleField "iPv4s" [t| TempRes ClientId IPv4Reservation |]
182 ])
183
184 emptyTempResState :: TempResState
185 emptyTempResState = TempResState M.empty mempty mempty mempty mempty
186
187 $(makeCustomLenses ''TempResState)
188
189 -- ** Utility functions
190
191 -- | Issues a reservation error.
192 resError :: (MonadError GanetiException m) => String -> m a
193 resError = throwError . ReservationError
194
195 -- | Converts 'GenericError' into a 'ReservationError'.
196 toResError :: (MonadError GanetiException m) => m a -> m a
197 toResError = flip catchError (throwError . f)
198 where
199 f (GenericError msg) = ReservationError msg
200 f e = e
201
202 -- | Filter values from the nested map and remove any nested maps
203 -- that become empty.
204 filterNested :: (Ord a, Ord b)
205 => (c -> Bool) -> Map a (Map b c) -> Map a (Map b c)
206 filterNested p = M.filter (not . M.null) . fmap (M.filter p)
207
208 -- | Converts a lens that works on maybe values into a lens that works
209 -- on regular ones. A missing value on the input is replaced by
210 -- 'mempty'.
211 -- The output is is @Just something@ iff @something /= mempty@.
212 maybeLens :: (Monoid a, Monoid b, Eq b)
213 => Lens s t (Maybe a) (Maybe b) -> Lens s t a b
214 maybeLens l f = l (fmap (mfilter (/= mempty) . Just) . f . fromMaybe mempty)
215
216 -- * DRBD functions
217
218 -- | Compute the map of used DRBD minor/nodes, including possible
219 -- duplicates.
220 -- An error is returned if the configuration isn't consistent
221 -- (for example if a referenced disk is missing etc.).
222 computeDRBDMap' :: (MonadError GanetiException m)
223 => ConfigData -> TempResState -> m DRBDMap'
224 computeDRBDMap' cfg trs =
225 flip execStateT (fmap (fmap (: [])) (trsDRBD trs))
226 $ F.forM_ (configDisks cfg) addMinors
227 where
228 -- | Creates a lens for modifying the list of instances
229 nodeMinor :: NodeUUID -> DRBDMinor -> Lens' DRBDMap' [DiskUUID]
230 nodeMinor node minor = maybeLens (at node) . maybeLens (at minor)
231 -- | Adds minors of a disk within the state monad
232 addMinors disk = do
233 let minors = getDrbdMinorsForDisk disk
234 forM_ minors $ \(minor, node) ->
235 nodeMinor (UTF8.fromString node) minor %=
236 (UTF8.fromString (uuidOf disk) :)
237
238 -- | Compute the map of used DRBD minor/nodes.
239 -- Report any duplicate entries as an error.
240 --
241 -- Unlike 'computeDRBDMap'', includes entries for all nodes, even if empty.
242 computeDRBDMap :: (MonadError GanetiException m)
243 => ConfigData -> TempResState -> m DRBDMap
244 computeDRBDMap cfg trs = do
245 m <- computeDRBDMap' cfg trs
246 let dups = filterNested ((>= 2) . length) m
247 unless (M.null dups) . resError
248 $ "Duplicate DRBD ports detected: " ++ show (M.toList $ fmap M.toList dups)
249 return $ fmap (fmap head . M.filter ((== 1) . length)) m
250 `M.union` (fmap (const mempty) . J.fromContainer . configNodes $ cfg)
251
252 -- Allocate a drbd minor.
253 --
254 -- The free minor will be automatically computed from the existing devices.
255 -- A node can not be given multiple times.
256 -- The result is the list of minors, in the same order as the passed nodes.
257 allocateDRBDMinor :: (MonadError GanetiException m, MonadState TempResState m)
258 => ConfigData -> DiskUUID -> [NodeUUID]
259 -> m [DRBDMinor]
260 allocateDRBDMinor cfg disk nodes = do
261 unless (nodes == ordNub nodes) . resError
262 $ "Duplicate nodes detected in list '" ++ show nodes ++ "'"
263 dMap <- computeDRBDMap' cfg =<< get
264 let usedMap = fmap M.keysSet dMap
265 let alloc :: S.Set DRBDMinor -> Map DRBDMinor DiskUUID
266 -> (DRBDMinor, Map DRBDMinor DiskUUID)
267 alloc used m = let k = findFirst 0 (M.keysSet m `S.union` used)
268 in (k, M.insert k disk m)
269 forM nodes $ \node -> trsDRBDL . maybeLens (at node)
270 %%= alloc (M.findWithDefault mempty node usedMap)
271
272 -- Release temporary drbd minors allocated for a given disk using
273 -- 'allocateDRBDMinor'.
274 releaseDRBDMinors :: (MonadState TempResState m) => DiskUUID -> m ()
275 releaseDRBDMinors disk = trsDRBDL %= filterNested (/= disk)
276
277 -- * Other temporary resources
278
279 -- | Tests if a given value is reserved for a given job.
280 isReserved :: (Ord a, Ord j) => a -> TempRes j a -> Bool
281 isReserved x = MM.elem x . getTempRes
282
283 -- | Tries to reserve a given value for a given job.
284 reserve :: (MonadError GanetiException m, Show a, Ord a, Ord j)
285 => j -> a -> TempRes j a -> m (TempRes j a)
286 reserve jobid x tr = do
287 when (isReserved x tr) . resError $ "Duplicate reservation for resource '"
288 ++ show x ++ "'"
289 return . TempRes . MM.insert jobid x $ getTempRes tr
290
291 dropReservationsFor :: (Ord a, Ord j) => j -> TempRes j a -> TempRes j a
292 dropReservationsFor jobid = TempRes . MM.deleteAll jobid . getTempRes
293
294 reservedFor :: (Ord a, Ord j) => j -> TempRes j a -> S.Set a
295 reservedFor jobid = MM.lookup jobid . getTempRes
296
297 reserved :: (Ord a, Ord j) => TempRes j a -> S.Set a
298 reserved = MM.values . getTempRes
299
300 -- | Computes the set of all reserved resources and passes it to
301 -- the given function.
302 -- This allows it to avoid resources that are already in use.
303 withReserved :: (MonadError GanetiException m, Show a, Ord a, Ord j)
304 => j -> (S.Set a -> m a) -> TempRes j a -> m (a, TempRes j a)
305 withReserved jobid genfn tr = do
306 x <- genfn (reserved tr)
307 (,) x `liftM` reserve jobid x tr
308
309 -- | Repeatedly tries to run a given monadic function until it succeeds
310 -- and the returned value is free to reserve.
311 -- If such a value is found, it's reserved and returned.
312 -- Otherwise fails with an error.
313 generate :: (MonadError GanetiException m, Show a, Ord a, Ord j)
314 => j -> S.Set a -> m (Maybe a) -> TempRes j a -> m (a, TempRes j a)
315 generate jobid existing genfn = withReserved jobid f
316 where
317 retries = 64 :: Int
318 f res = do
319 let vals = res `S.union` existing
320 xOpt <- retryMaybeN retries
321 (\_ -> mfilter (`S.notMember` vals) (MaybeT genfn))
322 maybe (resError "Not able generate new resource")
323 -- TODO: (last tried: " ++ %s)" % new_resource
324 return xOpt
325
326 -- | A variant of 'generate' for randomized computations.
327 generateRand
328 :: (MonadError GanetiException m, Show a, Ord a, Ord j, RandomGen g)
329 => g -> j -> S.Set a -> (g -> (Maybe a, g)) -> TempRes j a
330 -> m (a, TempRes j a)
331 generateRand rgen jobid existing genfn tr =
332 evalStateT (generate jobid existing (state genfn) tr) rgen
333
334 -- | Embeds a stateful computation in a stateful monad.
335 stateM :: (MonadState s m) => (s -> m (a, s)) -> m a
336 stateM f = get >>= f >>= \(x, s) -> liftM (const x) (put s)
337
338 -- | Embeds a state-modifying computation in a stateful monad.
339 modifyM :: (MonadState s m) => (s -> m s) -> m ()
340 modifyM f = get >>= f >>= put
341
342 -- ** Functions common to all reservations
343
344 -- | Removes all resources reserved by a given job.
345 --
346 -- If a new reservation resource type is added, it must be added here as well.
347 dropAllReservations :: ClientId -> State TempResState ()
348 dropAllReservations jobId = modify $
349 (trsMACsL %~ dropReservationsFor jobId)
350 . (trsDRBDSecretsL %~ dropReservationsFor jobId)
351 . (trsLVsL %~ dropReservationsFor jobId)
352 . (trsIPv4sL %~ dropReservationsFor jobId)
353
354 -- | Looks up a network by its UUID.
355 lookupNetwork :: (MonadError GanetiException m)
356 => ConfigData -> NetworkUUID -> m Network
357 lookupNetwork cd netId =
358 J.lookupContainer (resError $ "Network '" ++ show netId ++ "' not found")
359 netId (configNetworks cd)
360
361 -- ** IDs
362
363 -- ** MAC addresses
364
365 -- Randomly generate a MAC for an instance.
366 -- Checks that the generated MAC isn't used by another instance.
367 --
368 -- Note that we only consume, but not return the state of a random number
369 -- generator. This is because the whole operation needs to be pure (for atomic
370 -- 'IORef' updates) and therefore we can't use 'getStdRandom'. Therefore the
371 -- approach we take is to instead use 'newStdGen' and discard the split
372 -- generator afterwards.
373 generateMAC
374 :: (RandomGen g, MonadError GanetiException m, Functor m)
375 => g -> ClientId -> Maybe NetworkUUID -> ConfigData
376 -> StateT TempResState m MAC
377 generateMAC rgen jobId netId cd = do
378 net <- case netId of
379 Just n -> Just <$> lookupNetwork cd n
380 Nothing -> return Nothing
381 let prefix = fromMaybe (clusterMacPrefix . configCluster $ cd)
382 (networkMacPrefix =<< net)
383 let existing = S.fromList $ getAllMACs cd
384 StateT
385 $ traverseOf2 trsMACsL
386 (generateRand rgen jobId existing
387 (over _1 Just . generateOneMAC prefix))
388
389 -- Reserves a MAC for an instance in the list of temporary reservations.
390 reserveMAC
391 :: (MonadError GanetiException m, MonadState TempResState m, Functor m)
392 => ClientId -> MAC -> ConfigData -> m ()
393 reserveMAC jobId mac cd = do
394 let existing = S.fromList $ getAllMACs cd
395 when (S.member mac existing)
396 $ resError "MAC already in use"
397 modifyM $ traverseOf trsMACsL (reserve jobId mac)
398
399 -- ** DRBD secrets
400
401 generateDRBDSecret
402 :: (RandomGen g, MonadError GanetiException m, Functor m)
403 => g -> ClientId -> ConfigData -> StateT TempResState m DRBDSecret
404 generateDRBDSecret rgen jobId cd = do
405 let existing = S.fromList $ getAllDrbdSecrets cd
406 StateT $ traverseOf2 trsDRBDSecretsL
407 (generateRand rgen jobId existing
408 (over _1 Just . generateSecret C.drbdSecretLength))
409
410 -- ** LVs
411
412 reserveLV
413 :: (MonadError GanetiException m, MonadState TempResState m, Functor m)
414 => ClientId -> LogicalVolume -> ConfigData -> m ()
415 reserveLV jobId lv cd = do
416 existing <- toError $ getAllLVs cd
417 when (S.member lv existing)
418 $ resError "MAC already in use"
419 modifyM $ traverseOf trsLVsL (reserve jobId lv)
420
421 -- ** IPv4 addresses
422
423 -- | Lists all IPv4 addresses reserved for a given network.
424 usedIPv4Addrs :: NetworkUUID -> S.Set IPv4Reservation -> S.Set Ip4Address
425 usedIPv4Addrs netuuid =
426 S.map ipv4ResAddr . S.filter ((== netuuid) . ipv4ResNetwork)
427
428 -- | Reserve a given IPv4 address for use by an instance.
429 reserveIp
430 :: (MonadError GanetiException m, MonadState TempResState m, Functor m)
431 => ClientId -> NetworkUUID -> Ip4Address
432 -> Bool -- ^ whether to check externally reserved IPs
433 -> ConfigData -> m ()
434 reserveIp jobId netuuid addr checkExt cd = toResError $ do
435 net <- lookupNetwork cd netuuid
436 isres <- N.isReserved N.PoolInstances addr net
437 when isres . resError $ "IP address already in use"
438 when checkExt $ do
439 isextres <- N.isReserved N.PoolExt addr net
440 when isextres . resError $ "IP is externally reserved"
441 let action = IPv4Res IPv4Reserve netuuid addr
442 modifyM $ traverseOf trsIPv4sL (reserve jobId action)
443
444 -- | Give a specific IP address back to an IP pool.
445 -- The IP address is returned to the IP pool designated by network id
446 -- and marked as reserved.
447 releaseIp
448 :: (MonadError GanetiException m, MonadState TempResState m, Functor m)
449 => ClientId -> NetworkUUID -> Ip4Address -> m ()
450 releaseIp jobId netuuid addr =
451 let action = IPv4Res { ipv4ResAction = IPv4Release
452 , ipv4ResNetwork = netuuid
453 , ipv4ResAddr = addr }
454 in modifyM $ traverseOf trsIPv4sL (reserve jobId action)
455
456 -- Find a free IPv4 address for an instance and reserve it.
457 generateIp
458 :: (MonadError GanetiException m, MonadState TempResState m, Functor m)
459 => ClientId -> NetworkUUID -> ConfigData -> m Ip4Address
460 generateIp jobId netuuid cd = toResError $ do
461 net <- lookupNetwork cd netuuid
462 let f res = do
463 let ips = usedIPv4Addrs netuuid res
464 addr <- N.findFree (`S.notMember` ips) net
465 maybe (resError "Cannot generate IP. Network is full")
466 (return . IPv4Res IPv4Reserve netuuid) addr
467 liftM ipv4ResAddr . stateM $ traverseOf2 trsIPv4sL (withReserved jobId f)
468
469 -- | Commit a reserved/released IP address to an IP pool.
470 -- The IP address is taken from the network's IP pool and marked as
471 -- reserved/free for instances.
472 commitIp
473 :: (MonadError GanetiException m, Functor m)
474 => IPv4Reservation -> ConfigData -> m ConfigData
475 commitIp (IPv4Res actType netuuid addr) cd = toResError $ do
476 let call = case actType of
477 IPv4Reserve -> N.reserve
478 IPv4Release -> N.release
479 f Nothing = resError $ "Network '" ++ show netuuid ++ "' not found"
480 f (Just net) = Just `liftM` call N.PoolInstances addr net
481 traverseOf (configNetworksL . J.alterContainerL netuuid) f cd
482
483 -- | Immediately release an IP address, without using the reservations pool.
484 commitReleaseIp
485 :: (MonadError GanetiException m, Functor m)
486 => NetworkUUID -> Ip4Address -> ConfigData -> m ConfigData
487 commitReleaseIp netuuid addr =
488 commitIp (IPv4Res IPv4Release netuuid addr)
489
490 -- | Commit all reserved/released IP address to an IP pool.
491 -- The IP addresses are taken from the network's IP pool and marked as
492 -- reserved/free for instances.
493 --
494 -- Note that the reservations are kept, they are supposed to be cleaned
495 -- when a job finishes.
496 commitReservedIps
497 :: (MonadError GanetiException m, Functor m, MonadLog m)
498 => ClientId -> TempResState -> ConfigData -> m ConfigData
499 commitReservedIps jobId tr cd = do
500 let res = reservedFor jobId (trsIPv4s tr)
501 logDebug $ "Commiting reservations: " ++ show res
502 F.foldrM commitIp cd res
503
504 listReservedIps :: ClientId -> TempResState -> S.Set IPv4Reservation
505 listReservedIps jobid = reservedFor jobid . trsIPv4s