refactor
This commit is contained in:
parent
62dac85880
commit
57203e3981
4 changed files with 47 additions and 42 deletions
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ()
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue