.. and a supplied function that works inside the lens.
Signed-off-by: Petr Pudlak <[email protected]>
---
Makefile.am | 1 +
src/Ganeti/Utils/IORef.hs | 40 ++++++++++++++++++++++++++++++++++++++++
src/Ganeti/WConfd/Monad.hs | 14 ++++++--------
3 files changed, 47 insertions(+), 8 deletions(-)
create mode 100644 src/Ganeti/Utils/IORef.hs
diff --git a/Makefile.am b/Makefile.am
index 48ac4c7..c464eb9 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -860,6 +860,7 @@ HS_LIB_SRCS = \
src/Ganeti/Utils.hs \
src/Ganeti/Utils/Atomic.hs \
src/Ganeti/Utils/AsyncWorker.hs \
+ src/Ganeti/Utils/IORef.hs \
src/Ganeti/Utils/Livelock.hs \
src/Ganeti/Utils/MonadPlus.hs \
src/Ganeti/VCluster.hs \
diff --git a/src/Ganeti/Utils/IORef.hs b/src/Ganeti/Utils/IORef.hs
new file mode 100644
index 0000000..44645f8
--- /dev/null
+++ b/src/Ganeti/Utils/IORef.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE FlexibleContexts, RankNTypes #-}
+
+{-| Utility functions for working with IORefs. -}
+
+{-
+
+Copyright (C) 2014 Google Inc.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.
+
+-}
+
+module Ganeti.Utils.IORef
+ ( atomicModifyWithLens
+ ) where
+
+import Control.Monad.Base
+import Data.IORef.Lifted
+import Data.Tuple (swap)
+
+import Ganeti.BasicTypes
+import Ganeti.Lens
+
+-- | 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)
diff --git a/src/Ganeti/WConfd/Monad.hs b/src/Ganeti/WConfd/Monad.hs
index 4a676f3..f1e6b18 100644
--- a/src/Ganeti/WConfd/Monad.hs
+++ b/src/Ganeti/WConfd/Monad.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-| All RPC calls are run within this monad.
@@ -58,7 +58,6 @@ import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.IORef.Lifted
import qualified Data.Set as S
-import Data.Tuple (swap)
import qualified Text.JSON as J
import Ganeti.BasicTypes
@@ -69,6 +68,7 @@ import Ganeti.Locking.Locks
import Ganeti.Locking.Waiting (getAllocation)
import Ganeti.Logging
import Ganeti.Utils.AsyncWorker
+import Ganeti.Utils.IORef
import Ganeti.WConfd.ConfigState
-- * Pure data types used in the monad
@@ -187,8 +187,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 +208,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
