blob: f0c47e844188299ab26e21d43588961abf31a7ea (
plain)
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
|
{- git-annex assistant thread to detect when upgrade is available
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.Threads.Upgrader (
upgraderThread
) where
import Assistant.Common
import Assistant.Upgrade
import Assistant.Types.UrlRenderer
import Assistant.DaemonStatus
import Assistant.Alert
import Utility.NotificationBroadcaster
import Utility.Tmp
import qualified Annex
import qualified Build.SysConfig
import qualified Utility.Url as Url
import qualified Annex.Url as Url
import qualified Git.Version
import Types.Distribution
#ifdef WITH_WEBAPP
import Assistant.WebApp.Types
#endif
import Data.Time.Clock
import qualified Data.Text as T
upgraderThread :: UrlRenderer -> NamedThread
upgraderThread urlrenderer = namedThread "Upgrader" $
when (isJust Build.SysConfig.upgradelocation) $ do
{- Check for upgrade on startup, unless it was just
- upgraded. -}
unlessM (liftIO checkSuccessfulUpgrade) $
checkUpgrade urlrenderer
h <- liftIO . newNotificationHandle False . networkConnectedNotifier =<< getDaemonStatus
go h =<< liftIO getCurrentTime
where
{- Wait for a network connection event. Then see if it's been
- half a day since the last upgrade check. If so, proceed with
- check. -}
go h lastchecked = do
liftIO $ waitNotification h
autoupgrade <- liftAnnex $ annexAutoUpgrade <$> Annex.getGitConfig
if autoupgrade == NoAutoUpgrade
then go h lastchecked
else do
now <- liftIO getCurrentTime
if diffUTCTime now lastchecked > halfday
then do
checkUpgrade urlrenderer
go h =<< liftIO getCurrentTime
else go h lastchecked
halfday = 12 * 60 * 60
checkUpgrade :: UrlRenderer -> Assistant ()
checkUpgrade urlrenderer = do
debug [ "Checking if an upgrade is available." ]
go =<< getDistributionInfo
where
go Nothing = debug [ "Failed to check if upgrade is available." ]
go (Just d) = do
let installed = Git.Version.normalize Build.SysConfig.packageversion
let avail = Git.Version.normalize $ distributionVersion d
let old = Git.Version.normalize <$> distributionUrgentUpgrade d
if Just installed <= old
then canUpgrade High urlrenderer d
else if installed < avail
then canUpgrade Low urlrenderer d
else debug [ "No new version found." ]
canUpgrade :: AlertPriority -> UrlRenderer -> GitAnnexDistribution -> Assistant ()
canUpgrade urgency urlrenderer d = ifM autoUpgradeEnabled
( startDistributionDownload d
, do
#ifdef WITH_WEBAPP
button <- mkAlertButton True (T.pack "Upgrade") urlrenderer (ConfigStartUpgradeR d)
void $ addAlert (canUpgradeAlert urgency (distributionVersion d) button)
#else
noop
#endif
)
getDistributionInfo :: Assistant (Maybe GitAnnexDistribution)
getDistributionInfo = do
ua <- liftAnnex Url.getUserAgent
liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do
hClose h
ifM (Url.downloadQuiet distributionInfoUrl [] [] tmpfile ua)
( readish <$> readFileStrict tmpfile
, return Nothing
)
distributionInfoUrl :: String
distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info"
|
