summaryrefslogtreecommitdiff
path: root/Commands.hs
blob: e38f9c37257f4568b27c8d8634bcdf3c57e6d8de (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
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
{- git-annex command line -}

module Commands (parseCmd) where

import System.Console.GetOpt
import Control.Monad.State (liftIO)
import System.Posix.Files
import System.Directory
import System.Path
import Data.String.Utils
import List
import IO

import qualified GitRepo as Git
import qualified Annex
import Utility
import Locations
import qualified Backend
import UUID
import LocationLog
import Types
import Core
import qualified Remotes
import qualified TypeInternals

data CmdWants = FilesInGit | FilesNotInGit | RepoName | SingleString
data Command = Command {
	cmdname :: String,
	cmdaction :: (String -> Annex ()),
	cmdwants :: CmdWants,
	cmddesc :: String
}

cmds :: [Command]
cmds =  [
	  (Command "add"	addCmd		FilesNotInGit
		"add files to annex")
	, (Command "get"	getCmd		FilesInGit
		"make content of annexed files available")
	, (Command "drop"	dropCmd		FilesInGit
		"indicate content of files not currently wanted")
	, (Command "unannex"	unannexCmd	FilesInGit
		"undo accidential add command")
	, (Command "init"	initCmd		SingleString
		"initialize git-annex with repository description")
	, (Command "fix"	fixCmd		FilesInGit
		"fix up files' symlinks to point to annexed content")
	]

options = [
	    Option ['f'] ["force"] (NoArg Force) "allow actions that may lose annexed data"
	  ]

header = "Usage: git-annex [" ++ (join "|" $ map cmdname cmds) ++ "] ..."

usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs
	where
		cmddescs = unlines $ map (\c -> indent $ showcmd c) cmds
		showcmd c =
			(cmdname c) ++
			(take (10 - (length (cmdname c))) $ repeat ' ') ++ 
			(cmddesc c)
		indent l = "  " ++ l

{- Finds the type of parameters a command wants, from among the passed
 - parameter list. -}
findWanted :: CmdWants -> [String] -> Git.Repo -> IO [String]
findWanted FilesNotInGit params repo = do
	files <- mapM (Git.notInRepo repo) params
	return $ foldl (++) [] files
findWanted FilesInGit params repo = do
	files <- mapM (Git.inRepo repo) params
	return $ foldl (++) [] files
findWanted SingleString params _ = do
	return $ [unwords params]
findWanted RepoName params _ = do
	return $ params

{- Parses command line and returns a list of flags and a list of
 - actions to be run in the Annex monad. -}
parseCmd :: [String] -> AnnexState -> IO ([Flag], [Annex ()])
parseCmd argv state = do
	(flags, params) <- getopt
	case (length params) of
		0 -> error usage
		_ -> case (lookupCmd (params !! 0)) of
			[] -> error usage
			[Command _ action want _] -> do
				f <- findWanted want (drop 1 params)
					(TypeInternals.repo state)
				return (flags, map action $ filter notstate f)
	where
		-- never include files from the state directory
		notstate f = stateLoc /= take (length stateLoc) f
		getopt = case getOpt Permute options argv of
			(flags, params, []) -> return (flags, params)
			(_, _, errs) -> ioError (userError (concat errs ++ usage))
		lookupCmd cmd = filter (\c -> cmd  == cmdname c) cmds

{- 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. -}
addCmd :: FilePath -> Annex ()
addCmd file = inBackend file $ do
	s <- liftIO $ getSymbolicLinkStatus file
	if ((isSymbolicLink s) || (not $ isRegularFile s))
		then return ()
		else do
			showStart "add" file
			g <- Annex.gitRepo
			stored <- Backend.storeFileKey file
			case (stored) of
				Nothing -> showEndFail
				Just (key, backend) -> do
					logStatus key ValuePresent
					setup g key
	where
		setup g key = do
			let dest = annexLocation g key
			liftIO $ createDirectoryIfMissing True (parentDir dest)
			liftIO $ renameFile file dest
			link <- calcGitLink file key
			liftIO $ createSymbolicLink link file
			liftIO $ Git.run g ["add", file]
			showEndOk

{- Undo addCmd. -}
unannexCmd :: FilePath -> Annex ()
unannexCmd file = notinBackend file $ \(key, backend) -> do
	showStart "unannex" file
	Annex.flagChange Force True -- force backend to always remove
	Backend.removeKey backend key
	logStatus key ValueMissing
	g <- Annex.gitRepo
	let src = annexLocation g key
	moveout g src
	where
		moveout g src = do
			liftIO $ removeFile file
			liftIO $ Git.run g ["rm", "--quiet", file]
			-- git rm deletes empty directories;
			-- put them back
			liftIO $ createDirectoryIfMissing True (parentDir file)
			liftIO $ renameFile src file
			showEndOk

{- Gets an annexed file from one of the backends. -}
getCmd :: FilePath -> Annex ()
getCmd file = notinBackend file $ \(key, backend) -> do
	inannex <- inAnnex key
	if (inannex)
		then return ()
		else do
			showStart "get" file
			g <- Annex.gitRepo
			let dest = annexLocation g key
			let tmp = (annexTmpLocation g) ++ (keyFile key)
			liftIO $ createDirectoryIfMissing True (parentDir tmp)
			success <- Backend.retrieveKeyFile backend key tmp
			if (success)
				then do
					liftIO $ renameFile tmp dest	
					logStatus key ValuePresent
					showEndOk
				else do
					showEndFail

{- Indicates a file's content is not wanted anymore, and should be removed
 - if it's safe to do so. -}
dropCmd :: FilePath -> Annex ()
dropCmd file = notinBackend file $ \(key, backend) -> do
	inbackend <- Backend.hasKey key
	if (not inbackend)
		then return () -- no-op
		else do
			showStart "drop" file
			success <- Backend.removeKey backend key
			if (success)
				then do
					cleanup key
					showEndOk
				else showEndFail
	where
		cleanup key = do
			logStatus key ValueMissing
			inannex <- inAnnex key
			if (inannex)
				then do
					g <- Annex.gitRepo
					let loc = annexLocation g key
					liftIO $ removeFile loc
					return ()
				else return ()

{- Fixes the symlink to an annexed file. -}
fixCmd :: String -> Annex ()
fixCmd file = notinBackend file $ \(key, backend) -> do
	link <- calcGitLink file key
	l <- liftIO $ readSymbolicLink file
	if (link == l)
		then return ()
		else do
			showStart "fix" file
			liftIO $ createDirectoryIfMissing True (parentDir file)
			liftIO $ removeFile file
			liftIO $ createSymbolicLink link file
			g <- Annex.gitRepo
			liftIO $ Git.run g ["add", file]
			showEndOk

{- Stores description for the repository. -}
initCmd :: String -> Annex ()
initCmd description = do
	if (0 == length description)
		then error $ 
			"please specify a description of this repository\n" ++
			usage
		else do
			g <- Annex.gitRepo
			u <- getUUID g
			describeUUID u description
			log <- uuidLog
			liftIO $ Git.run g ["add", log]
			liftIO $ putStrLn "description set"

-- helpers
inBackend file a = do
	r <- Backend.lookupFile file
	case (r) of
		Just v -> return ()
		Nothing -> a
notinBackend file a = do
	r <- Backend.lookupFile file
	case (r) of
		Just v -> a v
		Nothing -> return ()