code.grnet.gr Git - ganeti-local/blob - htools/Ganeti/Confd.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2
   3 {-| Implementation of the Ganeti confd types.
   4
   5 -}
   6
   7 {-
   8
   9 Copyright (C) 2011, 2012 Google Inc.
  10
  11 This program is free software; you can redistribute it and/or modify
  12 it under the terms of the GNU General Public License as published by
  13 the Free Software Foundation; either version 2 of the License, or
  14 (at your option) any later version.
  15
  16 This program is distributed in the hope that it will be useful, but
  17 WITHOUT ANY WARRANTY; without even the implied warranty of
  18 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 General Public License for more details.
  20
  21 You should have received a copy of the GNU General Public License
  22 along with this program; if not, write to the Free Software
  23 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  24 02110-1301, USA.
  25
  26 -}
  27
  28 module Ganeti.Confd
  29   ( C.confdProtocolVersion
  30   , C.confdMaxClockSkew
  31   , C.confdConfigReloadTimeout
  32   , C.confdConfigReloadRatelimit
  33   , C.confdMagicFourcc
  34   , C.confdDefaultReqCoverage
  35   , C.confdClientExpireTimeout
  36   , C.maxUdpDataSize
  37   , ConfdRequestType(..)
  38   , ConfdReqQ(..)
  39   , ConfdReqField(..)
  40   , ConfdReplyStatus(..)
  41   , ConfdNodeRole(..)
  42   , ConfdErrorType(..)
  43   , ConfdRequest(..)
  44   , ConfdReply(..)
  45   , ConfdQuery(..)
  46   , SignedMessage(..)
  47   ) where
  48
  49 import Text.JSON
  50
  51 import qualified Ganeti.Constants as C
  52 import Ganeti.THH
  53 import Ganeti.JSON
  54
  55 {-
  56    Note that we re-export as is from Constants the following simple items:
  57    - confdProtocolVersion
  58    - confdMaxClockSkew
  59    - confdConfigReloadTimeout
  60    - confdConfigReloadRatelimit
  61    - confdMagicFourcc
  62    - confdDefaultReqCoverage
  63    - confdClientExpireTimeout
  64    - maxUdpDataSize
  65
  66 -}
  67
  68 $(declareIADT "ConfdRequestType"
  69   [ ("ReqPing",             'C.confdReqPing )
  70   , ("ReqNodeRoleByName",   'C.confdReqNodeRoleByname )
  71   , ("ReqNodePipList",      'C.confdReqNodePipList )
  72   , ("ReqNodePipByInstPip", 'C.confdReqNodePipByInstanceIp )
  73   , ("ReqClusterMaster",    'C.confdReqClusterMaster )
  74   , ("ReqMcPipList",        'C.confdReqMcPipList )
  75   , ("ReqInstIpsList",      'C.confdReqInstancesIpsList )
  76   , ("ReqNodeDrbd",         'C.confdReqNodeDrbd )
  77   ])
  78 $(makeJSONInstance ''ConfdRequestType)
  79
  80 $(declareSADT "ConfdReqField"
  81   [ ("ReqFieldName",     'C.confdReqfieldName )
  82   , ("ReqFieldIp",       'C.confdReqfieldIp )
  83   , ("ReqFieldMNodePip", 'C.confdReqfieldMnodePip )
  84   ])
  85 $(makeJSONInstance ''ConfdReqField)
  86
  87 -- Confd request query fields. These are used to narrow down queries.
  88 -- These must be strings rather than integers, because json-encoding
  89 -- converts them to strings anyway, as they're used as dict-keys.
  90
  91 $(buildObject "ConfdReqQ" "confdReqQ"
  92   [ renameField "Ip" .
  93                 optionalField $ simpleField C.confdReqqIp [t| String   |]
  94   , renameField "IpList" .
  95                 defaultField [| [] |] $
  96                 simpleField C.confdReqqIplist [t| [String] |]
  97   , renameField "Link" . optionalField $
  98                 simpleField C.confdReqqLink [t| String   |]
  99   , renameField "Fields" . defaultField [| [] |] $
 100                 simpleField C.confdReqqFields [t| [ConfdReqField] |]
 101   ])
 102
 103 -- | Confd query type. This is complex enough that we can't
 104 -- automatically derive it via THH.
 105 data ConfdQuery = EmptyQuery
 106                 | PlainQuery String
 107                 | DictQuery  ConfdReqQ
 108                   deriving (Show, Read, Eq)
 109
 110 instance JSON ConfdQuery where
 111   readJSON o = case o of
 112                  JSNull     -> return EmptyQuery
 113                  JSString s -> return . PlainQuery . fromJSString $ s
 114                  JSObject _ -> fmap DictQuery (readJSON o::Result ConfdReqQ)
 115                  _ -> fail $ "Cannot deserialise into ConfdQuery\
 116                              \ the value '" ++ show o ++ "'"
 117   showJSON cq = case cq of
 118                   EmptyQuery -> JSNull
 119                   PlainQuery s -> showJSON s
 120                   DictQuery drq -> showJSON drq
 121
 122 $(declareIADT "ConfdReplyStatus"
 123   [ ( "ReplyStatusOk",      'C.confdReplStatusOk )
 124   , ( "ReplyStatusError",   'C.confdReplStatusError )
 125   , ( "ReplyStatusNotImpl", 'C.confdReplStatusNotimplemented )
 126   ])
 127 $(makeJSONInstance ''ConfdReplyStatus)
 128
 129 $(declareIADT "ConfdNodeRole"
 130   [ ( "NodeRoleMaster",    'C.confdNodeRoleMaster )
 131   , ( "NodeRoleCandidate", 'C.confdNodeRoleCandidate )
 132   , ( "NodeRoleOffline",   'C.confdNodeRoleOffline )
 133   , ( "NodeRoleDrained",   'C.confdNodeRoleDrained )
 134   , ( "NodeRoleRegular",   'C.confdNodeRoleRegular )
 135   ])
 136 $(makeJSONInstance ''ConfdNodeRole)
 137
 138
 139 -- Note that the next item is not a frozenset in Python, but we make
 140 -- it a separate type for safety
 141
 142 $(declareIADT "ConfdErrorType"
 143   [ ( "ConfdErrorUnknownEntry", 'C.confdErrorUnknownEntry )
 144   , ( "ConfdErrorInternal",     'C.confdErrorInternal )
 145   , ( "ConfdErrorArgument",     'C.confdErrorArgument )
 146   ])
 147 $(makeJSONInstance ''ConfdErrorType)
 148
 149 $(buildObject "ConfdRequest" "confdRq"
 150   [ simpleField "protocol" [t| Int |]
 151   , simpleField "type"     [t| ConfdRequestType |]
 152   , defaultField [| EmptyQuery |] $ simpleField "query" [t| ConfdQuery |]
 153   , simpleField "rsalt"    [t| String |]
 154   ])
 155
 156 $(buildObject "ConfdReply" "confdReply"
 157   [ simpleField "protocol" [t| Int              |]
 158   , simpleField "status"   [t| ConfdReplyStatus |]
 159   , simpleField "answer"   [t| JSValue          |]
 160   , simpleField "serial"   [t| Int              |]
 161   ])
 162
 163 $(buildObject "SignedMessage" "signedMsg"
 164   [ simpleField "hmac" [t| String |]
 165   , simpleField "msg"  [t| String |]
 166   , simpleField "salt" [t| String |]
 167   ])