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
|
{- git-annex assistant thread to detect when git-annex binary is changed
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.Threads.UpgradeWatcher (
upgradWatcherThread
) where
import Assistant.Common
import Utility.DirWatcher
import Utility.DirWatcher.Types
import Config.Files
import qualified Utility.Lsof as Lsof
import Utility.ThreadScheduler
import Assistant.Types.UrlRenderer
import Assistant.Alert
import Assistant.DaemonStatus
#ifdef WITH_WEBAPP
import Assistant.WebApp.Types
#endif
import Control.Concurrent.MVar
import Data.Tuple.Utils
import qualified Data.Text as T
data WatcherState = InStartupScan | Started | Upgrading
deriving (Eq)
upgradWatcherThread :: UrlRenderer -> NamedThread
upgradWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ go =<< liftIO programPath
where
go Nothing = debug [ "cannot determine program path" ]
go (Just program) = do
mvar <- liftIO $ newMVar InStartupScan
changed <- Just <$> asIO2 (changedFile urlrenderer mvar program)
let hooks = mkWatchHooks
{ addHook = changed
, delHook = changed
, addSymlinkHook = changed
, modifyHook = changed
, delDirHook = changed
}
let dir = parentDir program
let depth = length (splitPath dir) + 1
let nosubdirs f = length (splitPath f) == depth
void $ liftIO $ watchDir dir nosubdirs hooks (startup mvar)
-- Ignore bogus events generated during the startup scan.
startup mvar scanner = do
r <- scanner
void $ swapMVar mvar Started
return r
changedFile :: UrlRenderer -> MVar WatcherState -> FilePath -> FilePath -> Maybe FileStatus -> Assistant ()
changedFile urlrenderer mvar program file _status
| program /= file = noop
| otherwise = do
state <- liftIO $ readMVar mvar
when (state == Started) $ do
setstate Upgrading
ifM (sanityCheck program)
( handleUpgrade urlrenderer
, do
debug ["new version of", program, "failed sanity check; not using"]
setstate Started
)
where
setstate = void . liftIO . swapMVar mvar
{- The program's file has been changed. Before restarting,
- it needs to not be open for write by anything, and should run
- successfully when run with the parameter "version".
-}
sanityCheck :: FilePath -> Assistant Bool
sanityCheck program = do
whileM (liftIO $ haswriter <||> missing) $ do
debug [program, "is still being written; waiting"]
liftIO $ threadDelaySeconds (Seconds 60)
debug [program, "has changed, and seems to be ready to run"]
liftIO $ boolSystem program [Param "version"]
where
missing = not <$> doesFileExist program
haswriter = not . null
. filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly])
. map snd3
<$> Lsof.query [program]
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.)
liftIO $ threadDelaySeconds (Seconds 120)
#ifdef WITH_WEBAPP
button <- mkAlertButton True (T.pack "Finish Upgrade") urlrenderer ConfigFinishUpgradeR
void $ addAlert (upgradeReadyAlert button)
#else
noop
#endif
|
