TempRes.hs 10.3 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
{-# LANGUAGE TemplateHaskell, RankNTypes, FlexibleContexts #-}

{-| Pure functions for manipulating reservations of temporary objects

-}

{-

Copyright (C) 2014 Google Inc.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

module Ganeti.WConfd.TempRes
  ( TempResState(..)
  , emptyTempResState
  , NodeUUID
  , InstanceUUID
33
  , NetworkUUID
34
35
36
37
38
39
40
  , DRBDMinor
  , DRBDMap
  , trsDRBDL
  , computeDRBDMap
  , computeDRBDMap'
  , allocateDRBDMinor
  , releaseDRBDMinors
41
42
43
  , MAC
  , generateMAC
  , reserveMAC
44
  , generateDRBDSecret
45
46
47
48
49
50
  , dropAllReservations
  , isReserved
  , reserve
  , dropReservationsFor
  , reserved
  , generate
51
52
  ) where

53
import Control.Applicative
54
55
56
import Control.Lens.At
import Control.Monad.Error
import Control.Monad.State
57
import Control.Monad.Trans.Maybe
58
59
60
61
62
63
import qualified Data.Foldable as F
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as M
import Data.Monoid
import qualified Data.Set as S
64
import System.Random
65
66
67

import Ganeti.BasicTypes
import Ganeti.Config
68
import qualified Ganeti.Constants as C
69
70
71
import Ganeti.Errors
import qualified Ganeti.JSON as J
import Ganeti.Lens
72
import Ganeti.Locking.Locks (ClientId)
73
74
import Ganeti.Objects
import Ganeti.Utils
75
import Ganeti.Utils.MonadPlus
76
import Ganeti.Utils.Random
77
import qualified Ganeti.Utils.MultiMap as MM
78
79
80
81
82
83
84
85
86

-- * The main reservation state

-- ** Aliases to make types more meaningful:

type NodeUUID = String

type InstanceUUID = String

87
88
type NetworkUUID = String

89
90
91
92
93
94
95
96
97
98
type DRBDMinor = Int

-- | A map of the usage of DRBD minors
type DRBDMap = Map NodeUUID (Map DRBDMinor InstanceUUID)

-- | A map of the usage of DRBD minors with possible duplicates
type DRBDMap' = Map NodeUUID (Map DRBDMinor [InstanceUUID])

-- * The state data structure

99
100
101
102
103
104
105
106
107
-- | A polymorphic data structure for managing temporary resources assigned
-- to jobs.
newtype TempRes j a = TempRes { getTempRes :: MM.MultiMap j a }
  deriving (Eq, Ord, Show)

instance (Ord j, Ord a) => Monoid (TempRes j a) where
  mempty = TempRes mempty
  mappend (TempRes x) (TempRes y) = TempRes $ x <> y

108
109
110
-- | The state of the temporary reservations
data TempResState = TempResState
  { trsDRBD :: DRBDMap
111
  , trsMACs :: TempRes ClientId MAC
112
  , trsDRBDSecrets :: TempRes ClientId DRBDSecret
113
114
115
116
  }
  deriving (Eq, Show)

emptyTempResState :: TempResState
117
emptyTempResState = TempResState M.empty mempty mempty
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195

$(makeCustomLenses ''TempResState)

-- ** Utility functions

-- | Filter values from the nested map and remove any nested maps
-- that become empty.
filterNested :: (Ord a, Ord b)
             => (c -> Bool) -> Map a (Map b c) -> Map a (Map b c)
filterNested p = M.filter (not . M.null) . fmap (M.filter p)

-- * DRBDs

-- | Converts a lens that works on maybe values into a lens that works
-- on regular ones. A missing value on the input is replaced by
-- 'mempty'.
-- The output is is @Just something@ iff @something /= mempty@.
maybeLens :: (Monoid a, Monoid b, Eq b)
          => Lens s t (Maybe a) (Maybe b) -> Lens s t a b
maybeLens l f = l (fmap (mfilter (/= mempty) . Just) . f . fromMaybe mempty)

-- * DRBD functions

-- | Compute the map of used DRBD minor/nodes, including possible
-- duplicates.
-- An error is returned if the configuration isn't consistent
-- (for example if a referenced disk is missing etc.).
computeDRBDMap' :: (MonadError GanetiException m)
                => ConfigData -> TempResState -> m DRBDMap'
computeDRBDMap' cfg trs =
    flip execStateT (fmap (fmap (: [])) (trsDRBD trs))
    $ F.forM_ (configInstances cfg) addDisks
  where
    -- | Creates a lens for modifying the list of instances
    nodeMinor :: NodeUUID -> DRBDMinor -> Lens' DRBDMap' [InstanceUUID]
    nodeMinor node minor = maybeLens (at node) . maybeLens (at minor)
    -- | Adds disks of an instance within the state monad
    addDisks inst = do
                      disks <- toError $ getDrbdMinorsForInstance cfg inst
                      forM_ disks $ \(minor, node) -> nodeMinor node minor
                                                          %= (uuidOf inst :)

-- | Compute the map of used DRBD minor/nodes.
-- Report any duplicate entries as an error.
--
-- Unlike 'computeDRBDMap'', includes entries for all nodes, even if empty.
computeDRBDMap :: (MonadError GanetiException m)
               => ConfigData -> TempResState -> m DRBDMap
computeDRBDMap cfg trs = do
  m <- computeDRBDMap' cfg trs
  let dups = filterNested ((>= 2) . length) m
  unless (M.null dups) . failError
    $ "Duplicate DRBD ports detected: " ++ show (M.toList $ fmap M.toList dups)
  return $ fmap (fmap head . M.filter ((== 1) . length)) m
           `M.union` (fmap (const mempty) . J.fromContainer . configNodes $ cfg)

-- Allocate a drbd minor.
--
-- The free minor will be automatically computed from the existing devices.
-- A node can be given multiple times in order to allocate multiple minors.
-- The result is the list of minors, in the same order as the passed nodes.
allocateDRBDMinor :: (MonadError GanetiException m, MonadState TempResState m)
                  => ConfigData -> InstanceUUID -> [NodeUUID]
                  -> m [DRBDMinor]
allocateDRBDMinor cfg inst nodes = do
  dMap <- computeDRBDMap' cfg =<< get
  let usedMap = fmap M.keysSet dMap
  let alloc :: S.Set DRBDMinor -> Map DRBDMinor InstanceUUID
            -> (DRBDMinor, Map DRBDMinor InstanceUUID)
      alloc used m = let k = findFirst 0 (M.keysSet m `S.union` used)
                      in (k, M.insert k inst m)
  forM nodes $ \node -> trsDRBDL . maybeLens (at node)
                        %%= alloc (M.findWithDefault mempty node usedMap)

-- Release temporary drbd minors allocated for a given instance using
-- 'allocateDRBDMinor'.
releaseDRBDMinors :: (MonadState TempResState m) => InstanceUUID -> m ()
releaseDRBDMinors inst = trsDRBDL %= filterNested (/= inst)
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241

-- * Other temporary resources

-- | Tests if a given value is reserved for a given job.
isReserved :: (Ord a, Ord j) => a -> TempRes j a -> Bool
isReserved x = MM.elem x . getTempRes

-- | Tries to reserve a given value for a given job.
reserve :: (MonadError e m, Error e, Show a, Ord a, Ord j)
        => j -> a -> TempRes j a -> m (TempRes j a)
reserve jobid x tr = do
  when (isReserved x tr) . failError $ "Duplicate reservation for resource '"
                                       ++ show x ++ "'"
  return . TempRes . MM.insert jobid x $ getTempRes tr

dropReservationsFor :: (Ord a, Ord j) => j -> TempRes j a -> TempRes j a
dropReservationsFor jobid = TempRes . MM.deleteAll jobid . getTempRes

reserved :: (Ord a, Ord j) => TempRes j a -> S.Set a
reserved = MM.values . getTempRes

generate :: (MonadError e m, Error e, Show a, Ord a, Ord j)
         => j -> S.Set a -> m (Maybe a) -> TempRes j a -> m (a, TempRes j a)
generate jobid existing genfn tr = do
  let retries = 64
  let vals = reserved tr `S.union` existing
  xOpt <- retryMaybeN retries
                      (\_ -> mfilter (`S.notMember` vals) (MaybeT genfn))
  case xOpt of
    Nothing -> failError "Not able generate new resource"
                         -- TODO: (last tried: " ++ %s)" % new_resource
    Just x  -> (,) x `liftM` reserve jobid x tr

-- | A variant of 'generate' for randomized computations.
generateRand :: (MonadError e m, Error e, Show a, Ord a, Ord j, RandomGen g)
             => g -> j -> S.Set a -> (g -> (Maybe a, g)) -> TempRes j a
             -> m (a, TempRes j a)
generateRand rgen jobid existing genfn tr =
  evalStateT (generate jobid existing (state genfn) tr) rgen

-- ** Functions common to all reservations

-- | Removes all resources reserved by a given job.
--
-- If a new reservation resource type is added, it must be added here as well.
dropAllReservations :: ClientId -> TempResState -> TempResState
242
243
244
dropAllReservations jobId =
    (trsMACsL %~ dropReservationsFor jobId)
  . (trsDRBDSecretsL %~ dropReservationsFor jobId)
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284

-- ** IDs

-- ** MAC addresses

-- Randomly generate a MAC for an instance.
-- Checks that the generated MAC isn't used by another instance.
--
-- Note that we only consume, but not return the state of a random number
-- generator. This is because the whole operation needs to be pure (for atomic
-- 'IORef' updates) and therefore we can't use 'getStdRandom'. Therefore the
-- approach we take is to instead use 'newStdGen' and discard the split
-- generator afterwards.
generateMAC
  :: (RandomGen g, MonadError e m, Error e, Functor m)
  => g -> ClientId -> Maybe NetworkUUID -> ConfigData
  -> StateT TempResState m MAC
generateMAC rgen jobId netId cd = do
  net <- case netId of
    Just n -> Just <$> J.lookupContainer (failError $ "Network '" ++ show netId
                                             ++ "' not found")
                                         n (configNetworks cd)
    Nothing -> return Nothing
  let prefix = fromMaybe (clusterMacPrefix . configCluster $ cd)
                         (networkMacPrefix =<< net)
  let existing = S.fromList $ getAllMACs cd
  StateT
    $ traverseOf2 trsMACsL
        (generateRand rgen jobId existing
                      (over _1 Just . generateOneMAC prefix))

-- Reserves a MAC for an instance in the list of temporary reservations.
reserveMAC
  :: (MonadError GanetiException m, MonadState TempResState m, Functor m)
  => ClientId -> MAC -> ConfigData -> m ()
reserveMAC jobId mac cd = do
  let existing = S.fromList $ getAllMACs cd
  when (S.member mac existing)
    $ throwError (ReservationError "MAC already in use")
  get >>= traverseOf trsMACsL (reserve jobId mac) >>= put
285
286
287
288
289
290
291
292
293
294
295

-- ** DRBD secrets

generateDRBDSecret
  :: (RandomGen g, MonadError e m, Error e, Functor m)
  => g -> ClientId -> ConfigData -> StateT TempResState m DRBDSecret
generateDRBDSecret rgen jobId cd = do
  let existing = S.fromList $ getAllDrbdSecrets cd
  StateT $ traverseOf2 trsDRBDSecretsL
           (generateRand rgen jobId existing
                         (over _1 Just . generateSecret C.drbdSecretLength))