blob: 58c0143dd0ee91d40cca36b7fe32b39d61d0e680 (
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
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
|
{- git-annex command
-
- Copyright 2010 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Command.Add where
import Control.Monad.State (liftIO)
import System.Posix.Files
import System.Directory
import Control.Exception.Control (handle)
import Control.Exception.Base (throwIO)
import Control.Exception.Extensible (IOException)
import Command
import qualified Annex
import qualified AnnexQueue
import qualified Backend
import LocationLog
import Types
import Content
import Messages
import Utility
import Touch
import Locations
command :: [Command]
command = [repoCommand "add" paramPath seek "add files to annex"]
{- Add acts on both files not checked into git yet, and unlocked files. -}
seek :: [CommandSeek]
seek = [withFilesNotInGit start, withFilesUnlocked start]
{- The add subcommand annexes a file, storing it in a backend, and then
- moving it into the annex directory and setting up the symlink pointing
- to its content. -}
start :: CommandStartBackendFile
start pair@(file, _) = notAnnexed file $ do
s <- liftIO $ getSymbolicLinkStatus file
if isSymbolicLink s || not (isRegularFile s)
then stop
else do
showStart "add" file
next $ perform pair
perform :: BackendFile -> CommandPerform
perform (file, backend) = do
k <- Backend.genKey file backend
case k of
Nothing -> stop
Just (key, _) -> do
handle (undo file key) $ moveAnnex key file
next $ cleanup file key
{- On error, put the file back so it doesn't seem to have vanished.
- This can be called before or after the symlink is in place. -}
undo :: FilePath -> Key -> IOException -> Annex a
undo file key e = do
unlessM (inAnnex key) rethrow -- no cleanup to do
liftIO $ whenM (doesFileExist file) $ removeFile file
handle tryharder $ fromAnnex key file
logStatus key InfoMissing
rethrow
where
rethrow = liftIO $ throwIO e
-- fromAnnex could fail if the file ownership is weird
tryharder :: IOException -> Annex ()
tryharder _ = do
g <- Annex.gitRepo
liftIO $ renameFile (gitAnnexLocation g key) file
cleanup :: FilePath -> Key -> CommandCleanup
cleanup file key = do
handle (undo file key) $ do
link <- calcGitLink file key
liftIO $ createSymbolicLink link file
logStatus key InfoPresent
-- touch the symlink to have the same mtime as the
-- file it points to
s <- liftIO $ getFileStatus file
let mtime = modificationTime s
liftIO $ touch file (TimeSpec mtime) False
force <- Annex.getState Annex.force
if force
then AnnexQueue.add "add" [Param "-f", Param "--"] [file]
else AnnexQueue.add "add" [Param "--"] [file]
return True
|
