Commit e9aaa3c6 authored by Iustin Pop's avatar Iustin Pop
Browse files

Use TemplateHaskell instead of hand-coded instances

This patch replaces the current hard-coded JSON instances (all alike,
just manual conversion to/from string) with auto-generated code based
on Template Haskell
(http://www.haskell.org/haskellwiki/Template_Haskell

).

The reduction in code line is not big, as the helper module is well
documented and thus overall we gain about 70 code lines; however, if
we ignore comments we're in good shape, and any future addition of
such data types will be much simpler and less error-prone.
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarAgata Murawska <agatamurawska@google.com>
parent 2c9336a4
......@@ -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))
......
{-# 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)
{-# 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)
{-# 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.
--
......
{-# 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)]
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment