Synnefo » snf-ganeti

extractArray :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]

  getData v >>= parseQueryResult

-- | Testing result status for more verbose error message.

fromJValWithStatus :: (Text.JSON.JSON a, Monad m) => (JSValue, JSValue) -> m a

fromJValWithStatus (st, v) = do

    st' <- fromJVal st

    L.checkRS st' v >>= fromJVal

                  String             -- ^ The object type

               -> String             -- ^ The object name

               -> String             -- ^ The attribute we're trying to convert

               -> (JSValue, JSValue) -- ^ The value we're trying to convert

               -> Result a           -- ^ The annotated result

                    oattr ++ "'") . fromJValWithStatus

              -> [(JSValue, JSValue)]

parseInstance ktn [ name, disk, mem, vcpus

                  , status, pnode, snodes, tags, oram

                  , auto_balance, disk_template ] = do

  xname <- annotateResult "Parsing new instance" (fromJValWithStatus name)

  xmem <- (case oram of -- FIXME: remove the "guessing"

             (_, JSRational _ _) -> convert "oper_ram" oram

parseNode :: NameAssoc -> [(JSValue, JSValue)] -> Result (String, Node.Node)

parseNode ktg [ name, mtotal, mnode, mfree, dtotal, dfree

              , ctotal, offline, drained, vm_capable, g_uuid ]

  xname <- annotateResult "Parsing new node" (fromJValWithStatus name)

parseGroup :: [(JSValue, JSValue)] -> Result (String, Group.Group)

parseGroup [uuid, name, apol] = do

  xname <- annotateResult "Parsing new group" (fromJValWithStatus name)

    , ResultStatus(..)

    , checkRS

$(declareIADT "ResultStatus"

     [ ("RSNormal", 'rsNormal)

     , ("RSUnknown", 'rsUnknown)

     , ("RSNoData", 'rsNodata)

     , ("RSUnavailable", 'rsUnavail)

     , ("RSOffline", 'rsOffline)

     ])

$(makeJSONInstanceInt ''ResultStatus)

-- | Check that ResultStatus is success or fail with descriptive message.

checkRS :: (Monad m) => ResultStatus -> a -> m a

checkRS RSNormal val    = return val

checkRS RSUnknown _     = fail "Unknown field"

checkRS RSNoData _      = fail "No data for a field"

checkRS RSUnavailable _ = fail "Ganeti reports unavailable data"

checkRS RSOffline _     = fail "Ganeti reports resource as offline"

                  , declareIADT

                  , makeJSONInstanceInt

-- | ToInt function name.

toIntName :: String -> Name

toIntName= mkName . (++ "ToInt") . ensureLower

-- | FromInt function name.

fromIntName:: String -> Name

fromIntName = mkName . (++ "FromInt") . ensureLower

-- * Template code for simple integer-equivalent ADTs

-- | Generates a data type declaration.

--

-- The type will have a fixed list of instances.

intADTDecl :: Name -> [String] -> Dec

intADTDecl name constructors =

    DataD [] name []

              (map (flip NormalC [] . mkName) constructors)

              [''Show]

-- | Generates a toInt function.

genToInt :: Name -> Name -> [(String, Name)] -> Q [Dec]

genToInt fname tname constructors = do

  sigt <- [t| $(conT tname) -> Int |]

  clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]

                             (normalB (varE v)) []) constructors

  return [SigD fname sigt, FunD fname clauses]

-- | Generates a fromInt function.

genFromInt :: Name -> Name -> [(String, Name)] -> Q [Dec]

genFromInt fname tname constructors = do

  sigt <- [t| (Monad m) => Int-> m $(conT tname) |]

  let varp = mkName "s"

      varpe = varE varp

  clauses <- mapM (\(c, v) -> do

                     g <- normalG [| $varpe == $(varE v) |]

                     r <- [| return $(conE (mkName c)) |]

                     return (g, r)) constructors

  oth_clause <- do

    g <- normalG [| otherwise |]

    r <- [|fail ("Invalid int value for type " ++

                 $(litE (stringL (nameBase tname))) ++ ": " ++ show $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.

declareIADT:: String -> [(String, Name)] -> Q [Dec]

declareIADT sname cons = do

  let name = mkName sname

      ddecl = intADTDecl name (map fst cons)

  tostr <- genToInt (toIntName sname) name cons

  fromstr <- genFromInt (fromIntName sname) name cons

  return $ ddecl:tostr ++ fromstr

-- | Creates the showJSON member of a JSON instance declaration.

genShowJSONInt :: String -> Q [Dec]

genShowJSONInt name = [d| showJSON = JSON.showJSON . $(varE (toIntName name)) |]

-- | Creates the readJSON member of a JSON instance declaration.

genReadJSONInt :: String -> Q Dec

genReadJSONInt name = do

  let s = mkName "s"

  body <- [| case JSON.readJSON $(varE s) of

               JSON.Ok s' -> $(varE (fromIntName name)) s'

               JSON.Error e ->

                   JSON.Error $ "Can't parse int value for type " ++

                           $(stringE name) ++ ": " ++ e

           |]

  return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]

-- | Generates a JSON instance for a given type.

makeJSONInstanceInt :: Name -> Q [Dec]

makeJSONInstanceInt name = do

  let base = nameBase name

  showJ <- genShowJSONInt base

  readJ <- genReadJSONInt base

  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)]