create directory for upgraded versio early as a locking mechanism
This commit is contained in:
parent
5ff5d0a854
commit
95feec24d1
2 changed files with 78 additions and 41 deletions
|
@ -63,17 +63,24 @@ upgradedEnv = "GIT_ANNEX_UPGRADED"
|
||||||
|
|
||||||
{- Start downloading the distribution key from the web.
|
{- Start downloading the distribution key from the web.
|
||||||
- Install a hook that will be run once the download is complete,
|
- Install a hook that will be run once the download is complete,
|
||||||
- and finishes the upgrade. -}
|
- 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 :: GitAnnexDistribution -> Assistant ()
|
||||||
startDistributionDownload d = do
|
startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO oldVersionLocation
|
||||||
liftAnnex $ setUrlPresent k u
|
|
||||||
hook <- asIO1 $ distributionDownloadComplete d cleanup
|
|
||||||
modifyDaemonStatus_ $ \s -> s
|
|
||||||
{ transferHook = M.insert k hook (transferHook s) }
|
|
||||||
maybe noop (queueTransfer "upgrade" Next (Just f) t)
|
|
||||||
=<< liftAnnex (remoteFromUUID webUUID)
|
|
||||||
startTransfer t
|
|
||||||
where
|
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 (Just f) t)
|
||||||
|
=<< liftAnnex (remoteFromUUID webUUID)
|
||||||
|
startTransfer t
|
||||||
k = distributionKey d
|
k = distributionKey d
|
||||||
u = distributionUrl d
|
u = distributionUrl d
|
||||||
f = takeFileName u ++ " (for upgrade)"
|
f = takeFileName u ++ " (for upgrade)"
|
||||||
|
@ -92,11 +99,12 @@ startDistributionDownload d = do
|
||||||
-
|
-
|
||||||
- Fsck the key to verify the download.
|
- Fsck the key to verify the download.
|
||||||
-}
|
-}
|
||||||
distributionDownloadComplete :: GitAnnexDistribution -> Assistant () -> Transfer -> Assistant ()
|
distributionDownloadComplete :: GitAnnexDistribution -> FilePath -> Assistant () -> Transfer -> Assistant ()
|
||||||
distributionDownloadComplete d cleanup t
|
distributionDownloadComplete d dest cleanup t
|
||||||
| transferDirection t == Download = do
|
| transferDirection t == Download = do
|
||||||
debug ["finished downloading git-annex distribution"]
|
debug ["finished downloading git-annex distribution"]
|
||||||
maybe cleanup go =<< liftAnnex (withObjectLoc k fsckit (getM fsckit))
|
maybe (failedupgrade "bad download") go
|
||||||
|
=<< liftAnnex (withObjectLoc k fsckit (getM fsckit))
|
||||||
| otherwise = cleanup
|
| otherwise = cleanup
|
||||||
where
|
where
|
||||||
k = distributionKey d
|
k = distributionKey d
|
||||||
|
@ -109,12 +117,13 @@ distributionDownloadComplete d cleanup t
|
||||||
, return Nothing
|
, return Nothing
|
||||||
)
|
)
|
||||||
go f = do
|
go f = do
|
||||||
ua <- asIO $ upgradeToDistribution d cleanup f
|
ua <- asIO $ upgradeToDistribution dest cleanup f
|
||||||
fa <- asIO1 failedupgrade
|
fa <- asIO1 failedupgrade
|
||||||
liftIO $ ua `catchNonAsync` fa
|
liftIO $ ua `catchNonAsync` (fa . show)
|
||||||
failedupgrade e = do
|
failedupgrade msg = do
|
||||||
|
void $ addAlert $ upgradeFailedAlert msg
|
||||||
cleanup
|
cleanup
|
||||||
void $ addAlert $ upgradeFailedAlert $ show e
|
liftIO $ void $ tryIO $ removeDirectoryRecursive dest
|
||||||
|
|
||||||
{- The upgrade method varies by OS.
|
{- The upgrade method varies by OS.
|
||||||
-
|
-
|
||||||
|
@ -122,8 +131,8 @@ distributionDownloadComplete d cleanup t
|
||||||
- and unpack the new distribution next to it (in a versioned directory).
|
- and unpack the new distribution next to it (in a versioned directory).
|
||||||
- Then update the programFile to point to the new version.
|
- Then update the programFile to point to the new version.
|
||||||
-}
|
-}
|
||||||
upgradeToDistribution :: GitAnnexDistribution -> Assistant () -> FilePath -> Assistant ()
|
upgradeToDistribution :: FilePath -> Assistant () -> FilePath -> Assistant ()
|
||||||
upgradeToDistribution d cleanup f = do
|
upgradeToDistribution newdir cleanup distributionfile = do
|
||||||
(program, deleteold) <- unpack
|
(program, deleteold) <- unpack
|
||||||
changeprogram program
|
changeprogram program
|
||||||
cleanup
|
cleanup
|
||||||
|
@ -149,12 +158,8 @@ upgradeToDistribution d cleanup f = do
|
||||||
- untar it (into a temp directory) and move the directory
|
- untar it (into a temp directory) and move the directory
|
||||||
- into place. -}
|
- into place. -}
|
||||||
unpack = liftIO $ do
|
unpack = liftIO $ do
|
||||||
olddir <- parentDir <$> readProgramFile
|
olddir <- oldVersionLocation
|
||||||
when (null olddir) $
|
createDirectoryIfMissing True newdir
|
||||||
error $ "Cannot find old distribution bundle; not upgrading."
|
|
||||||
newdir <- newVersionLocation d olddir "git-annex.linux."
|
|
||||||
whenM (doesDirectoryExist newdir) $
|
|
||||||
error $ "Upgrade destination directory " ++ newdir ++ "already exists; not overwriting."
|
|
||||||
withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do
|
withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do
|
||||||
let tarball = tmpdir </> "tar"
|
let tarball = tmpdir </> "tar"
|
||||||
-- Cannot rely on filename extension, and this also
|
-- Cannot rely on filename extension, and this also
|
||||||
|
@ -162,7 +167,7 @@ upgradeToDistribution d cleanup f = do
|
||||||
-- decompression.
|
-- decompression.
|
||||||
void $ boolSystem "sh"
|
void $ boolSystem "sh"
|
||||||
[ Param "-c"
|
[ Param "-c"
|
||||||
, Param $ "zcat < " ++ shellEscape f ++
|
, Param $ "zcat < " ++ shellEscape distributionfile ++
|
||||||
" > " ++ shellEscape tarball
|
" > " ++ shellEscape tarball
|
||||||
]
|
]
|
||||||
tarok <- boolSystem "tar"
|
tarok <- boolSystem "tar"
|
||||||
|
@ -171,37 +176,66 @@ upgradeToDistribution d cleanup f = do
|
||||||
, Param "--directory", File tmpdir
|
, Param "--directory", File tmpdir
|
||||||
]
|
]
|
||||||
unless tarok $
|
unless tarok $
|
||||||
error $ "failed to untar " ++ f
|
error $ "failed to untar " ++ distributionfile
|
||||||
let unpacked = tmpdir </> "git-annex.linux"
|
let unpacked = tmpdir </> installBase
|
||||||
unlessM (doesDirectoryExist unpacked) $
|
unlessM (doesDirectoryExist unpacked) $
|
||||||
error $ "did not find git-annex.linux in " ++ f
|
error $ "did not find " ++ installBase ++ " in " ++ distributionfile
|
||||||
renameDirectory unpacked newdir
|
moveinto newdir unpacked
|
||||||
let deleteold = do
|
let deleteold = do
|
||||||
deleteFromManifest olddir
|
deleteFromManifest olddir
|
||||||
let origdir = parentDir olddir </> "git-annex.linux"
|
let origdir = parentDir olddir </> installBase
|
||||||
nukeFile origdir
|
nukeFile origdir
|
||||||
createSymbolicLink newdir origdir
|
createSymbolicLink newdir origdir
|
||||||
return (newdir </> "git-annex", deleteold)
|
return (newdir </> "git-annex", deleteold)
|
||||||
#endif
|
#endif
|
||||||
|
moveinto dstdir srcdir =
|
||||||
|
mapM_ (\x -> rename x (dstdir </> takeFileName x))
|
||||||
|
=<< dirContents srcdir
|
||||||
|
|
||||||
|
{- Finds where the old version was installed. -}
|
||||||
|
oldVersionLocation :: IO FilePath
|
||||||
|
oldVersionLocation = do
|
||||||
|
#ifdef darwin_HOST_OS
|
||||||
|
error "TODO OSX oldVersionLocation"
|
||||||
|
#else
|
||||||
|
olddir <- parentDir <$> readProgramFile
|
||||||
|
#endif
|
||||||
|
when (null olddir) $
|
||||||
|
error $ "Cannot find old distribution bundle; not upgrading."
|
||||||
|
return olddir
|
||||||
|
|
||||||
{- Finds a place to install the new version.
|
{- Finds a place to install the new version.
|
||||||
- Generally, put it in the parent directory of where the old version was
|
- Generally, put it in the parent directory of where the old version was
|
||||||
- installed, and use a version number in the directory name.
|
- installed, and use a version number in the directory name.
|
||||||
- If unable to write to there, instead put it in the home directory.
|
- 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 -> String -> IO FilePath
|
newVersionLocation :: GitAnnexDistribution -> FilePath -> IO (Maybe FilePath)
|
||||||
newVersionLocation d olddir base = go =<< tryIO (writeFile testfile "")
|
newVersionLocation d olddir =
|
||||||
|
trymkdir newloc $ do
|
||||||
|
home <- myHomeDir
|
||||||
|
trymkdir (home </> s) $
|
||||||
|
return Nothing
|
||||||
where
|
where
|
||||||
s = base ++ distributionVersion d
|
s = installBase ++ "." ++ distributionVersion d
|
||||||
topdir = parentDir olddir
|
topdir = parentDir olddir
|
||||||
newloc = topdir </> s
|
newloc = topdir </> s
|
||||||
testfile = newloc ++ ".test"
|
trymkdir dir fallback =
|
||||||
go (Right _) = do
|
(createDirectory dir >> return (Just dir))
|
||||||
nukeFile testfile
|
`catchIO` const fallback
|
||||||
return newloc
|
|
||||||
go (Left _) = do
|
installBase :: String
|
||||||
home <- myHomeDir
|
installBase = "git-annex." ++
|
||||||
return $ home </> s
|
#ifdef linux_HOST_OS
|
||||||
|
"linux"
|
||||||
|
#else
|
||||||
|
#ifdef darwin_HOST_OS
|
||||||
|
"osx"
|
||||||
|
#else
|
||||||
|
"dir"
|
||||||
|
#endif
|
||||||
|
#endif
|
||||||
|
|
||||||
deleteFromManifest :: FilePath -> IO ()
|
deleteFromManifest :: FilePath -> IO ()
|
||||||
deleteFromManifest dir = do
|
deleteFromManifest dir = do
|
||||||
|
|
|
@ -46,4 +46,7 @@ should notice the upgrade and restart.
|
||||||
|
|
||||||
I don't want every daemon trying to download the file at once..
|
I don't want every daemon trying to download the file at once..
|
||||||
|
|
||||||
TODO Add locking to prevent that.
|
Approach: The first new version is installed into a stable directory, based
|
||||||
|
on its version. So, start the upgrade by making this directory. If upgrade
|
||||||
|
is already in progress, the directory will already exist. (Remove directory
|
||||||
|
if upgrade fails.)
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue