diff options
author | Joey Hess <joey@kitenet.net> | 2012-07-29 08:52:57 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-07-29 08:52:57 -0400 |
commit | 57203e39811e4e769a6feb576a8779707664c40d (patch) | |
tree | b8b87a96027fa6a9804af9dd7e7d8ccbb685eaf4 | |
parent | 62dac858807da8fb62ce55adbed84cfe582367b2 (diff) |
refactor
-rw-r--r-- | Assistant/DaemonStatus.hs | 47 | ||||
-rw-r--r-- | Assistant/Threads/Transferrer.hs | 3 | ||||
-rw-r--r-- | Assistant/Threads/WebApp.hs | 37 | ||||
-rw-r--r-- | Assistant/TransferQueue.hs | 2 |
4 files changed, 47 insertions, 42 deletions
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 3610c2fda..958a816c0 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -35,9 +35,10 @@ data DaemonStatus = DaemonStatus , currentTransfers :: TransferMap -- Ordered list of remotes to talk to. , knownRemotes :: [Remote] - -- Clients can use this to wait on changes to the DaemonStatus - -- and other related things like the TransferQueue. - , notificationBroadcaster :: NotificationBroadcaster + -- Broadcasts notifications about all changes to the DaemonStatus + , changeNotifier :: NotificationBroadcaster + -- Broadcasts notifications when queued or running transfers change. + , transferNotifier :: NotificationBroadcaster } type TransferMap = M.Map Transfer TransferInfo @@ -47,7 +48,8 @@ type DaemonStatusHandle = TMVar DaemonStatus newDaemonStatus :: IO DaemonStatus newDaemonStatus = do - nb <- newNotificationBroadcaster + cn <- newNotificationBroadcaster + tn <- newNotificationBroadcaster return $ DaemonStatus { scanComplete = False , lastRunning = Nothing @@ -55,7 +57,8 @@ newDaemonStatus = do , lastSanityCheck = Nothing , currentTransfers = M.empty , knownRemotes = [] - , notificationBroadcaster = nb + , changeNotifier = cn + , transferNotifier = tn } getDaemonStatus :: DaemonStatusHandle -> IO DaemonStatus @@ -66,19 +69,13 @@ modifyDaemonStatus_ handle a = modifyDaemonStatus handle $ \s -> (a s, ()) modifyDaemonStatus :: DaemonStatusHandle -> (DaemonStatus -> (DaemonStatus, b)) -> IO b modifyDaemonStatus handle a = do - (b, nb) <- atomically $ do - (s, b) <- a <$> takeTMVar handle + (s, b) <- atomically $ do + r@(s, _) <- a <$> takeTMVar handle putTMVar handle s - return $ (b, notificationBroadcaster s) - sendNotification nb + return r + sendNotification $ changeNotifier s return b -{- Can be used to send a notification that the daemon status, or other - - associated thing, like the TransferQueue, has changed. -} -notifyDaemonStatusChange :: DaemonStatusHandle -> IO () -notifyDaemonStatusChange handle = sendNotification - =<< notificationBroadcaster <$> atomically (readTMVar handle) - {- Updates the cached ordered list of remotes from the list in Annex - state. -} updateKnownRemotes :: DaemonStatusHandle -> Annex () @@ -108,11 +105,11 @@ startDaemonStatus = do -} daemonStatusThread :: ThreadState -> DaemonStatusHandle -> IO () daemonStatusThread st handle = do - bhandle <- newNotificationHandle - =<< notificationBroadcaster <$> getDaemonStatus handle + notifier <- newNotificationHandle + =<< changeNotifier <$> getDaemonStatus handle checkpoint runEvery (Seconds tenMinutes) $ do - waitNotification bhandle + waitNotification notifier checkpoint where checkpoint = do @@ -182,15 +179,23 @@ adjustTransfersSTM dstatus a = do {- Variant that does send notifications. -} adjustTransfers :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> IO () -adjustTransfers dstatus a = modifyDaemonStatus_ dstatus $ - \s -> s { currentTransfers = a (currentTransfers s) } +adjustTransfers dstatus a = + notifyTransfer dstatus `after` modifyDaemonStatus_ dstatus go + where + go 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 = modifyDaemonStatus dstatus go +removeTransfer dstatus t = + notifyTransfer dstatus `after` modifyDaemonStatus dstatus go where go 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 handle = sendNotification + =<< transferNotifier <$> atomically (readTMVar handle) diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index f011ff036..a801556db 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -38,14 +38,13 @@ transfererThread st dstatus transferqueue slots = go ifM (runThreadState st $ shouldTransfer dstatus t info) ( do debug thisThread [ "Transferring:" , show t ] - notifyDaemonStatusChange dstatus + notifyTransfer dstatus transferThread st dstatus slots t info , do debug thisThread [ "Skipping unnecessary transfer:" , show t ] -- getNextTransfer added t to the -- daemonstatus's transfer map. void $ removeTransfer dstatus t - notifyDaemonStatusChange dstatus ) go diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 500297693..3db5f368c 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings #-} +{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Assistant.Threads.WebApp where @@ -47,9 +47,20 @@ data WebApp = WebApp , getStatic :: Static } -getNotificationBroadcaster :: WebApp -> IO NotificationBroadcaster -getNotificationBroadcaster webapp = notificationBroadcaster - <$> getDaemonStatus (daemonStatus webapp) +waitNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp () +waitNotifier selector nid = do + notifier <- getNotifier selector + liftIO $ waitNotification $ notificationHandleFromId notifier nid + +newNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationId +newNotifier selector = do + notifier <- getNotifier selector + liftIO $ notificationHandleToId <$> newNotificationHandle notifier + +getNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationBroadcaster +getNotifier selector = do + webapp <- getYesod + liftIO $ selector <$> getDaemonStatus (daemonStatus webapp) staticFiles "static" @@ -133,10 +144,7 @@ transfersDisplayIdent = "transfers" -} getTransfersR :: NotificationId -> Handler RepHtml getTransfersR nid = do - {- Block until there is a change from last time. -} - webapp <- getYesod - b <- liftIO $ getNotificationBroadcaster webapp - liftIO $ waitNotification $ notificationHandleFromId b nid + waitNotifier transferNotifier nid page <- widgetToPageContent $ transfersDisplay False hamletToRepHtml $ [hamlet|^{pageBody page}|] @@ -149,9 +157,7 @@ sideBarDisplay noScript = do $(widgetFile "sidebar") unless noScript $ do {- Set up automatic updates of the sidebar. -} - webapp <- lift getYesod - nid <- liftIO $ notificationHandleToId <$> - (newNotificationHandle =<< getNotificationBroadcaster webapp) + nid <- lift $ newNotifier transferNotifier autoUpdate ident (SideBarR nid) (10 :: Int) (10 :: Int) {- Called by client to get a sidebar display. @@ -164,10 +170,7 @@ sideBarDisplay noScript = do -} getSideBarR :: NotificationId -> Handler RepHtml getSideBarR nid = do - {- Block until there is a change from last time. -} - webapp <- getYesod - b <- liftIO $ getNotificationBroadcaster webapp - liftIO $ waitNotification $ notificationHandleFromId b nid + waitNotifier transferNotifier nid page <- widgetToPageContent $ sideBarDisplay True hamletToRepHtml $ [hamlet|^{pageBody page}|] @@ -180,9 +183,7 @@ dashboard noScript warnNoScript = do getHomeR :: Handler RepHtml getHomeR = defaultLayout $ do {- Set up automatic updates for the transfers display. -} - webapp <- lift getYesod - nid <- liftIO $ notificationHandleToId <$> - (newNotificationHandle =<< getNotificationBroadcaster webapp) + nid <- lift $ newNotifier transferNotifier autoUpdate transfersDisplayIdent (TransfersR nid) (10 :: Int) (10 :: Int) dashboard False True diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index 51ed5c9c7..01c159b08 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -95,7 +95,7 @@ enqueue schedule q dstatus t info void $ modqueue (queue q) new void $ modifyTVar' (queuesize q) succ void $ modifyTVar' (queuelist q) modlist - void $ notifyDaemonStatusChange dstatus + void $ notifyTransfer dstatus {- Adds a transfer to the queue. -} queueTransfer :: Schedule -> TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO () |