1 files changed, 262 insertions, 0 deletions
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
new file mode 100644
index 000000000..7268bbbfb
--- /dev/null
+++ b/Assistant/DaemonStatus.hs
@@ -0,0 +1,262 @@
+{- git-annex assistant daemon status
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.DaemonStatus where
+
+import Assistant.Common
+import Assistant.Alert.Utility
+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
+
+import Control.Concurrent.STM
+import System.Posix.Types
+import Data.Time.Clock.POSIX
+import Data.Time
+import System.Locale
+import qualified Data.Map as M
+import qualified Data.Text as T
+
+getDaemonStatus :: Assistant DaemonStatus
+getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle
+
+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)
+calcSyncRemotes = do
+	rs <- filter (remoteAnnexSync . Remote.gitconfig) .
+		concat . Remote.byCost <$> Remote.remoteList
+	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
+		, syncGitRemotes = filter Remote.syncableRemote syncable
+		, syncDataRemotes = syncdata
+		, syncingToCloudRemote = any iscloud syncdata
+		}
+  where
+  	iscloud r = not (Remote.readonly r) && Remote.globallyAvailable r
+
+{- Updates the syncRemotes list from the list of all remotes in Annex state. -}
+updateSyncRemotes :: Assistant ()
+updateSyncRemotes = do
+	modifyDaemonStatus_ =<< liftAnnex calcSyncRemotes
+	status <- getDaemonStatus
+	liftIO $ sendNotification $ syncRemotesNotifier status
+
+	when (syncingToCloudRemote status) $
+		updateAlertMap $
+			M.filter $ \alert ->
+				alertName alert /= Just CloudRepoNeededAlert
+
+updateScheduleLog :: Assistant ()
+updateScheduleLog =
+	liftIO . sendNotification =<< scheduleLogNotifier <$> getDaemonStatus
+
+{- Load any previous daemon status file, and store it in a MVar for this
+ - process to use as its DaemonStatus. Also gets current transfer status. -}
+startDaemonStatus :: Annex DaemonStatusHandle
+startDaemonStatus = do
+	file <- fromRepo gitAnnexDaemonStatusFile
+	status <- liftIO $
+		flip catchDefaultIO (readDaemonStatusFile file) =<< newDaemonStatus
+	transfers <- M.fromList <$> getTransfers
+	addsync <- calcSyncRemotes
+	liftIO $ atomically $ newTMVar $ addsync $ status
+		{ scanComplete = False
+		, sanityCheckRunning = False
+		, currentTransfers = transfers
+		}
+
+{- 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
+  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
+  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
+afterLastDaemonRun timestamp status = maybe False (< t) (lastRunning status)
+  where
+	t = realToFrac (timestamp + slop) :: POSIXTime
+	slop = fromIntegral tenMinutes
+
+tenMinutes :: Int
+tenMinutes = 10 * 60
+
+{- 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
+  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
+  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
+  where
+	remove 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 :: Assistant ()
+notifyTransfer = do
+	dstatus <- getAssistant daemonStatusHandle
+	liftIO $ sendNotification
+		=<< transferNotifier <$> atomically (readTMVar dstatus)
+
+{- Send a notification when alerts are changed. -}
+notifyAlert :: Assistant ()
+notifyAlert = do
+	dstatus <- getAssistant daemonStatusHandle
+	liftIO $ sendNotification
+		=<< alertNotifier <$> atomically (readTMVar dstatus)
+
+{- Returns the alert's identifier, which can be used to remove it. -}
+addAlert :: Alert -> Assistant AlertId
+addAlert alert = do
+	notice [showAlert alert]
+	notifyAlert `after` modifyDaemonStatus add
+  where
+	add s = (s { lastAlertId = i, alertMap = m }, i)
+	  where
+		i = nextAlertId $ lastAlertId s
+		m = mergeAlert i alert (alertMap s)
+
+removeAlert :: AlertId -> Assistant ()
+removeAlert i = updateAlert i (const Nothing)
+
+updateAlert :: AlertId -> (Alert -> Maybe Alert) -> Assistant ()
+updateAlert i a = updateAlertMap $ \m -> M.update a i m
+
+updateAlertMap :: (AlertMap -> AlertMap) -> Assistant ()
+updateAlertMap a = notifyAlert `after` modifyDaemonStatus_ update
+  where
+	update s = s { alertMap = a (alertMap s) }
+
+{- 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'
+	(ok, r) <- a
+	updateAlertMap $ mergeAlert i $ makeAlertFiller ok alert'
+	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))