Fix computation in network blocks
[ganeti-github.git] / src / Ganeti / Network.hs
1 {-# LANGUAGE RankNTypes #-}
2
3 {-| Implementation of the Ganeti network objects.
4
5 This is does not (yet) cover all methods that are provided in the
6 corresponding python implementation (network.py).
7
8 -}
9
10 {-
11
12 Copyright (C) 2011, 2012, 2013 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.Network
41 ( PoolPart(..)
42 , netIpv4NumHosts
43 , ip4BaseAddr
44 , getReservedCount
45 , getFreeCount
46 , isFull
47 , getMap
48 , isReserved
49 , reserve
50 , release
51 , findFree
52 , allReservations
53 , reservations
54 , extReservations
55 ) where
56
57 import Control.Monad
58 import Control.Monad.Error
59 import Control.Monad.State
60 import Data.Bits ((.&.))
61 import Data.Function (on)
62
63 import Ganeti.BasicTypes
64 import qualified Ganeti.Constants as C
65 import Ganeti.Lens
66 import Ganeti.Objects
67 import Ganeti.Objects.Lens
68 import qualified Ganeti.Objects.BitArray as BA
69
70 ip4BaseAddr :: Ip4Network -> Ip4Address
71 ip4BaseAddr net =
72 let m = ip4netMask net
73 mask = 2^(32 :: Integer) - 2^(32 - m)
74 in ip4AddressFromNumber . (.&.) mask . ip4AddressToNumber $ ip4netAddr net
75
76 ipv4NumHosts :: (Integral n) => n -> Integer
77 ipv4NumHosts mask = 2^(32 - mask)
78
79 ipv4NetworkMinNumHosts :: Integer
80 ipv4NetworkMinNumHosts = ipv4NumHosts C.ipv4NetworkMinSize
81
82 ipv4NetworkMaxNumHosts :: Integer
83 ipv4NetworkMaxNumHosts = ipv4NumHosts C.ipv4NetworkMaxSize
84
85 data PoolPart = PoolInstances | PoolExt
86
87 addressPoolIso :: Iso' AddressPool BA.BitArray
88 addressPoolIso = iso apReservations AddressPool
89
90 poolLens :: PoolPart -> Lens' Network (Maybe AddressPool)
91 poolLens PoolInstances = networkReservationsL
92 poolLens PoolExt = networkExtReservationsL
93
94 poolArrayLens :: PoolPart -> Lens' Network (Maybe BA.BitArray)
95 poolArrayLens part = poolLens part . mapping addressPoolIso
96
97 netIpv4NumHosts :: Network -> Integer
98 netIpv4NumHosts = ipv4NumHosts . ip4netMask . networkNetwork
99
100 -- | Creates a new bit array pool of the appropriate size
101 newPoolArray :: (MonadError e m, Error e) => Network -> m BA.BitArray
102 newPoolArray net = do
103 let numhosts = netIpv4NumHosts net
104 when (numhosts > ipv4NetworkMaxNumHosts) . failError $
105 "A big network with " ++ show numhosts ++ " host(s) is currently"
106 ++ " not supported, please specify at most a /"
107 ++ show ipv4NetworkMaxNumHosts ++ " network"
108 when (numhosts < ipv4NetworkMinNumHosts) . failError $
109 "A network with only " ++ show numhosts ++ " host(s) is too small,"
110 ++ " please specify at least a /"
111 ++ show ipv4NetworkMinNumHosts ++ " network"
112 return $ BA.zeroes (fromInteger numhosts)
113
114 -- | Creates a new bit array pool of the appropriate size
115 newPool :: (MonadError e m, Error e) => Network -> m AddressPool
116 newPool = liftM AddressPool . newPoolArray
117
118 -- | A helper function that creates a bit array pool, of it's missing.
119 orNewPool :: (MonadError e m, Error e)
120 => Network -> Maybe AddressPool -> m AddressPool
121 orNewPool net = maybe (newPool net) return
122
123 withPool :: (MonadError e m, Error e)
124 => PoolPart -> (Network -> BA.BitArray -> m (a, BA.BitArray))
125 -> StateT Network m a
126 withPool part f = StateT $ \n -> mapMOf2 (poolLens part) (f' n) n
127 where
128 f' net = liftM (over _2 Just)
129 . mapMOf2 addressPoolIso (f net)
130 <=< orNewPool net
131
132 withPool_ :: (MonadError e m, Error e)
133 => PoolPart -> (Network -> BA.BitArray -> m BA.BitArray)
134 -> Network -> m Network
135 withPool_ part f = execStateT $ withPool part ((liftM ((,) ()) .) . f)
136
137 readPool :: PoolPart -> Network -> Maybe BA.BitArray
138 readPool = view . poolArrayLens
139
140 readPoolE :: (MonadError e m, Error e)
141 => PoolPart -> Network -> m BA.BitArray
142 readPoolE part net =
143 liftM apReservations $ orNewPool net ((view . poolLens) part net)
144
145 readAllE :: (MonadError e m, Error e)
146 => Network -> m BA.BitArray
147 readAllE net = do
148 let toRes = liftM apReservations . orNewPool net
149 res <- toRes $ networkReservations net
150 ext <- toRes $ networkExtReservations net
151 return $ res BA.-|- ext
152
153 reservations :: Network -> Maybe BA.BitArray
154 reservations = readPool PoolInstances
155
156 extReservations :: Network -> Maybe BA.BitArray
157 extReservations = readPool PoolExt
158
159 -- | Get a bit vector of all reservations (internal and external) combined.
160 allReservations :: Network -> Maybe BA.BitArray
161 allReservations a = (BA.-|-) `liftM` reservations a `ap` extReservations a
162
163 -- | Get the count of reserved addresses.
164 getReservedCount :: Network -> Int
165 getReservedCount = maybe 0 BA.count1 . allReservations
166
167 -- | Get the count of free addresses.
168 getFreeCount :: Network -> Int
169 getFreeCount = maybe 0 BA.count0 . allReservations
170
171 -- | Check whether the network is full.
172 isFull :: Network -> Bool
173 isFull = (0 ==) . getFreeCount
174
175 -- | Return a textual representation of the network's occupation status.
176 getMap :: Network -> String
177 getMap = maybe "" (BA.asString '.' 'X') . allReservations
178
179 -- * Functions used for manipulating the reservations
180
181 -- | Returns an address index wrt a network.
182 -- Fails if the address isn't in the network range.
183 addrIndex :: (MonadError e m, Error e) => Ip4Address -> Network -> m Int
184 addrIndex addr net = do
185 let n = networkNetwork net
186 i = on (-) ip4AddressToNumber addr (ip4BaseAddr n)
187 when ((i < 0) || (i >= ipv4NumHosts (ip4netMask n))) . failError
188 $ "Address '" ++ show addr ++ "' not in the network '" ++ show net ++ "'"
189 return $ fromInteger i
190
191 -- | Returns an address of a given index wrt a network.
192 -- Fails if the index isn't in the network range.
193 addrAt :: (MonadError e m, Error e) => Int -> Network -> m Ip4Address
194 addrAt i net | (i' < 0) || (i' >= ipv4NumHosts (ip4netMask n)) =
195 failError $ "Requested index " ++ show i
196 ++ " outside the range of network '" ++ show net ++ "'"
197 | otherwise =
198 return $ ip4AddressFromNumber (ip4AddressToNumber (ip4BaseAddr n) + i')
199 where
200 n = networkNetwork net
201 i' = toInteger i
202
203 -- | Checks if a given address is reserved.
204 -- Fails if the address isn't in the network range.
205 isReserved :: (MonadError e m, Error e) =>
206 PoolPart -> Ip4Address -> Network -> m Bool
207 isReserved part addr net =
208 (BA.!) `liftM` readPoolE part net `ap` addrIndex addr net
209
210 -- | Marks an address as used.
211 reserve :: (MonadError e m, Error e) =>
212 PoolPart -> Ip4Address -> Network -> m Network
213 reserve part addr =
214 withPool_ part $ \net ba -> do
215 idx <- addrIndex addr net
216 let addrs = show addr
217 when (ba BA.! idx) . failError $ case part of
218 PoolExt -> "IP " ++ addrs ++ " is already externally reserved"
219 PoolInstances -> "IP " ++ addrs ++ " is already used by an instance"
220 BA.setAt idx True ba
221
222 -- | Marks an address as unused.
223 release :: (MonadError e m, Error e) =>
224 PoolPart -> Ip4Address -> Network -> m Network
225 release part addr =
226 withPool_ part $ \net ba -> do
227 idx <- addrIndex addr net
228 let addrs = show addr
229 unless (ba BA.! idx) . failError $ case part of
230 PoolExt -> "IP " ++ addrs ++ " is not externally reserved"
231 PoolInstances -> "IP " ++ addrs ++ " is not used by an instance"
232 BA.setAt idx False ba
233
234 -- | Get the first free address in the network
235 -- that satisfies a given predicate.
236 findFree :: (MonadError e m, Error e)
237 => (Ip4Address -> Bool) -> Network -> m (Maybe Ip4Address)
238 findFree p net = readAllE net >>= BA.foldr f (return Nothing)
239 where
240 addrAtEither = addrAt :: Int -> Network -> Either String Ip4Address
241 f False i _ | Right a <- addrAtEither i net, p a = return (Just a)
242 f _ _ x = x