diff --git a/Makefile.am b/Makefile.am
index 5bdcd939322324eada902ee6d5bf5f58a83c46a5..26c5b86b176f6fef31c3f6a12ee1b1b212f18352 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -364,7 +364,8 @@ HS_LIB_SRCS = \
htools/Ganeti/HTools/Program/Hspace.hs \
htools/Ganeti/Jobs.hs \
htools/Ganeti/Luxi.hs \
- htools/Ganeti/OpCodes.hs
+ htools/Ganeti/OpCodes.hs \
+ htools/Ganeti/THH.hs
HS_BUILT_SRCS = htools/Ganeti/HTools/Version.hs htools/Ganeti/Constants.hs
HS_BUILT_SRCS_IN = $(patsubst %,%.in,$(HS_BUILT_SRCS))
diff --git a/htools/Ganeti/HTools/Types.hs b/htools/Ganeti/HTools/Types.hs
index 75dbce59ae2c72b4b7252bedd00c3371ad8f8ce5..8e6b6a4dcb44a14a664ba4d88f0c246d7ef11ac3 100644
--- a/htools/Ganeti/HTools/Types.hs
+++ b/htools/Ganeti/HTools/Types.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+
{-| Some common types.
-}
@@ -72,6 +74,7 @@ import qualified Data.Map as M
import qualified Text.JSON as JSON
import qualified Ganeti.Constants as C
+import qualified Ganeti.THH as THH
-- | The instance index type.
type Idx = Int
@@ -100,36 +103,12 @@ type GroupID = String
-- Ord instance will order them in the order they are defined, so when
-- changing this data type be careful about the interaction with the
-- desired sorting order.
-data AllocPolicy
- = AllocPreferred -- ^ This is the normal status, the group
- -- should be used normally during allocations
- | AllocLastResort -- ^ This group should be used only as
- -- last-resort, after the preferred groups
- | AllocUnallocable -- ^ This group must not be used for new
- -- allocations
- deriving (Show, Read, Eq, Ord, Enum, Bounded)
-
--- | Convert a string to an alloc policy.
-allocPolicyFromString :: (Monad m) => String -> m AllocPolicy
-allocPolicyFromString s =
- case () of
- _ | s == C.allocPolicyPreferred -> return AllocPreferred
- | s == C.allocPolicyLastResort -> return AllocLastResort
- | s == C.allocPolicyUnallocable -> return AllocUnallocable
- | otherwise -> fail $ "Invalid alloc policy mode: " ++ s
-
--- | Convert an alloc policy to the Ganeti string equivalent.
-allocPolicyToString :: AllocPolicy -> String
-allocPolicyToString AllocPreferred = C.allocPolicyPreferred
-allocPolicyToString AllocLastResort = C.allocPolicyLastResort
-allocPolicyToString AllocUnallocable = C.allocPolicyUnallocable
-
-instance JSON.JSON AllocPolicy where
- showJSON = JSON.showJSON . allocPolicyToString
- readJSON s = case JSON.readJSON s of
- JSON.Ok s' -> allocPolicyFromString s'
- JSON.Error e -> JSON.Error $
- "Can't parse alloc_policy: " ++ e
+$(THH.declareSADT "AllocPolicy"
+ [ ("AllocPreferred", 'C.allocPolicyPreferred)
+ , ("AllocLastResort", 'C.allocPolicyLastResort)
+ , ("AllocUnallocable", 'C.allocPolicyUnallocable)
+ ])
+$(THH.makeJSONInstance ''AllocPolicy)
-- | The resource spec type.
data RSpec = RSpec
@@ -182,41 +161,15 @@ data IMove = Failover -- ^ Failover the instance (f)
deriving (Show, Read)
-- | Instance disk template type.
-data DiskTemplate = DTDiskless
- | DTFile
- | DTSharedFile
- | DTPlain
- | DTBlock
- | DTDrbd8
- deriving (Show, Read, Eq, Enum, Bounded)
-
--- | Converts a DiskTemplate to String.
-diskTemplateToString :: DiskTemplate -> String
-diskTemplateToString DTDiskless = C.dtDiskless
-diskTemplateToString DTFile = C.dtFile
-diskTemplateToString DTSharedFile = C.dtSharedFile
-diskTemplateToString DTPlain = C.dtPlain
-diskTemplateToString DTBlock = C.dtBlock
-diskTemplateToString DTDrbd8 = C.dtDrbd8
-
--- | Converts a DiskTemplate from String.
-diskTemplateFromString :: (Monad m) => String -> m DiskTemplate
-diskTemplateFromString s =
- case () of
- _ | s == C.dtDiskless -> return DTDiskless
- | s == C.dtFile -> return DTFile
- | s == C.dtSharedFile -> return DTSharedFile
- | s == C.dtPlain -> return DTPlain
- | s == C.dtBlock -> return DTBlock
- | s == C.dtDrbd8 -> return DTDrbd8
- | otherwise -> fail $ "Invalid disk template: " ++ s
-
-instance JSON.JSON DiskTemplate where
- showJSON = JSON.showJSON . diskTemplateToString
- readJSON s = case JSON.readJSON s of
- JSON.Ok s' -> diskTemplateFromString s'
- JSON.Error e -> JSON.Error $
- "Can't parse disk_template as string: " ++ e
+$(THH.declareSADT "DiskTemplate"
+ [ ("DTDiskless", 'C.dtDiskless)
+ , ("DTFile", 'C.dtFile)
+ , ("DTSharedFile", 'C.dtSharedFile)
+ , ("DTPlain", 'C.dtPlain)
+ , ("DTBlock", 'C.dtBlock)
+ , ("DTDrbd8", 'C.dtDrbd8)
+ ])
+$(THH.makeJSONInstance ''DiskTemplate)
-- | Formatted solution output for one move (involved nodes and
-- commands.
@@ -347,21 +300,9 @@ class Element a where
setIdx :: a -> Int -> a
-- | The iallocator node-evacuate evac_mode type.
-data EvacMode = ChangePrimary
- | ChangeSecondary
- | ChangeAll
- deriving (Show, Read)
-
-instance JSON.JSON EvacMode where
- showJSON mode = case mode of
- ChangeAll -> JSON.showJSON C.iallocatorNevacAll
- ChangePrimary -> JSON.showJSON C.iallocatorNevacPri
- ChangeSecondary -> JSON.showJSON C.iallocatorNevacSec
- readJSON v =
- case JSON.readJSON v of
- JSON.Ok s | s == C.iallocatorNevacAll -> return ChangeAll
- | s == C.iallocatorNevacPri -> return ChangePrimary
- | s == C.iallocatorNevacSec -> return ChangeSecondary
- | otherwise -> fail $ "Invalid evacuate mode " ++ s
- JSON.Error e -> JSON.Error $
- "Can't parse evacuate mode as string: " ++ e
+$(THH.declareSADT "EvacMode"
+ [ ("ChangePrimary", 'C.iallocatorNevacPri)
+ , ("ChangeSecondary", 'C.iallocatorNevacSec)
+ , ("ChangeAll", 'C.iallocatorNevacAll)
+ ])
+$(THH.makeJSONInstance ''EvacMode)
diff --git a/htools/Ganeti/Jobs.hs b/htools/Ganeti/Jobs.hs
index ed7bc7d8f34cdfb7823804a85c423a01b4f21f58..1e2cebecccc14eea92cd9c85ccf9e8a21248a5dc 100644
--- a/htools/Ganeti/Jobs.hs
+++ b/htools/Ganeti/Jobs.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+
{-| Implementation of the job information.
-}
@@ -32,67 +34,30 @@ import Text.JSON (readJSON, showJSON, JSON)
import qualified Text.JSON as J
import qualified Ganeti.Constants as C
+import qualified Ganeti.THH as THH
-- | Our ADT for the OpCode status at runtime (while in a job).
-data OpStatus = OP_STATUS_QUEUED
- | OP_STATUS_WAITING
- | OP_STATUS_CANCELING
- | OP_STATUS_RUNNING
- | OP_STATUS_CANCELED
- | OP_STATUS_SUCCESS
- | OP_STATUS_ERROR
- deriving (Eq, Enum, Bounded, Show, Read)
-
-instance JSON OpStatus where
- showJSON os = showJSON w
- where w = case os of
- OP_STATUS_QUEUED -> C.opStatusQueued
- OP_STATUS_WAITING -> C.opStatusWaiting
- OP_STATUS_CANCELING -> C.opStatusCanceling
- OP_STATUS_RUNNING -> C.opStatusRunning
- OP_STATUS_CANCELED -> C.opStatusCanceled
- OP_STATUS_SUCCESS -> C.opStatusSuccess
- OP_STATUS_ERROR -> C.opStatusError
- readJSON s = case readJSON s of
- J.Ok v | v == C.opStatusQueued -> J.Ok OP_STATUS_QUEUED
- | v == C.opStatusWaiting -> J.Ok OP_STATUS_WAITING
- | v == C.opStatusCanceling -> J.Ok OP_STATUS_CANCELING
- | v == C.opStatusRunning -> J.Ok OP_STATUS_RUNNING
- | v == C.opStatusCanceled -> J.Ok OP_STATUS_CANCELED
- | v == C.opStatusSuccess -> J.Ok OP_STATUS_SUCCESS
- | v == C.opStatusError -> J.Ok OP_STATUS_ERROR
- | otherwise -> J.Error ("Unknown opcode status " ++ v)
- _ -> J.Error ("Cannot parse opcode status " ++ show s)
+$(THH.declareSADT "OpStatus"
+ [ ("OP_STATUS_QUEUED", 'C.opStatusQueued)
+ , ("OP_STATUS_WAITING", 'C.opStatusWaiting)
+ , ("OP_STATUS_CANCELING", 'C.opStatusCanceling)
+ , ("OP_STATUS_RUNNING", 'C.opStatusRunning)
+ , ("OP_STATUS_CANCELED", 'C.opStatusCanceled)
+ , ("OP_STATUS_SUCCESS", 'C.opStatusSuccess)
+ , ("OP_STATUS_ERROR", 'C.opStatusError)
+ ])
+$(THH.makeJSONInstance ''OpStatus)
-- | The JobStatus data type. Note that this is ordered especially
-- such that greater\/lesser comparison on values of this type makes
-- sense.
-data JobStatus = JOB_STATUS_QUEUED
- | JOB_STATUS_WAITING
- | JOB_STATUS_RUNNING
- | JOB_STATUS_SUCCESS
- | JOB_STATUS_CANCELING
- | JOB_STATUS_CANCELED
- | JOB_STATUS_ERROR
- deriving (Eq, Enum, Ord, Bounded, Show, Read)
-
-instance JSON JobStatus where
- showJSON js = showJSON w
- where w = case js of
- JOB_STATUS_QUEUED -> C.jobStatusQueued
- JOB_STATUS_WAITING -> C.jobStatusWaiting
- JOB_STATUS_CANCELING -> C.jobStatusCanceling
- JOB_STATUS_RUNNING -> C.jobStatusRunning
- JOB_STATUS_CANCELED -> C.jobStatusCanceled
- JOB_STATUS_SUCCESS -> C.jobStatusSuccess
- JOB_STATUS_ERROR -> C.jobStatusError
- readJSON s = case readJSON s of
- J.Ok v | v == C.jobStatusQueued -> J.Ok JOB_STATUS_QUEUED
- | v == C.jobStatusWaiting -> J.Ok JOB_STATUS_WAITING
- | v == C.jobStatusCanceling -> J.Ok JOB_STATUS_CANCELING
- | v == C.jobStatusRunning -> J.Ok JOB_STATUS_RUNNING
- | v == C.jobStatusSuccess -> J.Ok JOB_STATUS_SUCCESS
- | v == C.jobStatusCanceled -> J.Ok JOB_STATUS_CANCELED
- | v == C.jobStatusError -> J.Ok JOB_STATUS_ERROR
- | otherwise -> J.Error ("Unknown job status " ++ v)
- _ -> J.Error ("Unknown job status " ++ show s)
+$(THH.declareSADT "JobStatus"
+ [ ("JOB_STATUS_QUEUED", 'C.jobStatusQueued)
+ , ("JOB_STATUS_WAITING", 'C.jobStatusWaiting)
+ , ("JOB_STATUS_CANCELING", 'C.jobStatusCanceling)
+ , ("JOB_STATUS_RUNNING", 'C.jobStatusRunning)
+ , ("JOB_STATUS_CANCELED", 'C.jobStatusCanceled)
+ , ("JOB_STATUS_SUCCESS", 'C.jobStatusSuccess)
+ , ("JOB_STATUS_ERROR", 'C.jobStatusError)
+ ])
+$(THH.makeJSONInstance ''JobStatus)
diff --git a/htools/Ganeti/OpCodes.hs b/htools/Ganeti/OpCodes.hs
index 09305983bc64b43414b664c2bd1962ad341f2c8b..b3fc1f33aaeaa145a79dc8fe460b8d79929d4ab3 100644
--- a/htools/Ganeti/OpCodes.hs
+++ b/htools/Ganeti/OpCodes.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+
{-| Implementation of the opcodes.
-}
@@ -34,27 +36,19 @@ import Text.JSON (readJSON, showJSON, makeObj, JSON)
import qualified Text.JSON as J
import Text.JSON.Types
+import qualified Ganeti.Constants as C
+import qualified Ganeti.THH as THH
+
import Ganeti.HTools.Utils
-- | Replace disks type.
-data ReplaceDisksMode = ReplaceOnPrimary
- | ReplaceOnSecondary
- | ReplaceNewSecondary
- | ReplaceAuto
- deriving (Show, Read, Eq)
-
-instance JSON ReplaceDisksMode where
- showJSON m = case m of
- ReplaceOnPrimary -> showJSON "replace_on_primary"
- ReplaceOnSecondary -> showJSON "replace_on_secondary"
- ReplaceNewSecondary -> showJSON "replace_new_secondary"
- ReplaceAuto -> showJSON "replace_auto"
- readJSON s = case readJSON s of
- J.Ok "replace_on_primary" -> J.Ok ReplaceOnPrimary
- J.Ok "replace_on_secondary" -> J.Ok ReplaceOnSecondary
- J.Ok "replace_new_secondary" -> J.Ok ReplaceNewSecondary
- J.Ok "replace_auto" -> J.Ok ReplaceAuto
- _ -> J.Error "Can't parse a valid ReplaceDisksMode"
+$(THH.declareSADT "ReplaceDisksMode"
+ [ ("ReplaceOnPrimary", 'C.replaceDiskPri)
+ , ("ReplaceOnSecondary", 'C.replaceDiskSec)
+ , ("ReplaceNewSecondary", 'C.replaceDiskChg)
+ , ("ReplaceAuto", 'C.replaceDiskAuto)
+ ])
+$(THH.makeJSONInstance ''ReplaceDisksMode)
-- | OpCode representation.
--
diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
new file mode 100644
index 0000000000000000000000000000000000000000..6e539a43d4d023d1bb388213aca3279d47faa8a6
--- /dev/null
+++ b/htools/Ganeti/THH.hs
@@ -0,0 +1,186 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+
+{-| TemplateHaskell helper for HTools.
+
+As TemplateHaskell require that splices be defined in a separate
+module, we combine all the TemplateHaskell functionality that HTools
+needs in this module (except the one for unittests).
+
+-}
+
+{-
+
+Copyright (C) 2011 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.THH ( declareSADT
+ , makeJSONInstance
+ ) where
+
+import Data.Char
+import Language.Haskell.TH
+
+import qualified Text.JSON as JSON
+
+-- | Ensure first letter is lowercase.
+--
+-- Used to convert type name to function prefix, e.g. in @data Aa ->
+-- aaToString@.
+ensureLower :: String -> String
+ensureLower [] = []
+ensureLower (x:xs) = toLower x:xs
+
+-- | ToString function name.
+toStrName :: String -> Name
+toStrName = mkName . (++ "ToString") . ensureLower
+
+-- | FromString function name.
+fromStrName :: String -> Name
+fromStrName = mkName . (++ "FromString") . ensureLower
+
+-- | Generates a data type declaration.
+--
+-- The type will have a fixed list of instances.
+strADTDecl :: Name -> [String] -> Dec
+strADTDecl name constructors =
+ DataD [] name []
+ (map (flip NormalC [] . mkName) constructors)
+ [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
+
+-- | Generates a toString function.
+--
+-- This generates a simple function of the form:
+--
+-- @
+-- nameToString :: Name -> String
+-- nameToString Cons1 = var1
+-- nameToString Cons2 = \"value2\"
+-- @
+genToString :: Name -> Name -> [(String, Name)] -> Q [Dec]
+genToString fname tname constructors = do
+ sigt <- [t| $(conT tname) -> String |]
+ -- the body clauses, matching on the constructor and returning the
+ -- string value
+ clauses <- mapM (\(c, v) -> clause [recP (mkName c) []]
+ (normalB (varE v)) []) constructors
+ return [SigD fname sigt, FunD fname clauses]
+
+-- | Generates a fromString function.
+--
+-- The function generated is monadic and can fail parsing the
+-- string. It is of the form:
+--
+-- @
+-- nameFromString :: (Monad m) => String -> m Name
+-- nameFromString s | s == var1 = Cons1
+-- | s == \"value2\" = Cons2
+-- | otherwise = fail /.../
+-- @
+genFromString :: Name -> Name -> [(String, Name)] -> Q [Dec]
+genFromString fname tname constructors = do
+ -- signature of form (Monad m) => String -> m $name
+ sigt <- [t| (Monad m) => String -> m $(conT tname) |]
+ -- clauses for a guarded pattern
+ let varp = mkName "s"
+ varpe = varE varp
+ clauses <- mapM (\(c, v) -> do
+ -- the clause match condition
+ g <- normalG [| $varpe == $(varE v) |]
+ -- the clause result
+ r <- [| return $(conE (mkName c)) |]
+ return (g, r)) constructors
+ -- the otherwise clause (fallback)
+ oth_clause <- do
+ g <- normalG [| otherwise |]
+ r <- [|fail ("Invalid string value for type " ++
+ $(litE (stringL (nameBase tname))) ++ ": " ++ $varpe) |]
+ return (g, r)
+ let fun = FunD fname [Clause [VarP varp]
+ (GuardedB (clauses++[oth_clause])) []]
+ return [SigD fname sigt, fun]
+
+-- | Generates a data type from a given string format.
+--
+-- The format is expected to multiline. The first line contains the
+-- type name, and the rest of the lines must contain two words: the
+-- constructor name and then the string representation of the
+-- respective constructor.
+--
+-- The function will generate the data type declaration, and then two
+-- functions:
+--
+-- * /name/ToString, which converts the type to a string
+--
+-- * /name/FromString, which (monadically) converts from a string to the type
+--
+-- Note that this is basically just a custom show/read instance,
+-- nothing else.
+declareSADT :: String -> [(String, Name)] -> Q [Dec]
+declareSADT sname cons = do
+ let name = mkName sname
+ ddecl = strADTDecl name (map fst cons)
+ tostr <- genToString (toStrName sname) name cons
+ fromstr <- genFromString (fromStrName sname) name cons
+ return $ ddecl:tostr ++ fromstr
+
+
+-- | Creates the showJSON member of a JSON instance declaration.
+--
+-- This will create what is the equivalent of:
+--
+-- @
+-- showJSON = showJSON . /name/ToString
+-- @
+--
+-- in an instance JSON /name/ declaration
+genShowJSON :: String -> Q [Dec]
+genShowJSON name = [d| showJSON = JSON.showJSON . $(varE (toStrName name)) |]
+
+-- | Creates the readJSON member of a JSON instance declaration.
+--
+-- This will create what is the equivalent of:
+--
+-- @
+-- readJSON s = case readJSON s of
+-- Ok s' -> /name/FromString s'
+-- Error e -> Error /description/
+-- @
+--
+-- in an instance JSON /name/ declaration
+genReadJSON :: String -> Q Dec
+genReadJSON name = do
+ let s = mkName "s"
+ body <- [| case JSON.readJSON $(varE s) of
+ JSON.Ok s' -> $(varE (fromStrName name)) s'
+ JSON.Error e ->
+ JSON.Error $ "Can't parse string value for type " ++
+ $(litE (StringL name)) ++ ": " ++ e
+ |]
+ return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
+
+-- | Generates a JSON instance for a given type.
+--
+-- This assumes that the /name/ToString and /name/FromString functions
+-- have been defined as by the 'declareSADT' function.
+makeJSONInstance :: Name -> Q [Dec]
+makeJSONInstance name = do
+ let base = nameBase name
+ showJ <- genShowJSON base
+ readJ <- genReadJSON base
+ return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)]