Synnefo » snf-ganeti

                  , specialNumericalField

                  , timeAsDoubleField

                  , timeStampFields

                  , uuidFields

                  , serialFields

                  , tagsFields

                  , TagSet

import qualified Data.Set as Set

import System.Time (ClockTime(..))

-- | Wrapper around a special parse function, suitable as field-parsing

-- function.

numericalReadFn :: JSON.JSON a => (String -> JSON.Result a)

                   -> [(String, JSON.JSValue)] -> JSON.JSValue -> JSON.Result a

numericalReadFn _ _ v@(JSON.JSRational _ _) = JSON.readJSON v

numericalReadFn f _ (JSON.JSString x) = f $ JSON.fromJSString x

numericalReadFn _ _ _ = JSON.Error "A numerical field has to be a number or\

                                   \ a string."

-- | Sets the read function to also accept string parsable by the given

-- function.

specialNumericalField :: Name -> Field -> Field

specialNumericalField f field =

     field { fieldRead = Just (appE (varE 'numericalReadFn) (varE f)) }

-- | Creates a new mandatory field that reads time as the (floating point)

-- number of seconds since the standard UNIX epoch, and represents it in

-- Haskell as 'ClockTime'.

timeAsDoubleField :: String -> Field

timeAsDoubleField fname =

  (simpleField fname [t| ClockTime |])

    { fieldRead = Just $ [| \_ -> liftM unTimeAsDoubleJSON . JSON.readJSON |]

    , fieldShow = Just $ [| \c -> (JSON.showJSON $ TimeAsDoubleJSON c, []) |]

    }

-- * Common field declarations

-- | Timestamp fields description.

timeStampFields :: [Field]

timeStampFields = map (defaultField [| TOD 0 0 |] . timeAsDoubleField)

                      ["ctime", "mtime"]

-- | Serial number fields description.

serialFields :: [Field]

serialFields =

    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]

-- | UUID fields description.

uuidFields :: [Field]

uuidFields = [ simpleField "uuid" [t| String |] ]

-- | Tag set type alias.

type TagSet = Set.Set String

-- | Tag field description.

tagsFields :: [Field]

tagsFields = [ defaultField [| Set.empty |] $

               simpleField "tags" [t| TagSet |] ]