This commit is contained in:
Joey Hess 2012-07-29 08:52:57 -04:00
parent 62dac85880
commit 57203e3981
4 changed files with 47 additions and 42 deletions

View file

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

View file

@ -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

View file

@ -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

View file

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