summaryrefslogtreecommitdiff
path: root/Assistant/DaemonStatus.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-10-30 15:39:15 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-10-30 15:39:15 -0400
commit07cd1b2b40735d460c8225762fcf3992b9886c60 (patch)
treec08c38417dfd9cba94ac56e212fa9d5864927ac0 /Assistant/DaemonStatus.hs
parentbab7e83221468905b76e28bb123ebe26e146b97b (diff)
pushed Assistant monad down into DaemonStatus code
Currently have three old versions of functions that more reworking is needed to remove: getDaemonStatusOld, modifyDaemonStatusOld_, and modifyDaemonStatusOld
Diffstat (limited to 'Assistant/DaemonStatus.hs')
-rw-r--r--Assistant/DaemonStatus.hs107
1 files changed, 62 insertions, 45 deletions
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index 1706c0a57..4223b6ce9 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -31,11 +31,16 @@ getDaemonStatusOld = atomically . readTMVar
getDaemonStatus :: Assistant DaemonStatus
getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle
-modifyDaemonStatus_ :: DaemonStatusHandle -> (DaemonStatus -> DaemonStatus) -> IO ()
-modifyDaemonStatus_ dstatus a = modifyDaemonStatus dstatus $ \s -> (a s, ())
+-- TODO remove this
+modifyDaemonStatusOld_ :: DaemonStatusHandle -> (DaemonStatus -> DaemonStatus) -> IO ()
+modifyDaemonStatusOld_ dstatus a = modifyDaemonStatusOld dstatus $ \s -> (a s, ())
+
+modifyDaemonStatus_ :: (DaemonStatus -> DaemonStatus) -> Assistant ()
+modifyDaemonStatus_ a = modifyDaemonStatus $ \s -> (a s, ())
-modifyDaemonStatus :: DaemonStatusHandle -> (DaemonStatus -> (DaemonStatus, b)) -> IO b
-modifyDaemonStatus dstatus a = do
+-- TODO remove this
+modifyDaemonStatusOld :: DaemonStatusHandle -> (DaemonStatus -> (DaemonStatus, b)) -> IO b
+modifyDaemonStatusOld dstatus a = do
(s, b) <- atomically $ do
r@(s, _) <- a <$> takeTMVar dstatus
putTMVar dstatus s
@@ -43,6 +48,17 @@ modifyDaemonStatus dstatus a = do
sendNotification $ changeNotifier s
return b
+modifyDaemonStatus :: (DaemonStatus -> (DaemonStatus, b)) -> Assistant b
+modifyDaemonStatus a = do
+ dstatus <- getAssistant daemonStatusHandle
+ liftIO $ do
+ (s, b) <- atomically $ do
+ r@(s, _) <- a <$> takeTMVar dstatus
+ putTMVar dstatus s
+ return r
+ sendNotification $ changeNotifier s
+ return b
+
{- Syncable remotes ordered by cost. -}
calcSyncRemotes :: Annex [Remote]
calcSyncRemotes = do
@@ -53,11 +69,10 @@ calcSyncRemotes = do
return $ filter good rs
{- Updates the sycRemotes list from the list of all remotes in Annex state. -}
-updateSyncRemotes :: DaemonStatusHandle -> Annex ()
-updateSyncRemotes dstatus = do
- remotes <- calcSyncRemotes
- liftIO $ modifyDaemonStatus_ dstatus $
- \s -> s { syncRemotes = remotes }
+updateSyncRemotes :: Assistant ()
+updateSyncRemotes = do
+ remotes <- liftAnnex calcSyncRemotes
+ modifyDaemonStatus_ $ \s -> s { syncRemotes = remotes }
{- Load any previous daemon status file, and store it in a MVar for this
- process to use as its DaemonStatus. Also gets current transfer status. -}
@@ -136,15 +151,14 @@ adjustTransfersSTM dstatus a = do
putTMVar dstatus $ s { currentTransfers = a (currentTransfers s) }
{- Alters a transfer's info, if the transfer is in the map. -}
-alterTransferInfo :: DaemonStatusHandle -> Transfer -> (TransferInfo -> TransferInfo) -> IO ()
-alterTransferInfo dstatus t a = updateTransferInfo' dstatus $ M.adjust a t
+alterTransferInfo :: Transfer -> (TransferInfo -> TransferInfo) -> Assistant ()
+alterTransferInfo t a = updateTransferInfo' $ M.adjust a t
{- Updates a transfer's info. Adds the transfer to the map if necessary,
- or if already present, updates it while preserving the old transferTid,
- transferPaused, and bytesComplete values, which are not written to disk. -}
-updateTransferInfo :: DaemonStatusHandle -> Transfer -> TransferInfo -> IO ()
-updateTransferInfo dstatus t info = updateTransferInfo' dstatus $
- M.insertWith' merge t info
+updateTransferInfo :: Transfer -> TransferInfo -> Assistant ()
+updateTransferInfo t info = updateTransferInfo' $ M.insertWith' merge t info
where
merge new old = new
{ transferTid = maybe (transferTid new) Just (transferTid old)
@@ -152,52 +166,59 @@ updateTransferInfo dstatus t info = updateTransferInfo' dstatus $
, bytesComplete = maybe (bytesComplete new) Just (bytesComplete old)
}
-updateTransferInfo' :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> IO ()
-updateTransferInfo' dstatus a =
- notifyTransfer dstatus `after` modifyDaemonStatus_ dstatus go
+updateTransferInfo' :: (TransferMap -> TransferMap) -> Assistant ()
+updateTransferInfo' a = notifyTransfer `after` modifyDaemonStatus_ update
where
- go s = s { currentTransfers = a (currentTransfers s) }
+ update s = s { currentTransfers = a (currentTransfers s) }
{- Removes a transfer from the map, and returns its info. -}
-removeTransfer :: DaemonStatusHandle -> Transfer -> IO (Maybe TransferInfo)
-removeTransfer dstatus t =
- notifyTransfer dstatus `after` modifyDaemonStatus dstatus go
+removeTransfer :: Transfer -> Assistant (Maybe TransferInfo)
+removeTransfer t = notifyTransfer `after` modifyDaemonStatus remove
where
- go s =
+ remove s =
let (info, ts) = M.updateLookupWithKey
(\_k _v -> Nothing)
t (currentTransfers s)
in (s { currentTransfers = ts }, info)
{- Send a notification when a transfer is changed. -}
-notifyTransfer :: DaemonStatusHandle -> IO ()
-notifyTransfer dstatus = sendNotification
+notifyTransfer :: Assistant ()
+notifyTransfer = do
+ dstatus <- getAssistant daemonStatusHandle
+ liftIO $ sendNotification
+ =<< transferNotifier <$> atomically (readTMVar dstatus)
+
+-- TODO remove
+notifyTransferOld :: DaemonStatusHandle -> IO ()
+notifyTransferOld dstatus = sendNotification
=<< transferNotifier <$> atomically (readTMVar dstatus)
{- Send a notification when alerts are changed. -}
-notifyAlert :: DaemonStatusHandle -> IO ()
-notifyAlert dstatus = sendNotification
- =<< alertNotifier <$> atomically (readTMVar dstatus)
+notifyAlert :: Assistant ()
+notifyAlert = do
+ dstatus <- getAssistant daemonStatusHandle
+ liftIO $ sendNotification
+ =<< alertNotifier <$> atomically (readTMVar dstatus)
{- Returns the alert's identifier, which can be used to remove it. -}
-addAlert :: DaemonStatusHandle -> Alert -> IO AlertId
-addAlert dstatus alert = notifyAlert dstatus `after` modifyDaemonStatus dstatus go
+addAlert :: Alert -> Assistant AlertId
+addAlert alert = notifyAlert `after` modifyDaemonStatus add
where
- go s = (s { lastAlertId = i, alertMap = m }, i)
+ add s = (s { lastAlertId = i, alertMap = m }, i)
where
i = nextAlertId $ lastAlertId s
m = mergeAlert i alert (alertMap s)
-removeAlert :: DaemonStatusHandle -> AlertId -> IO ()
-removeAlert dstatus i = updateAlert dstatus i (const Nothing)
+removeAlert :: AlertId -> Assistant ()
+removeAlert i = updateAlert i (const Nothing)
-updateAlert :: DaemonStatusHandle -> AlertId -> (Alert -> Maybe Alert) -> IO ()
-updateAlert dstatus i a = updateAlertMap dstatus $ \m -> M.update a i m
+updateAlert :: AlertId -> (Alert -> Maybe Alert) -> Assistant ()
+updateAlert i a = updateAlertMap $ \m -> M.update a i m
-updateAlertMap :: DaemonStatusHandle -> (AlertMap -> AlertMap) -> IO ()
-updateAlertMap dstatus a = notifyAlert dstatus `after` modifyDaemonStatus_ dstatus go
+updateAlertMap :: (AlertMap -> AlertMap) -> Assistant ()
+updateAlertMap a = notifyAlert `after` modifyDaemonStatus_ update
where
- go s = s { alertMap = a (alertMap s) }
+ update s = s { alertMap = a (alertMap s) }
{- Displays an alert while performing an activity that returns True on
- success.
@@ -213,17 +234,13 @@ alertWhile alert a = alertWhile' alert $ do
alertWhile' :: Alert -> Assistant (Bool, a) -> Assistant a
alertWhile' alert a = do
let alert' = alert { alertClass = Activity }
- dstatus <- getAssistant daemonStatusHandle
- i <- liftIO $ addAlert dstatus alert'
+ i <- addAlert alert'
(ok, r) <- a
- liftIO $ updateAlertMap dstatus $
- mergeAlert i $ makeAlertFiller ok alert'
+ updateAlertMap $ mergeAlert i $ makeAlertFiller ok alert'
return r
{- Displays an alert while performing an activity, then removes it. -}
alertDuring :: Alert -> Assistant a -> Assistant a
alertDuring alert a = do
- let alert' = alert { alertClass = Activity }
- dstatus <- getAssistant daemonStatusHandle
- i <- liftIO $ addAlert dstatus alert'
- liftIO (removeAlert dstatus i) `after` a
+ i <- addAlert $ alert { alertClass = Activity }
+ removeAlert i `after` a