a4c9d4424c
When imported along with Logs.Location, it can be an unused import and it won't warn, due to reexports. The point if this is really to show that Logs.Presence is not widely used, outside Logs/
376 lines
12 KiB
Haskell
376 lines
12 KiB
Haskell
{- git-annex assistant upgrading
|
|
-
|
|
- Copyright 2013 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Assistant.Upgrade where
|
|
|
|
import Assistant.Common
|
|
import Assistant.Restart
|
|
import qualified Annex
|
|
import Assistant.Alert
|
|
import Assistant.DaemonStatus
|
|
import Utility.Env
|
|
import Utility.Env.Set
|
|
import Types.Distribution
|
|
import Types.Transfer
|
|
import Logs.Web
|
|
import Logs.Location
|
|
import Annex.Content
|
|
import Annex.UUID
|
|
import qualified Backend
|
|
import qualified Types.Backend
|
|
import Assistant.TransferQueue
|
|
import Assistant.TransferSlots
|
|
import Remote (remoteFromUUID)
|
|
import Annex.Path
|
|
import Config.Files
|
|
import Utility.ThreadScheduler
|
|
import Utility.Tmp.Dir
|
|
import Utility.UserInfo
|
|
import Utility.Gpg
|
|
import Utility.FileMode
|
|
import Utility.Metered
|
|
import qualified Utility.Lsof as Lsof
|
|
import qualified BuildInfo
|
|
import qualified Utility.Url as Url
|
|
import qualified Annex.Url as Url hiding (download)
|
|
import Utility.Tuple
|
|
import qualified Utility.RawFilePath as R
|
|
|
|
import Data.Either
|
|
import qualified Data.Map as M
|
|
|
|
{- Upgrade without interaction in the webapp. -}
|
|
unattendedUpgrade :: Assistant ()
|
|
unattendedUpgrade = do
|
|
prepUpgrade
|
|
url <- runRestart
|
|
postUpgrade url
|
|
|
|
prepUpgrade :: Assistant ()
|
|
prepUpgrade = do
|
|
void $ addAlert upgradingAlert
|
|
liftIO $ setEnv upgradedEnv "1" True
|
|
prepRestart
|
|
|
|
postUpgrade :: URLString -> Assistant ()
|
|
postUpgrade = postRestart
|
|
|
|
autoUpgradeEnabled :: Assistant Bool
|
|
autoUpgradeEnabled = liftAnnex $ (==) AutoUpgrade . annexAutoUpgrade <$> Annex.getGitConfig
|
|
|
|
checkSuccessfulUpgrade :: IO Bool
|
|
checkSuccessfulUpgrade = isJust <$> getEnv upgradedEnv
|
|
|
|
upgradedEnv :: String
|
|
upgradedEnv = "GIT_ANNEX_UPGRADED"
|
|
|
|
{- Start downloading the distribution key from the web.
|
|
- Install a hook that will be run once the download is complete,
|
|
- and finishes the upgrade.
|
|
-
|
|
- Creates the destination directory where the upgrade will be installed
|
|
- early, in order to check if another upgrade has happened (or is
|
|
- happening). On failure, the directory is removed.
|
|
-}
|
|
startDistributionDownload :: GitAnnexDistribution -> Assistant ()
|
|
startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO oldVersionLocation
|
|
where
|
|
go Nothing = debug ["Skipping redundant upgrade"]
|
|
go (Just dest) = do
|
|
liftAnnex $ setUrlPresent k u
|
|
hook <- asIO1 $ distributionDownloadComplete d dest cleanup
|
|
modifyDaemonStatus_ $ \s -> s
|
|
{ transferHook = M.insert k hook (transferHook s) }
|
|
maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just (toRawFilePath f))) t)
|
|
=<< liftAnnex (remoteFromUUID webUUID)
|
|
startTransfer t
|
|
k = mkKey $ const $ distributionKey d
|
|
u = distributionUrl d
|
|
f = takeFileName u ++ " (for upgrade)"
|
|
t = Transfer
|
|
{ transferDirection = Download
|
|
, transferUUID = webUUID
|
|
, transferKeyData = fromKey id k
|
|
}
|
|
cleanup = liftAnnex $ do
|
|
lockContentForRemoval k noop removeAnnex
|
|
setUrlMissing k u
|
|
logStatus k InfoMissing
|
|
|
|
{- Called once the download is done.
|
|
- Passed an action that can be used to clean up the downloaded file.
|
|
-
|
|
- Verifies the content of the downloaded key.
|
|
-}
|
|
distributionDownloadComplete :: GitAnnexDistribution -> FilePath -> Assistant () -> Transfer -> Assistant ()
|
|
distributionDownloadComplete d dest cleanup t
|
|
| transferDirection t == Download = do
|
|
debug ["finished downloading git-annex distribution"]
|
|
maybe (failedupgrade "bad download") go
|
|
=<< liftAnnex (withObjectLoc k fsckit)
|
|
| otherwise = cleanup
|
|
where
|
|
k = mkKey $ const $ distributionKey d
|
|
fsckit f = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
|
|
Nothing -> return $ Just (fromRawFilePath f)
|
|
Just b -> case Types.Backend.verifyKeyContent b of
|
|
Nothing -> return $ Just (fromRawFilePath f)
|
|
Just verifier -> ifM (verifier k f)
|
|
( return $ Just (fromRawFilePath f)
|
|
, return Nothing
|
|
)
|
|
go f = do
|
|
ua <- asIO $ upgradeToDistribution dest cleanup f
|
|
fa <- asIO1 failedupgrade
|
|
liftIO $ ua `catchNonAsync` (fa . show)
|
|
failedupgrade msg = do
|
|
void $ addAlert $ upgradeFailedAlert msg
|
|
cleanup
|
|
liftIO $ void $ tryIO $ removeDirectoryRecursive dest
|
|
|
|
{- The upgrade method varies by OS.
|
|
-
|
|
- In general, find where the distribution was installed before,
|
|
- and unpack the new distribution next to it (in a versioned directory).
|
|
- Then update the programFile to point to the new version.
|
|
-}
|
|
upgradeToDistribution :: FilePath -> Assistant () -> FilePath -> Assistant ()
|
|
upgradeToDistribution newdir cleanup distributionfile = do
|
|
liftIO $ createDirectoryIfMissing True newdir
|
|
(program, deleteold) <- unpack
|
|
changeprogram program
|
|
cleanup
|
|
prepUpgrade
|
|
url <- runRestart
|
|
{- At this point, the new assistant is fully running, so
|
|
- it's safe to delete the old version. -}
|
|
liftIO $ void $ tryIO deleteold
|
|
postUpgrade url
|
|
where
|
|
changeprogram program = liftIO $ do
|
|
unlessM (boolSystem program [Param "version"]) $
|
|
giveup "New git-annex program failed to run! Not using."
|
|
pf <- programFile
|
|
liftIO $ writeFile pf program
|
|
|
|
#ifdef darwin_HOST_OS
|
|
{- OS X uses a dmg, so mount it, and copy the contents into place. -}
|
|
unpack = liftIO $ do
|
|
olddir <- oldVersionLocation
|
|
withTmpDirIn (fromRawFilePath (parentDir (toRawFilePath newdir))) "git-annex.upgrade" $ \tmpdir -> do
|
|
void $ boolSystem "hdiutil"
|
|
[ Param "attach", File distributionfile
|
|
, Param "-mountpoint", File tmpdir
|
|
]
|
|
void $ boolSystem "cp"
|
|
[ Param "-R"
|
|
, File $ tmpdir </> installBase </> "Contents"
|
|
, File $ newdir
|
|
]
|
|
void $ boolSystem "hdiutil"
|
|
[ Param "eject"
|
|
, File tmpdir
|
|
]
|
|
sanitycheck newdir
|
|
let deleteold = do
|
|
deleteFromManifest $ olddir </> "Contents" </> "MacOS"
|
|
makeorigsymlink olddir
|
|
return (newdir </> "Contents" </> "MacOS" </> "git-annex", deleteold)
|
|
#else
|
|
{- Linux uses a tarball (so could other POSIX systems), so
|
|
- untar it (into a temp directory) and move the directory
|
|
- into place. -}
|
|
unpack = liftIO $ do
|
|
olddir <- oldVersionLocation
|
|
withTmpDirIn (fromRawFilePath $ parentDir $ toRawFilePath newdir) "git-annex.upgrade" $ \tmpdir -> do
|
|
let tarball = tmpdir </> "tar"
|
|
-- Cannot rely on filename extension, and this also
|
|
-- avoids problems if tar doesn't support transparent
|
|
-- decompression.
|
|
void $ boolSystem "sh"
|
|
[ Param "-c"
|
|
, Param $ "zcat < " ++ shellEscape distributionfile ++
|
|
" > " ++ shellEscape tarball
|
|
]
|
|
tarok <- boolSystem "tar"
|
|
[ Param "xf"
|
|
, Param tarball
|
|
, Param "--directory", File tmpdir
|
|
]
|
|
unless tarok $
|
|
giveup $ "failed to untar " ++ distributionfile
|
|
sanitycheck $ tmpdir </> installBase
|
|
installby R.rename newdir (tmpdir </> installBase)
|
|
let deleteold = do
|
|
deleteFromManifest olddir
|
|
makeorigsymlink olddir
|
|
return (newdir </> "git-annex", deleteold)
|
|
installby a dstdir srcdir =
|
|
mapM_ (\x -> a (toRawFilePath x) (toRawFilePath (dstdir </> takeFileName x)))
|
|
=<< dirContents srcdir
|
|
#endif
|
|
sanitycheck dir =
|
|
unlessM (doesDirectoryExist dir) $
|
|
giveup $ "did not find " ++ dir ++ " in " ++ distributionfile
|
|
makeorigsymlink olddir = do
|
|
let origdir = fromRawFilePath (parentDir (toRawFilePath olddir)) </> installBase
|
|
removeWhenExistsWith R.removeLink (toRawFilePath origdir)
|
|
R.createSymbolicLink (toRawFilePath newdir) (toRawFilePath origdir)
|
|
|
|
{- Finds where the old version was installed. -}
|
|
oldVersionLocation :: IO FilePath
|
|
oldVersionLocation = readProgramFile >>= \case
|
|
Nothing -> giveup "Cannot find old distribution bundle; not upgrading."
|
|
Just pf -> do
|
|
let pdir = fromRawFilePath $ parentDir $ toRawFilePath pf
|
|
#ifdef darwin_HOST_OS
|
|
let dirs = splitDirectories pdir
|
|
{- It will probably be deep inside a git-annex.app directory. -}
|
|
let olddir = case findIndex ("git-annex.app" `isPrefixOf`) dirs of
|
|
Nothing -> pdir
|
|
Just i -> joinPath (take (i + 1) dirs)
|
|
#else
|
|
let olddir = pdir
|
|
#endif
|
|
when (null olddir) $
|
|
giveup $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")"
|
|
return olddir
|
|
|
|
{- Finds a place to install the new version.
|
|
- Generally, put it in the parent directory of where the old version was
|
|
- installed, and use a version number in the directory name.
|
|
- If unable to write to there, instead put it in the home directory.
|
|
-
|
|
- The directory is created. If it already exists, returns Nothing.
|
|
-}
|
|
newVersionLocation :: GitAnnexDistribution -> FilePath -> IO (Maybe FilePath)
|
|
newVersionLocation d olddir =
|
|
trymkdir newloc $ do
|
|
home <- myHomeDir
|
|
trymkdir (home </> s) $
|
|
return Nothing
|
|
where
|
|
s = installBase ++ "." ++ distributionVersion d
|
|
topdir = fromRawFilePath $ parentDir $ toRawFilePath olddir
|
|
newloc = topdir </> s
|
|
trymkdir dir fallback =
|
|
(createDirectory dir >> return (Just dir))
|
|
`catchIO` const fallback
|
|
|
|
installBase :: String
|
|
installBase = "git-annex." ++
|
|
#ifdef linux_HOST_OS
|
|
"linux"
|
|
#else
|
|
#ifdef darwin_HOST_OS
|
|
"app"
|
|
#else
|
|
"dir"
|
|
#endif
|
|
#endif
|
|
|
|
deleteFromManifest :: FilePath -> IO ()
|
|
deleteFromManifest dir = do
|
|
fs <- map (dir </>) . lines <$> catchDefaultIO "" (readFile manifest)
|
|
mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath) fs
|
|
removeWhenExistsWith R.removeLink (toRawFilePath manifest)
|
|
removeEmptyRecursive dir
|
|
where
|
|
manifest = dir </> "git-annex.MANIFEST"
|
|
|
|
removeEmptyRecursive :: FilePath -> IO ()
|
|
removeEmptyRecursive dir = do
|
|
mapM_ removeEmptyRecursive =<< dirContents dir
|
|
void $ tryIO $ removeDirectory dir
|
|
|
|
{- This is a file that the UpgradeWatcher can watch for modifications to
|
|
- detect when git-annex has been upgraded.
|
|
-}
|
|
upgradeFlagFile :: IO FilePath
|
|
upgradeFlagFile = programPath
|
|
|
|
{- Sanity check to see if an upgrade is complete and the program is ready
|
|
- to be run. -}
|
|
upgradeSanityCheck :: IO Bool
|
|
upgradeSanityCheck = ifM usingDistribution
|
|
( doesFileExist =<< programFile
|
|
, do
|
|
-- Ensure that the program is present, and has no writers,
|
|
-- and can be run. This should handle distribution
|
|
-- upgrades, manual upgrades, etc.
|
|
program <- programPath
|
|
untilM (doesFileExist program <&&> nowriter program) $
|
|
threadDelaySeconds (Seconds 60)
|
|
boolSystem program [Param "version"]
|
|
)
|
|
where
|
|
nowriter f = null
|
|
. filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly])
|
|
. map snd3
|
|
<$> Lsof.query [f]
|
|
|
|
usingDistribution :: IO Bool
|
|
usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV"
|
|
|
|
downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution)
|
|
downloadDistributionInfo = do
|
|
uo <- liftAnnex Url.getUrlOptions
|
|
gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig
|
|
liftIO $ withTmpDir "git-annex.tmp" $ \tmpdir -> do
|
|
let infof = tmpdir </> "info"
|
|
let sigf = infof ++ ".sig"
|
|
ifM (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoUrl infof uo
|
|
<&&> (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoSigUrl sigf uo)
|
|
<&&> verifyDistributionSig gpgcmd sigf)
|
|
( parseInfoFile <$> readFileStrict infof
|
|
, return Nothing
|
|
)
|
|
|
|
distributionInfoUrl :: String
|
|
distributionInfoUrl = fromJust BuildInfo.upgradelocation ++ ".info"
|
|
|
|
distributionInfoSigUrl :: String
|
|
distributionInfoSigUrl = distributionInfoUrl ++ ".sig"
|
|
|
|
{- Upgrade only supported on linux and OSX. -}
|
|
upgradeSupported :: Bool
|
|
#ifdef linux_HOST_OS
|
|
upgradeSupported = isJust BuildInfo.upgradelocation
|
|
#else
|
|
#ifdef darwin_HOST_OS
|
|
upgradeSupported = isJust BuildInfo.upgradelocation
|
|
#else
|
|
upgradeSupported = False
|
|
#endif
|
|
#endif
|
|
|
|
{- Verifies that a file from the git-annex distribution has a valid
|
|
- signature. Pass the detached .sig file; the file to be verified should
|
|
- be located next to it.
|
|
-
|
|
- The gpg keyring used to verify the signature is located in
|
|
- trustedkeys.gpg, next to the git-annex program.
|
|
-}
|
|
verifyDistributionSig :: GpgCmd -> FilePath -> IO Bool
|
|
verifyDistributionSig gpgcmd sig = readProgramFile >>= \case
|
|
Just p | isAbsolute p ->
|
|
withUmask 0o0077 $ withTmpDir "git-annex-gpg.tmp" $ \gpgtmp -> do
|
|
let trustedkeys = takeDirectory p </> "trustedkeys.gpg"
|
|
boolGpgCmd gpgcmd
|
|
[ Param "--no-default-keyring"
|
|
, Param "--no-auto-check-trustdb"
|
|
, Param "--no-options"
|
|
, Param "--homedir"
|
|
, File gpgtmp
|
|
, Param "--keyring"
|
|
, File trustedkeys
|
|
, Param "--verify"
|
|
, File sig
|
|
]
|
|
_ -> return False
|