diff options
author | Joey Hess <joeyh@joeyh.name> | 2016-11-21 23:46:59 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2016-11-21 23:46:59 -0400 |
commit | 598d063b2f009637c0c14bfc8025a597832a1652 (patch) | |
tree | bb5389bc86c4122f980e3900aefbafb6f284f8ff /Assistant/Upgrade.hs | |
parent | cbfedce7e9b1b6f7bf1f43122cc8d21f8f9bfba1 (diff) |
Relicense 5 source files that are not part of the webapp from AGPL to GPL.
Building w/o the webapp is not supposed to pull in any AGPLed files.
I appear to have written all the code in these files;
the only commit by anyone else is 0d555aa363482ed041db2d9c63da271ba7f4ced8
and is a spelling fix that is not copyrightable.
Diffstat (limited to 'Assistant/Upgrade.hs')
-rw-r--r-- | Assistant/Upgrade.hs | 361 |
1 files changed, 361 insertions, 0 deletions
diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs new file mode 100644 index 000000000..afbb61924 --- /dev/null +++ b/Assistant/Upgrade.hs @@ -0,0 +1,361 @@ +{- 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.maybeLookupBackendName (Types.Key.keyBackendName 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) + ( readish <$> 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 |