Store keys as ByteStrings
[ganeti-github.git] / src / Ganeti / WConfd / ConfigVerify.hs
1 {-# LANGUAGE FlexibleContexts #-}
2
3 {-| Implementation of functions specific to configuration management.
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.WConfd.ConfigVerify
38 ( verifyConfig
39 , verifyConfigErr
40 ) where
41
42 import Control.Monad.Error
43 import qualified Data.ByteString.UTF8 as UTF8
44 import qualified Data.Foldable as F
45 import qualified Data.Map as M
46 import qualified Data.Set as S
47
48 import Ganeti.Errors
49 import Ganeti.JSON (GenericContainer(..), Container)
50 import Ganeti.Objects
51 import Ganeti.Types
52 import Ganeti.Utils
53 import Ganeti.Utils.Validate
54
55 -- * Configuration checks
56
57 -- | A helper function that returns the key set of a container.
58 keysSet :: (Ord k) => GenericContainer k v -> S.Set k
59 keysSet = M.keysSet . fromContainer
60
61 -- | Checks that all objects are indexed by their proper UUID.
62 checkUUIDKeys :: (UuidObject a, Show a)
63 => String -> Container a -> ValidationMonad ()
64 checkUUIDKeys what = mapM_ check . M.toList . fromContainer
65 where
66 check (uuid, x) = reportIf (uuid /= UTF8.fromString (uuidOf x))
67 $ what ++ " '" ++ show x
68 ++ "' is indexed by wrong UUID '"
69 ++ UTF8.toString uuid ++ "'"
70
71 -- | Checks that all linked UUID of given objects exist.
72 checkUUIDRefs :: (UuidObject a, Show a, F.Foldable f)
73 => String -> String
74 -> (a -> [String]) -> f a -> Container b
75 -> ValidationMonad ()
76 checkUUIDRefs whatObj whatTarget linkf xs targets = F.mapM_ check xs
77 where
78 uuids = keysSet targets
79 check x = forM_ (linkf x) $ \uuid ->
80 reportIf (not $ S.member (UTF8.fromString uuid) uuids)
81 $ whatObj ++ " '" ++ show x ++ "' references a non-existing "
82 ++ whatTarget ++ " UUID '" ++ uuid ++ "'"
83
84 -- | Checks consistency of a given configuration.
85 --
86 -- TODO: Currently this implements only some very basic checks.
87 -- Evenually all checks from Python ConfigWriter need to be moved here
88 -- (see issue #759).
89 verifyConfig :: ConfigData -> ValidationMonad ()
90 verifyConfig cd = do
91 let cluster = configCluster cd
92 nodes = configNodes cd
93 nodegroups = configNodegroups cd
94 instances = configInstances cd
95 networks = configNetworks cd
96 disks = configDisks cd
97
98 -- global cluster checks
99 let enabledHvs = clusterEnabledHypervisors cluster
100 hvParams = clusterHvparams cluster
101 reportIf (null enabledHvs)
102 "enabled hypervisors list doesn't have any entries"
103 -- we don't need to check for invalid HVS as they would fail to parse
104 let missingHvp = S.fromList enabledHvs S.\\ keysSet hvParams
105 reportIf (not $ S.null missingHvp)
106 $ "hypervisor parameters missing for the enabled hypervisor(s) "
107 ++ (commaJoin . map hypervisorToRaw . S.toList $ missingHvp)
108
109 let enabledDiskTemplates = clusterEnabledDiskTemplates cluster
110 reportIf (null enabledDiskTemplates)
111 "enabled disk templates list doesn't have any entries"
112 -- we don't need to check for invalid templates as they wouldn't parse
113
114 let masterNodeName = clusterMasterNode cluster
115 reportIf (not $ UTF8.fromString masterNodeName
116 `S.member` keysSet (configNodes cd))
117 $ "cluster has invalid primary node " ++ masterNodeName
118
119 -- UUIDs
120 checkUUIDKeys "node" nodes
121 checkUUIDKeys "nodegroup" nodegroups
122 checkUUIDKeys "instances" instances
123 checkUUIDKeys "network" networks
124 checkUUIDKeys "disk" disks
125 -- UUID references
126 checkUUIDRefs "node" "nodegroup" (return . nodeGroup) nodes nodegroups
127 checkUUIDRefs "instance" "primary node" (maybe [] return . instPrimaryNode)
128 instances nodes
129 checkUUIDRefs "instance" "disks" instDisks instances disks
130
131 -- | Checks consistency of a given configuration.
132 -- If there is an error, throw 'ConfigVerifyError'.
133 verifyConfigErr :: (MonadError GanetiException m) => ConfigData -> m ()
134 verifyConfigErr cd =
135 case runValidate $ verifyConfig cd of
136 (_, []) -> return ()
137 (_, es) -> throwError $ ConfigVerifyError "Validation failed" es