27eca014be
9c4650358cchanged the Read instance for Key. I've checked all uses of that instance (by removing it and seeing what breaks), and they're all limited to the webapp, except one. That is GitAnnexDistribution's Read instance. So,9c4650358cwould have broken upgrades of git-annex from downloads.kitenet.net. Once the .info files there got updated for a new release, old releases would have failed to parse them and never upgraded. To fix this, I found a way to make the .info files that contain GitAnnexDistribution values be readable by the old version of git-annex. This commit was sponsored by Ewen McNeill.
361 lines
11 KiB
Haskell
361 lines
11 KiB
Haskell
{- git-annex assistant upgrading
|
|
-
|
|
- Copyright 2013 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL 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 Types.Distribution
|
|
import Types.Transfer
|
|
import Logs.Web
|
|
import Logs.Presence
|
|
import Logs.Location
|
|
import Annex.Content
|
|
import Annex.UUID
|
|
import qualified Backend
|
|
import qualified Types.Backend
|
|
import qualified Types.Key
|
|
import Assistant.TransferQueue
|
|
import Assistant.TransferSlots
|
|
import Remote (remoteFromUUID)
|
|
import Annex.Path
|
|
import Config.Files
|
|
import Utility.ThreadScheduler
|
|
import Utility.Tmp
|
|
import Utility.UserInfo
|
|
import Utility.Gpg
|
|
import Utility.FileMode
|
|
import qualified Utility.Lsof as Lsof
|
|
import qualified Build.SysConfig
|
|
import qualified Utility.Url as Url
|
|
import qualified Annex.Url as Url
|
|
|
|
import qualified Data.Map as M
|
|
import Data.Tuple.Utils
|
|
|
|
{- 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
|
|
- happending). 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 webUUID k u
|
|
hook <- asIO1 $ distributionDownloadComplete d dest cleanup
|
|
modifyDaemonStatus_ $ \s -> s
|
|
{ transferHook = M.insert k hook (transferHook s) }
|
|
maybe noop (queueTransfer "upgrade" Next (Just f) t)
|
|
=<< liftAnnex (remoteFromUUID webUUID)
|
|
startTransfer t
|
|
k = distributionKey d
|
|
u = distributionUrl d
|
|
f = takeFileName u ++ " (for upgrade)"
|
|
t = Transfer
|
|
{ transferDirection = Download
|
|
, transferUUID = webUUID
|
|
, transferKey = k
|
|
}
|
|
cleanup = liftAnnex $ do
|
|
lockContentForRemoval k removeAnnex
|
|
setUrlMissing webUUID 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 (getM fsckit))
|
|
| otherwise = cleanup
|
|
where
|
|
k = distributionKey d
|
|
fsckit f = case Backend.maybeLookupBackendVariety (Types.Key.keyVariety k) of
|
|
Nothing -> return $ Just f
|
|
Just b -> case Types.Backend.verifyKeyContent b of
|
|
Nothing -> return $ Just f
|
|
Just verifier -> ifM (verifier k f)
|
|
( return $ Just 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 (parentDir 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 (parentDir 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 $
|
|
error $ "failed to untar " ++ distributionfile
|
|
sanitycheck $ tmpdir </> installBase
|
|
installby rename newdir (tmpdir </> installBase)
|
|
let deleteold = do
|
|
deleteFromManifest olddir
|
|
makeorigsymlink olddir
|
|
return (newdir </> "git-annex", deleteold)
|
|
installby a dstdir srcdir =
|
|
mapM_ (\x -> a x (dstdir </> takeFileName x))
|
|
=<< dirContents srcdir
|
|
#endif
|
|
sanitycheck dir =
|
|
unlessM (doesDirectoryExist dir) $
|
|
error $ "did not find " ++ dir ++ " in " ++ distributionfile
|
|
makeorigsymlink olddir = do
|
|
let origdir = parentDir olddir </> installBase
|
|
nukeFile origdir
|
|
createSymbolicLink newdir origdir
|
|
|
|
{- Finds where the old version was installed. -}
|
|
oldVersionLocation :: IO FilePath
|
|
oldVersionLocation = do
|
|
pdir <- parentDir <$> readProgramFile
|
|
#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) $
|
|
error $ "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 = parentDir 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_ nukeFile fs
|
|
nukeFile 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 (Url.downloadQuiet distributionInfoUrl infof uo
|
|
<&&> Url.downloadQuiet distributionInfoSigUrl sigf uo
|
|
<&&> verifyDistributionSig gpgcmd sigf)
|
|
( parseInfoFile <$> readFileStrict infof
|
|
, return Nothing
|
|
)
|
|
|
|
distributionInfoUrl :: String
|
|
distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info"
|
|
|
|
distributionInfoSigUrl :: String
|
|
distributionInfoSigUrl = distributionInfoUrl ++ ".sig"
|
|
|
|
{- 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 = do
|
|
p <- readProgramFile
|
|
if isAbsolute p
|
|
then 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
|
|
]
|
|
else return False
|