blob: 952db1f13098577a3228ff6f0c1fa6c12c2df7fe (
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
102
103
104
105
106
107
108
109
|
{- git-annex assistant thread to detect when git-annex is upgraded
-
- Copyright 2013 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.Threads.UpgradeWatcher (
upgradeWatcherThread
) where
import Assistant.Common
import Assistant.Upgrade
import Utility.DirWatcher
import Utility.DirWatcher.Types
import Utility.ThreadScheduler
import Assistant.Types.UrlRenderer
import Assistant.Alert
import Assistant.DaemonStatus
#ifdef WITH_WEBAPP
import Assistant.WebApp.Types
import qualified Build.SysConfig
#endif
import Control.Concurrent.MVar
import qualified Data.Text as T
data WatcherState = InStartupScan | Started | Upgrading
deriving (Eq)
upgradeWatcherThread :: UrlRenderer -> NamedThread
upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
whenM (liftIO checkSuccessfulUpgrade) $
showSuccessfulUpgrade urlrenderer
go =<< liftIO upgradeFlagFile
where
go flagfile = do
mvar <- liftIO $ newMVar InStartupScan
changed <- Just <$> asIO2 (changedFile urlrenderer mvar flagfile)
let hooks = mkWatchHooks
{ addHook = changed
, delHook = changed
, addSymlinkHook = changed
, modifyHook = changed
, delDirHook = changed
}
let dir = parentDir flagfile
let depth = length (splitPath dir) + 1
let nosubdirs f = length (splitPath f) == depth
void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar)
-- Ignore bogus events generated during the startup scan.
-- We ask the watcher to not generate them, but just to be safe..
startup mvar scanner = do
r <- scanner
void $ swapMVar mvar Started
return r
changedFile :: UrlRenderer -> MVar WatcherState -> FilePath -> FilePath -> Maybe FileStatus -> Assistant ()
changedFile urlrenderer mvar flagfile file _status
| flagfile /= file = noop
| otherwise = do
state <- liftIO $ readMVar mvar
when (state == Started) $ do
setstate Upgrading
ifM (liftIO upgradeSanityCheck)
( handleUpgrade urlrenderer
, do
debug ["new version failed sanity check; not using"]
setstate Started
)
where
setstate = void . liftIO . swapMVar mvar
handleUpgrade :: UrlRenderer -> Assistant ()
handleUpgrade urlrenderer = do
-- Wait 2 minutes for any final upgrade changes to settle.
-- (For example, other associated files may be being put into
-- place.) Not needed when using a distribution bundle, because
-- in that case git-annex handles the upgrade in a non-racy way.
liftIO $ unlessM usingDistribution $
threadDelaySeconds (Seconds 120)
ifM autoUpgradeEnabled
( do
debug ["starting automatic upgrade"]
unattendedUpgrade
#ifdef WITH_WEBAPP
, do
button <- mkAlertButton True (T.pack "Finish Upgrade") urlrenderer ConfigFinishUpgradeR
void $ addAlert $ upgradeReadyAlert button
#else
, noop
#endif
)
showSuccessfulUpgrade :: UrlRenderer -> Assistant ()
showSuccessfulUpgrade urlrenderer = do
#ifdef WITH_WEBAPP
button <- ifM autoUpgradeEnabled
( pure Nothing
, Just <$> mkAlertButton True
(T.pack "Enable Automatic Upgrades")
urlrenderer ConfigEnableAutomaticUpgradeR
)
void $ addAlert $ upgradeFinishedAlert button Build.SysConfig.packageversion
#else
noop
#endif
|
