root / htools / Ganeti / OpCodes.hs @ 37904802
History | View | Annotate | Download (5.9 kB)
1 | e9aaa3c6 | Iustin Pop | {-# LANGUAGE TemplateHaskell #-} |
---|---|---|---|
2 | e9aaa3c6 | Iustin Pop | |
3 | 702a4ee0 | Iustin Pop | {-| Implementation of the opcodes. |
4 | 702a4ee0 | Iustin Pop | |
5 | 702a4ee0 | Iustin Pop | -} |
6 | 702a4ee0 | Iustin Pop | |
7 | 702a4ee0 | Iustin Pop | {- |
8 | 702a4ee0 | Iustin Pop | |
9 | a583ec5d | Iustin Pop | Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
10 | 702a4ee0 | Iustin Pop | |
11 | 702a4ee0 | Iustin Pop | This program is free software; you can redistribute it and/or modify |
12 | 702a4ee0 | Iustin Pop | it under the terms of the GNU General Public License as published by |
13 | 702a4ee0 | Iustin Pop | the Free Software Foundation; either version 2 of the License, or |
14 | 702a4ee0 | Iustin Pop | (at your option) any later version. |
15 | 702a4ee0 | Iustin Pop | |
16 | 702a4ee0 | Iustin Pop | This program is distributed in the hope that it will be useful, but |
17 | 702a4ee0 | Iustin Pop | WITHOUT ANY WARRANTY; without even the implied warranty of |
18 | 702a4ee0 | Iustin Pop | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
19 | 702a4ee0 | Iustin Pop | General Public License for more details. |
20 | 702a4ee0 | Iustin Pop | |
21 | 702a4ee0 | Iustin Pop | You should have received a copy of the GNU General Public License |
22 | 702a4ee0 | Iustin Pop | along with this program; if not, write to the Free Software |
23 | 702a4ee0 | Iustin Pop | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
24 | 702a4ee0 | Iustin Pop | 02110-1301, USA. |
25 | 702a4ee0 | Iustin Pop | |
26 | 702a4ee0 | Iustin Pop | -} |
27 | 702a4ee0 | Iustin Pop | |
28 | 702a4ee0 | Iustin Pop | module Ganeti.OpCodes |
29 | ebf38064 | Iustin Pop | ( OpCode(..) |
30 | 367c4241 | Dato Simó | , TagObject(..) |
31 | d8e7c45e | Iustin Pop | , tagObjectFrom |
32 | d8e7c45e | Iustin Pop | , encodeTagObject |
33 | d8e7c45e | Iustin Pop | , decodeTagObject |
34 | ebf38064 | Iustin Pop | , ReplaceDisksMode(..) |
35 | 4a1dc2bf | Iustin Pop | , DiskIndex |
36 | 4a1dc2bf | Iustin Pop | , mkDiskIndex |
37 | 4a1dc2bf | Iustin Pop | , unDiskIndex |
38 | ebf38064 | Iustin Pop | , opID |
39 | a583ec5d | Iustin Pop | , allOpIDs |
40 | ebf38064 | Iustin Pop | ) where |
41 | 702a4ee0 | Iustin Pop | |
42 | d8e7c45e | Iustin Pop | import Text.JSON (readJSON, showJSON, makeObj, JSON, JSValue(..), fromJSString) |
43 | d8e7c45e | Iustin Pop | import Text.JSON.Pretty (pp_value) |
44 | 702a4ee0 | Iustin Pop | |
45 | e9aaa3c6 | Iustin Pop | import qualified Ganeti.Constants as C |
46 | 12c19659 | Iustin Pop | import Ganeti.THH |
47 | e9aaa3c6 | Iustin Pop | |
48 | f3baf5ef | Iustin Pop | import Ganeti.JSON |
49 | 702a4ee0 | Iustin Pop | |
50 | 367c4241 | Dato Simó | -- | Data type representing what items do the tag operations apply to. |
51 | d8e7c45e | Iustin Pop | $(declareSADT "TagType" |
52 | d8e7c45e | Iustin Pop | [ ("TagTypeInstance", 'C.tagInstance) |
53 | d8e7c45e | Iustin Pop | , ("TagTypeNode", 'C.tagNode) |
54 | d8e7c45e | Iustin Pop | , ("TagTypeGroup", 'C.tagNodegroup) |
55 | d8e7c45e | Iustin Pop | , ("TagTypeCluster", 'C.tagCluster) |
56 | 367c4241 | Dato Simó | ]) |
57 | d8e7c45e | Iustin Pop | $(makeJSONInstance ''TagType) |
58 | d8e7c45e | Iustin Pop | |
59 | d8e7c45e | Iustin Pop | -- | Data type holding a tag object (type and object name). |
60 | d8e7c45e | Iustin Pop | data TagObject = TagInstance String |
61 | d8e7c45e | Iustin Pop | | TagNode String |
62 | d8e7c45e | Iustin Pop | | TagGroup String |
63 | d8e7c45e | Iustin Pop | | TagCluster |
64 | d8e7c45e | Iustin Pop | deriving (Show, Read, Eq) |
65 | d8e7c45e | Iustin Pop | |
66 | d8e7c45e | Iustin Pop | -- | Tag type for a given tag object. |
67 | d8e7c45e | Iustin Pop | tagTypeOf :: TagObject -> TagType |
68 | d8e7c45e | Iustin Pop | tagTypeOf (TagInstance {}) = TagTypeInstance |
69 | d8e7c45e | Iustin Pop | tagTypeOf (TagNode {}) = TagTypeNode |
70 | d8e7c45e | Iustin Pop | tagTypeOf (TagGroup {}) = TagTypeGroup |
71 | d8e7c45e | Iustin Pop | tagTypeOf (TagCluster {}) = TagTypeCluster |
72 | d8e7c45e | Iustin Pop | |
73 | d8e7c45e | Iustin Pop | -- | Gets the potential tag object name. |
74 | d8e7c45e | Iustin Pop | tagNameOf :: TagObject -> Maybe String |
75 | d8e7c45e | Iustin Pop | tagNameOf (TagInstance s) = Just s |
76 | d8e7c45e | Iustin Pop | tagNameOf (TagNode s) = Just s |
77 | d8e7c45e | Iustin Pop | tagNameOf (TagGroup s) = Just s |
78 | d8e7c45e | Iustin Pop | tagNameOf TagCluster = Nothing |
79 | d8e7c45e | Iustin Pop | |
80 | d8e7c45e | Iustin Pop | -- | Builds a 'TagObject' from a tag type and name. |
81 | d8e7c45e | Iustin Pop | tagObjectFrom :: (Monad m) => TagType -> JSValue -> m TagObject |
82 | d8e7c45e | Iustin Pop | tagObjectFrom TagTypeInstance (JSString s) = |
83 | d8e7c45e | Iustin Pop | return . TagInstance $ fromJSString s |
84 | d8e7c45e | Iustin Pop | tagObjectFrom TagTypeNode (JSString s) = return . TagNode $ fromJSString s |
85 | d8e7c45e | Iustin Pop | tagObjectFrom TagTypeGroup (JSString s) = return . TagGroup $ fromJSString s |
86 | d8e7c45e | Iustin Pop | tagObjectFrom TagTypeCluster JSNull = return TagCluster |
87 | d8e7c45e | Iustin Pop | tagObjectFrom t v = |
88 | d8e7c45e | Iustin Pop | fail $ "Invalid tag type/name combination: " ++ show t ++ "/" ++ |
89 | d8e7c45e | Iustin Pop | show (pp_value v) |
90 | d8e7c45e | Iustin Pop | |
91 | d8e7c45e | Iustin Pop | -- | Name of the tag \"name\" field. |
92 | d8e7c45e | Iustin Pop | tagNameField :: String |
93 | d8e7c45e | Iustin Pop | tagNameField = "name" |
94 | d8e7c45e | Iustin Pop | |
95 | d8e7c45e | Iustin Pop | -- | Custom encoder for 'TagObject' as represented in an opcode. |
96 | d8e7c45e | Iustin Pop | encodeTagObject :: TagObject -> (JSValue, [(String, JSValue)]) |
97 | d8e7c45e | Iustin Pop | encodeTagObject t = ( showJSON (tagTypeOf t) |
98 | d8e7c45e | Iustin Pop | , [(tagNameField, maybe JSNull showJSON (tagNameOf t))] ) |
99 | d8e7c45e | Iustin Pop | |
100 | d8e7c45e | Iustin Pop | -- | Custom decoder for 'TagObject' as represented in an opcode. |
101 | d8e7c45e | Iustin Pop | decodeTagObject :: (Monad m) => [(String, JSValue)] -> JSValue -> m TagObject |
102 | d8e7c45e | Iustin Pop | decodeTagObject obj kind = do |
103 | d8e7c45e | Iustin Pop | ttype <- fromJVal kind |
104 | d8e7c45e | Iustin Pop | tname <- fromObj obj tagNameField |
105 | d8e7c45e | Iustin Pop | tagObjectFrom ttype tname |
106 | 367c4241 | Dato Simó | |
107 | 525bfb36 | Iustin Pop | -- | Replace disks type. |
108 | 12c19659 | Iustin Pop | $(declareSADT "ReplaceDisksMode" |
109 | ebf38064 | Iustin Pop | [ ("ReplaceOnPrimary", 'C.replaceDiskPri) |
110 | ebf38064 | Iustin Pop | , ("ReplaceOnSecondary", 'C.replaceDiskSec) |
111 | ebf38064 | Iustin Pop | , ("ReplaceNewSecondary", 'C.replaceDiskChg) |
112 | ebf38064 | Iustin Pop | , ("ReplaceAuto", 'C.replaceDiskAuto) |
113 | ebf38064 | Iustin Pop | ]) |
114 | 12c19659 | Iustin Pop | $(makeJSONInstance ''ReplaceDisksMode) |
115 | 702a4ee0 | Iustin Pop | |
116 | 4a1dc2bf | Iustin Pop | -- | Disk index type (embedding constraints on the index value via a |
117 | 4a1dc2bf | Iustin Pop | -- smart constructor). |
118 | 4a1dc2bf | Iustin Pop | newtype DiskIndex = DiskIndex { unDiskIndex :: Int } |
119 | 4a1dc2bf | Iustin Pop | deriving (Show, Read, Eq, Ord) |
120 | 4a1dc2bf | Iustin Pop | |
121 | 4a1dc2bf | Iustin Pop | -- | Smart constructor for 'DiskIndex'. |
122 | 4a1dc2bf | Iustin Pop | mkDiskIndex :: (Monad m) => Int -> m DiskIndex |
123 | 4a1dc2bf | Iustin Pop | mkDiskIndex i | i >= 0 && i < C.maxDisks = return (DiskIndex i) |
124 | 4a1dc2bf | Iustin Pop | | otherwise = fail $ "Invalid value for disk index '" ++ |
125 | 4a1dc2bf | Iustin Pop | show i ++ "', required between 0 and " ++ |
126 | 4a1dc2bf | Iustin Pop | show C.maxDisks |
127 | 4a1dc2bf | Iustin Pop | |
128 | 4a1dc2bf | Iustin Pop | instance JSON DiskIndex where |
129 | 4a1dc2bf | Iustin Pop | readJSON v = readJSON v >>= mkDiskIndex |
130 | 4a1dc2bf | Iustin Pop | showJSON = showJSON . unDiskIndex |
131 | 4a1dc2bf | Iustin Pop | |
132 | 525bfb36 | Iustin Pop | -- | OpCode representation. |
133 | 525bfb36 | Iustin Pop | -- |
134 | 3bebda52 | Dato Simó | -- We only implement a subset of Ganeti opcodes: those which are actually used |
135 | 3bebda52 | Dato Simó | -- in the htools codebase. |
136 | 12c19659 | Iustin Pop | $(genOpCode "OpCode" |
137 | ebf38064 | Iustin Pop | [ ("OpTestDelay", |
138 | a1505857 | Iustin Pop | [ simpleField "duration" [t| Double |] |
139 | a1505857 | Iustin Pop | , simpleField "on_master" [t| Bool |] |
140 | a1505857 | Iustin Pop | , simpleField "on_nodes" [t| [String] |] |
141 | ebf38064 | Iustin Pop | ]) |
142 | ebf38064 | Iustin Pop | , ("OpInstanceReplaceDisks", |
143 | a1505857 | Iustin Pop | [ simpleField "instance_name" [t| String |] |
144 | a1505857 | Iustin Pop | , optionalField $ simpleField "remote_node" [t| String |] |
145 | a1505857 | Iustin Pop | , simpleField "mode" [t| ReplaceDisksMode |] |
146 | 4a1dc2bf | Iustin Pop | , simpleField "disks" [t| [DiskIndex] |] |
147 | a1505857 | Iustin Pop | , optionalField $ simpleField "iallocator" [t| String |] |
148 | ebf38064 | Iustin Pop | ]) |
149 | ebf38064 | Iustin Pop | , ("OpInstanceFailover", |
150 | a1505857 | Iustin Pop | [ simpleField "instance_name" [t| String |] |
151 | a1505857 | Iustin Pop | , simpleField "ignore_consistency" [t| Bool |] |
152 | a1505857 | Iustin Pop | , optionalField $ simpleField "target_node" [t| String |] |
153 | ebf38064 | Iustin Pop | ]) |
154 | ebf38064 | Iustin Pop | , ("OpInstanceMigrate", |
155 | a1505857 | Iustin Pop | [ simpleField "instance_name" [t| String |] |
156 | a1505857 | Iustin Pop | , simpleField "live" [t| Bool |] |
157 | a1505857 | Iustin Pop | , simpleField "cleanup" [t| Bool |] |
158 | a1505857 | Iustin Pop | , defaultField [| False |] $ simpleField "allow_failover" [t| Bool |] |
159 | a1505857 | Iustin Pop | , optionalField $ simpleField "target_node" [t| String |] |
160 | ebf38064 | Iustin Pop | ]) |
161 | 3bebda52 | Dato Simó | , ("OpTagsSet", |
162 | d8e7c45e | Iustin Pop | [ customField 'decodeTagObject 'encodeTagObject $ |
163 | d8e7c45e | Iustin Pop | simpleField "kind" [t| TagObject |] |
164 | 3bebda52 | Dato Simó | , simpleField "tags" [t| [String] |] |
165 | 3bebda52 | Dato Simó | ]) |
166 | 3bebda52 | Dato Simó | , ("OpTagsDel", |
167 | d8e7c45e | Iustin Pop | [ customField 'decodeTagObject 'encodeTagObject $ |
168 | d8e7c45e | Iustin Pop | simpleField "kind" [t| TagObject |] |
169 | 3bebda52 | Dato Simó | , simpleField "tags" [t| [String] |] |
170 | 3bebda52 | Dato Simó | ]) |
171 | ebf38064 | Iustin Pop | ]) |
172 | 12c19659 | Iustin Pop | |
173 | a583ec5d | Iustin Pop | -- | Returns the OP_ID for a given opcode value. |
174 | 12c19659 | Iustin Pop | $(genOpID ''OpCode "opID") |
175 | 702a4ee0 | Iustin Pop | |
176 | a583ec5d | Iustin Pop | -- | A list of all defined/supported opcode IDs. |
177 | a583ec5d | Iustin Pop | $(genAllOpIDs ''OpCode "allOpIDs") |
178 | a583ec5d | Iustin Pop | |
179 | 702a4ee0 | Iustin Pop | instance JSON OpCode where |
180 | ebf38064 | Iustin Pop | readJSON = loadOpCode |
181 | ebf38064 | Iustin Pop | showJSON = saveOpCode |