[PATCH stable-2.12 05/10] Utility function for modifying an IORef using a lens

['Petr Pudlak' via ganeti-devel]

.. and a supplied function that works inside the lens.

Signed-off-by: Petr Pudlak <pud...@google.com>
---
 src/Ganeti/WConfd/Monad.hs | 19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

diff --git a/src/Ganeti/WConfd/Monad.hs b/src/Ganeti/WConfd/Monad.hs
index 4a676f3..0130b8f 100644
--- a/src/Ganeti/WConfd/Monad.hs
+++ b/src/Ganeti/WConfd/Monad.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, RankNTypes #-}
 
 {-| All RPC calls are run within this monad.
 
@@ -125,6 +125,13 @@ mkDaemonHandle cpath cstat lstat
   return $ DaemonHandle ds cpath saveWorker distMCsWorker ssconfWorker
                                  saveLockWorker
 
+-- * Utility functions
+
+-- | Atomically modifies an 'IORef' using a lens
+atomicModifyWithLens :: (MonadBase IO m)
+                     => IORef a -> Lens a a b c -> (b -> (r, c)) -> m r
+atomicModifyWithLens ref l f = atomicModifyIORef ref (swap . traverseOf l f)
+
 -- * The monad and its instances
 
 -- | A type alias for easier referring to the actual content of the monad
@@ -187,8 +194,7 @@ modifyConfigState f = do
   dh <- daemonHandle
   let modCS cs = let (cs', r) = f cs
                   in ((r, cs /= cs'), cs')
-  let mf = traverseOf dsConfigStateL modCS
-  (r, modified) <- atomicModifyIORef (dhDaemonState dh) (swap . mf)
+  (r, modified) <- atomicModifyWithLens (dhDaemonState dh) dsConfigStateL modCS
   when modified $ do
     -- trigger the config. saving worker and wait for it
     logDebug "Triggering config write"
@@ -209,10 +215,9 @@ modifyLockWaiting :: (GanetiLockWaiting -> ( 
GanetiLockWaiting
                      -> WConfdMonad a
 modifyLockWaiting f = do
   dh <- lift . WConfdMonadInt $ ask
-  let f' = swap . (fst &&& id) . f
-  (lockAlloc, (r, nfy)) <- atomicModifyIORef
-                             (dhDaemonState dh)
-                             (swap . traverseOf dsLockWaitingL f')
+  let f' = (id &&& fst) . f
+  (lockAlloc, (r, nfy)) <- atomicModifyWithLens
+                             (dhDaemonState dh) dsLockWaitingL f'
   logDebug $ "Current lock status: " ++ J.encode lockAlloc
   logDebug "Triggering lock state write"
   liftBase . triggerAndWait . dhSaveLocksWorker $ dh
-- 
1.9.1.423.g4596e3a