1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
|
{- 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
import Utility.TempFile
import Utility.NotificationBroadcaster
import Logs.Transfer
import Logs.Trust
import qualified Remote
import qualified Types.Remote as Remote
import Config
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
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
{- Syncable remotes ordered by cost. -}
calcSyncRemotes :: Annex [Remote]
calcSyncRemotes = do
rs <- filterM (repoSyncable . Remote.repo) =<<
concat . Remote.byCost <$> Remote.enabledRemoteList
alive <- snd <$> trustPartition DeadTrusted (map Remote.uuid rs)
let good r = Remote.uuid r `elem` alive
return $ filter good rs
{- Updates the sycRemotes list from the list of all remotes in Annex state. -}
updateSyncRemotes :: Assistant ()
updateSyncRemotes = do
remotes <- liftAnnex calcSyncRemotes
modifyDaemonStatus_ $ \s -> s { syncRemotes = remotes }
{- 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
remotes <- calcSyncRemotes
liftIO $ atomically $ newTMVar status
{ scanComplete = False
, sanityCheckRunning = False
, currentTransfers = transfers
, syncRemotes = remotes
}
{- 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) }
{- 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 = 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
|
