blob: d64d5287d101209ad2d43affd47daa48c5e14382 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
{- git-annex upgrade support
-
- Copyright 2010 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Upgrade where
import System.Directory
import Control.Monad.State (liftIO)
import System.Posix.Files
import Core
import Types
import Locations
import qualified GitRepo as Git
import qualified Annex
import qualified Backend
import Messages
import Version
{- Uses the annex.version git config setting to automate upgrades. -}
upgrade :: Annex Bool
upgrade = do
version <- getVersion
case version of
Just "0" -> upgradeFrom0
Nothing -> return True -- repo not initted yet, no version
Just v | v == currentVersion -> return True
Just _ -> error "this version of git-annex is too old for this git repository!"
upgradeFrom0 :: Annex Bool
upgradeFrom0 = do
showSideAction "Upgrading object directory layout..."
g <- Annex.gitRepo
-- do the reorganisation of the files
let olddir = annexDir g
keys <- getKeysPresent' olddir
_ <- mapM (\k -> moveAnnex k $ olddir ++ "/" ++ keyFile k) keys
-- update the symlinks to the files
files <- liftIO $ Git.inRepo g $ Git.workTree g
fixlinks files
Annex.queueRun
setVersion
return True
where
fixlinks [] = return ()
fixlinks (f:fs) = do
r <- Backend.lookupFile f
case r of
Nothing -> return ()
Just (k, _) -> do
link <- calcGitLink f k
liftIO $ removeFile f
liftIO $ createSymbolicLink link f
Annex.queue "add" ["--"] f
fixlinks fs
|
