refactor

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)

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
 

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

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 ()