git-annex/Assistant/DaemonStatus.hs

259 lines
9.1 KiB
Haskell
Raw Normal View History

2012-06-13 16:36:33 +00:00
{- git-annex assistant daemon status
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
2012-06-23 05:20:40 +00:00
-
- Licensed under the GNU GPL version 3 or higher.
2012-06-13 16:36:33 +00:00
-}
module Assistant.DaemonStatus where
2012-10-30 18:34:48 +00:00
import Assistant.Common
2013-04-04 05:48:26 +00:00
import Assistant.Alert.Utility
2013-05-12 23:19:28 +00:00
import Utility.Tmp
import Assistant.Types.NetMessager
import Utility.NotificationBroadcaster
import Logs.Transfer
import Logs.Trust
import qualified Remote
import qualified Types.Remote as Remote
import qualified Git
2012-06-13 16:36:33 +00:00
import Control.Concurrent.STM
2012-06-13 16:36:33 +00:00
import System.Posix.Types
import Data.Time.Clock.POSIX
import Data.Time
import System.Locale
2012-07-02 20:11:04 +00:00
import qualified Data.Map as M
import qualified Data.Text as T
2012-06-13 16:36:33 +00:00
2012-10-30 18:44:18 +00:00
getDaemonStatus :: Assistant DaemonStatus
getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle
2012-06-13 16:36:33 +00:00
modifyDaemonStatus_ :: (DaemonStatus -> DaemonStatus) -> Assistant ()
modifyDaemonStatus_ a = modifyDaemonStatus $ \s -> (a s, ())
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
{- Returns a function that updates the lists of syncable remotes
- and other associated information. -}
calcSyncRemotes :: Annex (DaemonStatus -> DaemonStatus)
2012-10-14 18:47:01 +00:00
calcSyncRemotes = do
rs <- filter (remoteAnnexSync . Remote.gitconfig) .
concat . Remote.byCost <$> Remote.remoteList
2012-11-11 04:26:29 +00:00
alive <- trustExclude DeadTrusted (map Remote.uuid rs)
let good r = Remote.uuid r `elem` alive
let syncable = filter good rs
let syncdata = filter (not . remoteAnnexIgnore . Remote.gitconfig) $
filter (not . isXMPPRemote) syncable
return $ \dstatus -> dstatus
{ syncRemotes = syncable
2013-09-09 13:58:17 +00:00
, syncGitRemotes = filter Remote.syncableRemote syncable
, syncDataRemotes = syncdata
, syncingToCloudRemote = any iscloud syncdata
}
2013-03-15 23:16:13 +00:00
where
iscloud r = not (Remote.readonly r) && Remote.globallyAvailable r
2013-03-28 21:11:53 +00:00
{- Updates the syncRemotes list from the list of all remotes in Annex state. -}
updateSyncRemotes :: Assistant ()
2012-11-13 21:50:54 +00:00
updateSyncRemotes = do
modifyDaemonStatus_ =<< liftAnnex calcSyncRemotes
status <- getDaemonStatus
liftIO $ sendNotification $ syncRemotesNotifier status
2013-03-15 23:16:13 +00:00
when (syncingToCloudRemote status) $
updateAlertMap $
M.filter $ \alert ->
alertName alert /= Just CloudRepoNeededAlert
2012-07-22 19:06:18 +00:00
{- Load any previous daemon status file, and store it in a MVar for this
2012-07-02 20:11:04 +00:00
- process to use as its DaemonStatus. Also gets current transfer status. -}
2012-06-13 18:02:40 +00:00
startDaemonStatus :: Annex DaemonStatusHandle
startDaemonStatus = do
file <- fromRepo gitAnnexDaemonStatusFile
status <- liftIO $
2012-09-17 04:18:07 +00:00
flip catchDefaultIO (readDaemonStatusFile file) =<< newDaemonStatus
2012-07-02 20:11:04 +00:00
transfers <- M.fromList <$> getTransfers
addsync <- calcSyncRemotes
liftIO $ atomically $ newTMVar $ addsync $ status
{ scanComplete = False
, sanityCheckRunning = False
2012-07-02 20:11:04 +00:00
, currentTransfers = transfers
}
2012-06-13 18:02:40 +00:00
{- Don't just dump out the structure, because it will change over time,
- and parts of it are not relevant. -}
writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO ()
writeDaemonStatusFile file status =
viaTmp writeFile file =<< serialized <$> getPOSIXTime
2012-10-31 06:34:03 +00:00
where
serialized now = unlines
[ "lastRunning:" ++ show now
, "scanComplete:" ++ show (scanComplete status)
, "sanityCheckRunning:" ++ show (sanityCheckRunning status)
, "lastSanityCheck:" ++ maybe "" show (lastSanityCheck status)
]
readDaemonStatusFile :: FilePath -> IO DaemonStatus
readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file
2012-10-31 06:34:03 +00:00
where
parse status = foldr parseline status . lines
parseline line status
| key == "lastRunning" = parseval readtime $ \v ->
status { lastRunning = Just v }
| key == "scanComplete" = parseval readish $ \v ->
status { scanComplete = v }
| key == "sanityCheckRunning" = parseval readish $ \v ->
status { sanityCheckRunning = v }
| key == "lastSanityCheck" = parseval readtime $ \v ->
status { lastSanityCheck = Just v }
| otherwise = status -- unparsable line
where
(key, value) = separate (== ':') line
parseval parser a = maybe status a (parser value)
readtime s = do
d <- parseTime defaultTimeLocale "%s%Qs" s
Just $ utcTimeToPOSIXSeconds d
{- Checks if a time stamp was made after the daemon was lastRunning.
-
- Some slop is built in; this really checks if the time stamp was made
- at least ten minutes after the daemon was lastRunning. This is to
- ensure the daemon shut down cleanly, and deal with minor clock skew.
-
- If the daemon has never ran before, this always returns False.
-}
afterLastDaemonRun :: EpochTime -> DaemonStatus -> Bool
2012-06-13 18:02:40 +00:00
afterLastDaemonRun timestamp status = maybe False (< t) (lastRunning status)
2012-10-31 06:34:03 +00:00
where
t = realToFrac (timestamp + slop) :: POSIXTime
slop = fromIntegral tenMinutes
2012-06-13 18:19:21 +00:00
tenMinutes :: Int
tenMinutes = 10 * 60
2012-07-05 20:34:20 +00:00
{- Mutates the transfer map. Runs in STM so that the transfer map can
- be modified in the same transaction that modifies the transfer queue.
- Note that this does not send a notification of the change; that's left
- to the caller. -}
adjustTransfersSTM :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> STM ()
adjustTransfersSTM dstatus a = do
s <- takeTMVar dstatus
putTMVar dstatus $ s { currentTransfers = a (currentTransfers s) }
{- Checks if a transfer is currently running. -}
checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool
checkRunningTransferSTM dstatus t = M.member t . currentTransfers
<$> readTMVar dstatus
{- Alters a transfer's info, if the transfer is in the map. -}
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 :: Transfer -> TransferInfo -> Assistant ()
updateTransferInfo t info = updateTransferInfo' $ M.insertWith' merge t info
2012-10-31 06:34:03 +00:00
where
merge new old = new
{ transferTid = maybe (transferTid new) Just (transferTid old)
, transferPaused = transferPaused new || transferPaused old
, bytesComplete = maybe (bytesComplete new) Just (bytesComplete old)
}
updateTransferInfo' :: (TransferMap -> TransferMap) -> Assistant ()
updateTransferInfo' a = notifyTransfer `after` modifyDaemonStatus_ update
2012-10-31 06:34:03 +00:00
where
update s = s { currentTransfers = a (currentTransfers s) }
{- Removes a transfer from the map, and returns its info. -}
removeTransfer :: Transfer -> Assistant (Maybe TransferInfo)
removeTransfer t = notifyTransfer `after` modifyDaemonStatus remove
2012-10-31 06:34:03 +00:00
where
remove s =
let (info, ts) = M.updateLookupWithKey
(\_k _v -> Nothing)
t (currentTransfers s)
in (s { currentTransfers = ts }, info)
2012-07-29 12:52:57 +00:00
{- Send a notification when a transfer is changed. -}
notifyTransfer :: Assistant ()
notifyTransfer = do
dstatus <- getAssistant daemonStatusHandle
liftIO $ sendNotification
=<< transferNotifier <$> atomically (readTMVar dstatus)
2012-07-29 13:35:01 +00:00
{- Send a notification when alerts are changed. -}
notifyAlert :: Assistant ()
notifyAlert = do
dstatus <- getAssistant daemonStatusHandle
liftIO $ sendNotification
=<< alertNotifier <$> atomically (readTMVar dstatus)
2012-10-30 18:34:48 +00:00
{- Returns the alert's identifier, which can be used to remove it. -}
addAlert :: Alert -> Assistant AlertId
2013-01-15 18:09:35 +00:00
addAlert alert = do
notice [showAlert alert]
2013-01-15 18:09:35 +00:00
notifyAlert `after` modifyDaemonStatus add
2012-10-31 06:34:03 +00:00
where
add s = (s { lastAlertId = i, alertMap = m }, i)
where
i = nextAlertId $ lastAlertId s
m = mergeAlert i alert (alertMap s)
2012-10-30 18:34:48 +00:00
removeAlert :: AlertId -> Assistant ()
removeAlert i = updateAlert i (const Nothing)
2012-10-30 18:34:48 +00:00
updateAlert :: AlertId -> (Alert -> Maybe Alert) -> Assistant ()
updateAlert i a = updateAlertMap $ \m -> M.update a i m
2012-10-30 18:34:48 +00:00
updateAlertMap :: (AlertMap -> AlertMap) -> Assistant ()
updateAlertMap a = notifyAlert `after` modifyDaemonStatus_ update
2012-10-31 06:34:03 +00:00
where
update s = s { alertMap = a (alertMap s) }
2012-10-30 18:34:48 +00:00
{- Displays an alert while performing an activity that returns True on
- success.
-
- The alert is left visible afterwards, as filler.
- Old filler is pruned, to prevent the map growing too large. -}
alertWhile :: Alert -> Assistant Bool -> Assistant Bool
alertWhile alert a = alertWhile' alert $ do
r <- a
return (r, r)
{- Like alertWhile, but allows the activity to return a value too. -}
alertWhile' :: Alert -> Assistant (Bool, a) -> Assistant a
alertWhile' alert a = do
let alert' = alert { alertClass = Activity }
i <- addAlert alert'
2012-10-30 18:34:48 +00:00
(ok, r) <- a
updateAlertMap $ mergeAlert i $ makeAlertFiller ok alert'
2012-10-30 18:34:48 +00:00
return r
{- Displays an alert while performing an activity, then removes it. -}
alertDuring :: Alert -> Assistant a -> Assistant a
alertDuring alert a = do
i <- addAlert $ alert { alertClass = Activity }
removeAlert i `after` a
{- Remotes using the XMPP transport have urls like xmpp::user@host -}
isXMPPRemote :: Remote -> Bool
isXMPPRemote remote = Git.repoIsUrl r && "xmpp::" `isPrefixOf` Git.repoLocation r
where
r = Remote.repo remote
getXMPPClientID :: Remote -> ClientID
getXMPPClientID r = T.pack $ drop (length "xmpp::") (Git.repoLocation (Remote.repo r))