Revision e45eeb79 src/Ganeti/WConfd/Monad.hs

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

  		





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


  		





  4
  5
  
    

  		





  ......




  56
  57
  
    
import Control.Monad.Reader


  		





  57
  58
  
    
import Control.Monad.Trans.Control


  		





  58
  59
  
    
import Data.IORef.Lifted


  		





  
  60
  
    
import Data.Tuple (swap)


  		





  59
  61
  
    

  		





  60
  62
  
    
import Ganeti.BasicTypes


  		





  61
  63
  
    
import Ganeti.Errors


  		





  
  64
  
    
import Ganeti.Lens


  		





  62
  65
  
    
import Ganeti.Locking.Locks


  		





  63
  66
  
    
import Ganeti.Logging


  		





  64
  67
  
    
import Ganeti.Utils.AsyncWorker


  		





  ......




  73
  76
  
    
  , dsLockAllocation :: GanetiLockAllocation


  		





  74
  77
  
    
  }


  		





  75
  78
  
    

  		





  
  79
  
    
$(makeCustomLenses ''DaemonState)


  		





  
  80
  
    

  		





  76
  81
  
    
data DaemonHandle = DaemonHandle


  		





  77
  82
  
    
  { dhDaemonState :: IORef DaemonState -- ^ The current state of the daemon


  		





  78
  83
  
    
  , dhConfigPath :: FilePath           -- ^ The configuration file path


  		





  ......




  159
  164
  
    
modifyConfigState :: (ConfigState -> (ConfigState, a)) -> WConfdMonad a


  		





  160
  165
  
    
modifyConfigState f = do


  		





  161
  166
  
    
  dh <- daemonHandle


  		





  162
  
  
    
  -- TODO: Use lenses to modify the daemons state here


  		





  163
  
  
    
  let mf ds = let cs = dsConfigState ds


  		





  164
  
  
    
                  (cs', r) = f cs


  		





  165
  
  
    
              in (ds { dsConfigState = cs' }, (r, cs /= cs'))


  		





  166
  
  
    
  (r, modified) <- atomicModifyIORef (dhDaemonState dh) mf


  		





  
  167
  
    
  let modCS cs = let (cs', r) = f cs


  		





  
  168
  
    
                  in ((r, cs /= cs'), cs')


  		





  
  169
  
    
  let mf = traverseOf dsConfigStateL modCS


  		





  
  170
  
    
  (r, modified) <- atomicModifyIORef (dhDaemonState dh) (swap . mf)


  		





  167
  171
  
    
  when modified $ do


  		





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


  		





  169
  173
  
    
    logDebug "Triggering config write"


  		





  ......




  178
  182
  
    
                     -> WConfdMonad a


  		





  179
  183
  
    
modifyLockAllocation f = do


  		





  180
  184
  
    
  dh <- lift . WConfdMonadInt $ ask


  		





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


  		





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


  		





  183
  
  
    
  r <- atomicModifyIORef (dhDaemonState dh) mf


  		





  
  185
  
    
  r <- atomicModifyIORef (dhDaemonState dh)


  		





  
  186
  
    
                         (swap . traverseOf dsLockAllocationL (swap . f))


  		





  184
  187
  
    
  logDebug "Triggering lock state write"


  		





  185
  188
  
    
  liftBase . triggerAndWait . dhSaveLocksWorker $ dh


  		





  186
  189
  
    
  logDebug "Lock write finished"


  		












Also available in:
  Unified diff