htools: add definitions for confd types

While we have some of these as plain types in Constants.hs, we add
proper ADT definitions for them in a new file. Furthermore, we add the
ConfdRequest and ConfdReply types here (in Python they are in
objects.py).

Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Guido Trotter <ultrotter@google.com>

diff --git a/Makefile.am b/Makefile.am
index 6d69482..8ca411e 100644 (file)
--- a/Makefile.am
+++ b/Makefile.am
@@ -395,6 +395,7 @@ HS_LIB_SRCS = \
        htools/Ganeti/HTools/Program/Hscan.hs \
        htools/Ganeti/HTools/Program/Hspace.hs \
        htools/Ganeti/BasicTypes.hs \
+       htools/Ganeti/Confd.hs \
        htools/Ganeti/Config.hs \
        htools/Ganeti/Jobs.hs \
        htools/Ganeti/Luxi.hs \

diff --git a/htools/Ganeti/Confd.hs b/htools/Ganeti/Confd.hs
new file mode 100644 (file)
index 0000000..6bc0dd1
--- /dev/null
+++ b/htools/Ganeti/Confd.hs
@@ -0,0 +1,166 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+{-| Implementation of the Ganeti confd types.
+
+-}
+
+{-
+
+Copyright (C) 2011, 2012 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.Confd
+  ( C.confdProtocolVersion
+  , C.confdMaxClockSkew
+  , C.confdConfigReloadTimeout
+  , C.confdConfigReloadRatelimit
+  , C.confdMagicFourcc
+  , C.confdDefaultReqCoverage
+  , C.confdClientExpireTimeout
+  , C.maxUdpDataSize
+  , ConfdRequestType(..)
+  , ConfdReqQ(..)
+  , ConfdReqField(..)
+  , ConfdReplyStatus(..)
+  , ConfdNodeRole(..)
+  , ConfdErrorType(..)
+  , ConfdRequest(..)
+  , ConfdReply(..)
+  , ConfdQuery(..)
+  , SignedMessage(..)
+  ) where
+
+import Text.JSON
+
+import qualified Ganeti.Constants as C
+import Ganeti.THH
+import Ganeti.HTools.JSON
+
+{-
+   Note that we re-export as is from Constants the following simple items:
+   - confdProtocolVersion
+   - confdMaxClockSkew
+   - confdConfigReloadTimeout
+   - confdConfigReloadRatelimit
+   - confdMagicFourcc
+   - confdDefaultReqCoverage
+   - confdClientExpireTimeout
+   - maxUdpDataSize
+
+-}
+
+$(declareIADT "ConfdRequestType"
+  [ ("ReqPing",             'C.confdReqPing )
+  , ("ReqNodeRoleByName",   'C.confdReqNodeRoleByname )
+  , ("ReqNodePipList",      'C.confdReqNodePipList )
+  , ("ReqNodePipByInstPip", 'C.confdReqNodePipByInstanceIp )
+  , ("ReqClusterMaster",    'C.confdReqClusterMaster )
+  , ("ReqMcPipList",        'C.confdReqMcPipList )
+  , ("ReqInstIpsList",      'C.confdReqInstancesIpsList )
+  ])
+$(makeJSONInstance ''ConfdRequestType)
+
+$(declareSADT "ConfdReqField"
+  [ ("ReqFieldName",     'C.confdReqfieldName )
+  , ("ReqFieldIp",       'C.confdReqfieldIp )
+  , ("ReqFieldMNodePip", 'C.confdReqfieldMnodePip )
+  ])
+$(makeJSONInstance ''ConfdReqField)
+
+-- Confd request query fields. These are used to narrow down queries.
+-- These must be strings rather than integers, because json-encoding
+-- converts them to strings anyway, as they're used as dict-keys.
+
+$(buildObject "ConfdReqQ" "confdReqQ"
+  [ renameField "Ip" $
+                optionalField $ simpleField C.confdReqqIp [t| String   |]
+  , renameField "IpList" $
+                defaultField [| [] |] $
+                simpleField C.confdReqqIplist [t| [String] |]
+  , renameField "Link" $ optionalField $
+                simpleField C.confdReqqLink [t| String   |]
+  , renameField "Fields" $ defaultField [| [] |] $
+                simpleField C.confdReqqFields [t| [ConfdReqField] |]
+  ])
+
+-- | Confd query type. This is complex enough that we can't
+-- automatically derive it via THH.
+data ConfdQuery = EmptyQuery
+                | PlainQuery String
+                | DictQuery  ConfdReqQ
+                  deriving (Show, Read, Eq)
+
+instance JSON ConfdQuery where
+  readJSON o = case o of
+                 JSNull     -> return EmptyQuery
+                 JSString s -> return . PlainQuery . fromJSString $ s
+                 JSObject _ -> fmap DictQuery (readJSON o::Result ConfdReqQ)
+                 _ -> fail $ "Cannot deserialise into ConfdQuery\
+                             \ the value '" ++ show o ++ "'"
+  showJSON cq = case cq of
+                  EmptyQuery -> JSNull
+                  PlainQuery s -> showJSON s
+                  DictQuery drq -> showJSON drq
+
+$(declareIADT "ConfdReplyStatus"
+  [ ( "ReplyStatusOk",      'C.confdReplStatusOk )
+  , ( "ReplyStatusError",   'C.confdReplStatusError )
+  , ( "ReplyStatusNotImpl", 'C.confdReplStatusNotimplemented )
+  ])
+$(makeJSONInstance ''ConfdReplyStatus)
+
+$(declareIADT "ConfdNodeRole"
+  [ ( "NodeRoleMaster",    'C.confdNodeRoleMaster )
+  , ( "NodeRoleCandidate", 'C.confdNodeRoleCandidate )
+  , ( "NodeRoleOffline",   'C.confdNodeRoleOffline )
+  , ( "NodeRoleDrained",   'C.confdNodeRoleDrained )
+  , ( "NodeRoleRegular",   'C.confdNodeRoleRegular )
+  ])
+$(makeJSONInstance ''ConfdNodeRole)
+
+
+-- Note that the next item is not a frozenset in Python, but we make
+-- it a separate type for safety
+
+$(declareIADT "ConfdErrorType"
+  [ ( "ConfdErrorUnknownEntry", 'C.confdErrorUnknownEntry )
+  , ( "ConfdErrorInternal",     'C.confdErrorInternal )
+  , ( "ConfdErrorArgument",     'C.confdErrorArgument )
+  ])
+$(makeJSONInstance ''ConfdErrorType)
+
+$(buildObject "ConfdRequest" "confdRq" $
+  [ simpleField "protocol" [t| Int |]
+  , simpleField "type"     [t| ConfdRequestType |]
+  , defaultField [| EmptyQuery |] $ simpleField "query" [t| ConfdQuery |]
+  , simpleField "rsalt"    [t| String |]
+  ])
+
+$(buildObject "ConfdReply" "confdReply"
+  [ simpleField "protocol" [t| Int              |]
+  , simpleField "status"   [t| ConfdReplyStatus |]
+  , simpleField "answer"   [t| JSValue          |]
+  , simpleField "serial"   [t| Int              |]
+  ])
+
+$(buildObject "SignedMessage" "signedMsg"
+  [ simpleField "hmac" [t| String |]
+  , simpleField "msg"  [t| String |]
+  , simpleField "salt" [t| String |]
+  ])