40ecf58d4b
This does not change the overall license of the git-annex program, which was already AGPL due to a number of sources files being AGPL already. Legally speaking, I'm adding a new license under which these files are now available; I already released their current contents under the GPL license. Now they're dual licensed GPL and AGPL. However, I intend for all my future changes to these files to only be released under the AGPL license, and I won't be tracking the dual licensing status, so I'm simply changing the license statement to say it's AGPL. (In some cases, others wrote parts of the code of a file and released it under the GPL; but in all cases I have contributed a significant portion of the code in each file and it's that code that is getting the AGPL license; the GPL license of other contributors allows combining with AGPL code.)
109 lines
3.1 KiB
Haskell
109 lines
3.1 KiB
Haskell
{- git-annex assistant thread to detect when git-annex is upgraded
|
|
-
|
|
- Copyright 2013 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL 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 BuildInfo
|
|
#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 BuildInfo.packageversion
|
|
#else
|
|
noop
|
|
#endif
|