Revision 13d26b66 src/Ganeti/WConfd/Monad.hs

b/src/Ganeti/WConfd/Monad.hs
1 
{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}
1 
{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-}
2 2 

  		





  3
  3
  
    
{-| All RPC calls are run within this monad.


  		





  4
  4
  
    

  		





  ......




  37
  37
  
    
module Ganeti.WConfd.Monad


  		





  38
  38
  
    
  ( DaemonHandle


  		





  39
  39
  
    
  , dhConfigPath


  		





  
  40
  
    
  , dhSaveConfigWorker


  		





  40
  41
  
    
  , mkDaemonHandle


  		





  41
  42
  
    
  , ClientState(..)


  		





  42
  43
  
    
  , WConfdMonadInt


  		





  43
  44
  
    
  , runWConfdMonadInt


  		





  44
  45
  
    
  , WConfdMonad


  		





  
  46
  
    
  , daemonHandle


  		





  45
  47
  
    
  , modifyConfigState


  		





  
  48
  
    
  , readConfigState


  		





  46
  49
  
    
  , modifyLockAllocation


  		





  47
  50
  
    
  ) where


  		





  48
  51
  
    

  		





  ......




  52
  55
  
    
import Control.Monad.Error


  		





  53
  56
  
    
import Control.Monad.Trans.Control


  		





  54
  57
  
    
import Control.Monad.Trans.RWS.Strict


  		





  55
  
  
    
import Data.IORef


  		





  
  58
  
    
import Data.IORef.Lifted


  		





  56
  59
  
    

  		





  57
  60
  
    
import Ganeti.BasicTypes


  		





  58
  61
  
    
import Ganeti.Errors


  		





  59
  62
  
    
import Ganeti.Locking.Locks


  		





  60
  63
  
    
import Ganeti.Logging


  		





  61
  64
  
    
import Ganeti.Types


  		





  
  65
  
    
import Ganeti.Utils.AsyncWorker


  		





  62
  66
  
    
import Ganeti.WConfd.ConfigState


  		





  63
  67
  
    

  		





  64
  68
  
    
-- * Pure data types used in the monad


  		





  ......




  76
  80
  
    
  -- all static information that doesn't change during the life-time of the


  		





  77
  81
  
    
  -- daemon should go here;


  		





  78
  82
  
    
  -- all IDs of threads that do asynchronous work should probably also go here


  		





  
  83
  
    
  , dhSaveConfigWorker :: AsyncWorker ()


  		





  79
  84
  
    
  }


  		





  80
  85
  
    

  		





  81
  86
  
    
mkDaemonHandle :: FilePath


  		





  82
  87
  
    
               -> ConfigState


  		





  83
  88
  
    
               -> GanetiLockAllocation


  		





  84
  
  
    
               -> ResultT GanetiException IO DaemonHandle


  		





  85
  
  
    
mkDaemonHandle cp cs la =


  		





  86
  
  
    
  DaemonHandle <$> liftBase (newIORef $ DaemonState cs la) <*> pure cp


  		





  
  89
  
    
               -> (IO ConfigState -> ResultG (AsyncWorker ()))


  		





  
  90
  
    
                  -- ^ A function that creates a worker that asynchronously


  		





  
  91
  
    
                  -- saves the configuration to the master file.


  		





  
  92
  
    
               -> ResultG DaemonHandle


  		





  
  93
  
    
mkDaemonHandle cpath cstat lstat saveWorkerFn = do


  		





  
  94
  
    
  ds <- newIORef $ DaemonState cstat lstat


  		





  
  95
  
    
  saveWorker <- saveWorkerFn $ dsConfigState `liftM` readIORef ds


  		





  
  96
  
    
  return $ DaemonHandle ds cpath saveWorker


  		





  87
  97
  
    

  		





  88
  98
  
    
data ClientState = ClientState


  		





  89
  99
  
    
  { clLiveFilePath :: FilePath


  		





  ......




  138
  148
  
    

  		





  139
  149
  
    
-- * Basic functions in the monad


  		





  140
  150
  
    

  		





  
  151
  
    
-- | Returns the daemon handle.


  		





  
  152
  
    
daemonHandle :: WConfdMonad DaemonHandle


  		





  
  153
  
    
daemonHandle = lift . WConfdMonadInt $ ask


  		





  
  154
  
    

  		





  
  155
  
    
-- | Returns the current configuration, given a handle


  		





  
  156
  
    
readConfigState :: WConfdMonad ConfigState


  		





  
  157
  
    
readConfigState = liftM dsConfigState . readIORef . dhDaemonState


  		





  
  158
  
    
                  =<< daemonHandle


  		





  
  159
  
    

  		





  141
  160
  
    
-- | Atomically modifies the configuration state in the WConfdMonad.


  		





  142
  161
  
    
modifyConfigState :: (ConfigState -> (ConfigState, a)) -> WConfdMonad a


  		





  143
  162
  
    
modifyConfigState f = do


  		





  144
  
  
    
  dh <- lift . WConfdMonadInt $ ask


  		





  
  163
  
    
  dh <- daemonHandle


  		





  145
  164
  
    
  -- TODO: Use lenses to modify the daemons state here


  		





  146
  165
  
    
  let mf ds = let (cs', r) = f (dsConfigState ds)


  		





  147
  166
  
    
              in (ds { dsConfigState = cs' }, r)


  		





  148
  
  
    
  liftBase $ atomicModifyIORef (dhDaemonState dh) mf


  		





  
  167
  
    
  r <- atomicModifyIORef (dhDaemonState dh) mf


  		





  
  168
  
    
  -- trigger the config. saving worker and wait for it


  		





  
  169
  
    
  logDebug "Triggering config write"


  		





  
  170
  
    
  liftBase . triggerAndWait . dhSaveConfigWorker $ dh


  		





  
  171
  
    
  logDebug "Config write finished"


  		





  
  172
  
    
  -- trigger the config. distribution worker asynchronously


  		





  
  173
  
    
  -- TODO


  		





  
  174
  
    
  return r


  		





  149
  175
  
    

  		





  150
  176
  
    
-- | Atomically modifies the lock allocation state in WConfdMonad.


  		





  151
  177
  
    
modifyLockAllocation :: (GanetiLockAllocation -> (GanetiLockAllocation, a))


  		





  ......




  154
  180
  
    
  dh <- lift . WConfdMonadInt $ ask


  		





  155
  181
  
    
  let mf ds = let (la', r) = f (dsLockAllocation ds)


  		





  156
  182
  
    
              in (ds { dsLockAllocation = la' }, r)


  		





  157
  
  
    
  liftBase $ atomicModifyIORef (dhDaemonState dh) mf


  		





  
  183
  
    
  atomicModifyIORef (dhDaemonState dh) mf


  		





  
  184
  
    
  -- TODO: Trigger the async. lock saving worker


  		












Also available in:
  Unified diff