broke subcommands out into separate modules

10 files changed, 528 insertions, 0 deletions

diff --git a/Command/Add.hs b/Command/Add.hs
new file mode 100644
index 000000000..825c1d8c1
--- /dev/null
+++ b/Command/Add.hs
@@ -0,0 +1,52 @@
+{- 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 Command
+import qualified Annex
+import Utility
+import Locations
+import qualified Backend
+import LocationLog
+import Types
+import Core
+
+{- 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 :: SubCmdStartBackendFile
+start pair@(file, _) = notAnnexed file $ do
+	s <- liftIO $ getSymbolicLinkStatus file
+	if ((isSymbolicLink s) || (not $ isRegularFile s))
+		then return Nothing
+		else do
+			showStart "add" file
+			return $ Just $ perform pair
+
+perform :: (FilePath, Maybe Backend) -> SubCmdPerform
+perform (file, backend) = do
+	stored <- Backend.storeFileKey file backend
+	case (stored) of
+		Nothing -> return Nothing
+		Just (key, _) -> return $ Just $ cleanup file key
+
+cleanup :: FilePath -> Key -> SubCmdCleanup
+cleanup file key = do
+	logStatus key ValuePresent
+	g <- Annex.gitRepo
+	let dest = annexLocation g key
+	liftIO $ createDirectoryIfMissing True (parentDir dest)
+	liftIO $ renameFile file dest
+	link <- calcGitLink file key
+	liftIO $ createSymbolicLink link file
+	Annex.queue "add" [] file
+	return True
diff --git a/Command/Drop.hs b/Command/Drop.hs
new file mode 100644
index 000000000..6cdf216f4
--- /dev/null
+++ b/Command/Drop.hs
@@ -0,0 +1,50 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Drop where
+
+import Control.Monad.State (liftIO)
+import System.Directory
+
+import Command
+import qualified Annex
+import Locations
+import qualified Backend
+import LocationLog
+import Types
+import Core
+
+{- Indicates a file's content is not wanted anymore, and should be removed
+ - if it's safe to do so. -}
+start :: SubCmdStartString
+start file = isAnnexed file $ \(key, backend) -> do
+	inbackend <- Backend.hasKey key
+	if (not inbackend)
+		then return Nothing
+		else do
+			showStart "drop" file
+			return $ Just $ perform key backend
+
+perform :: Key -> Backend -> SubCmdPerform
+perform key backend = do
+	success <- Backend.removeKey backend key
+	if (success)
+		then return $ Just $ cleanup key
+		else return Nothing
+
+cleanup :: Key -> SubCmdCleanup
+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 True
+		else return True
+
diff --git a/Command/DropKey.hs b/Command/DropKey.hs
new file mode 100644
index 000000000..bdd9b55b1
--- /dev/null
+++ b/Command/DropKey.hs
@@ -0,0 +1,47 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.DropKey where
+
+import Control.Monad.State (liftIO)
+import System.Directory
+
+import Command
+import qualified Annex
+import Locations
+import qualified Backend
+import LocationLog
+import Types
+import Core
+
+{- Drops cached content for a key. -}
+start :: SubCmdStartString
+start keyname = do
+	backends <- Backend.list
+	let key = genKey (backends !! 0) keyname
+	present <- inAnnex key
+	force <- Annex.flagIsSet "force"
+	if (not present)
+		then return Nothing
+		else if (not force)
+			then error "dropkey is can cause data loss; use --force if you're sure you want to do this"
+			else do
+				showStart "dropkey" keyname
+				return $ Just $ perform key
+
+perform :: Key -> SubCmdPerform
+perform key = do
+	g <- Annex.gitRepo
+	let loc = annexLocation g key
+	liftIO $ removeFile loc
+	return $ Just $ cleanup key
+
+cleanup :: Key -> SubCmdCleanup
+cleanup key = do
+	logStatus key ValueMissing
+	return True
+
diff --git a/Command/Fix.hs b/Command/Fix.hs
new file mode 100644
index 000000000..90257a8a5
--- /dev/null
+++ b/Command/Fix.hs
@@ -0,0 +1,40 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Fix where
+
+import Control.Monad.State (liftIO)
+import System.Posix.Files
+import System.Directory
+
+import Command
+import qualified Annex
+import Utility
+import Core
+
+{- Fixes the symlink to an annexed file. -}
+start :: SubCmdStartString
+start file = isAnnexed file $ \(key, _) -> do
+	link <- calcGitLink file key
+	l <- liftIO $ readSymbolicLink file
+	if (link == l)
+		then return Nothing
+		else do
+			showStart "fix" file
+			return $ Just $ perform file link
+
+perform :: FilePath -> FilePath -> SubCmdPerform
+perform file link = do
+	liftIO $ createDirectoryIfMissing True (parentDir file)
+	liftIO $ removeFile file
+	liftIO $ createSymbolicLink link file
+	return $ Just $ cleanup file
+
+cleanup :: FilePath -> SubCmdCleanup
+cleanup file = do
+	Annex.queue "add" [] file
+	return True
diff --git a/Command/FromKey.hs b/Command/FromKey.hs
new file mode 100644
index 000000000..3071f218f
--- /dev/null
+++ b/Command/FromKey.hs
@@ -0,0 +1,44 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.FromKey where
+
+import Control.Monad.State (liftIO)
+import System.Posix.Files
+import System.Directory
+import Control.Monad (when, unless)
+
+import Command
+import qualified Annex
+import Utility
+import qualified Backend
+import Types
+import Core
+
+{- Adds a file pointing at a manually-specified key -}
+start :: SubCmdStartString
+start file = do
+	keyname <- Annex.flagGet "key"
+	when (null keyname) $ error "please specify the key with --key"
+	backends <- Backend.list
+	let key = genKey (backends !! 0) keyname
+
+	inbackend <- Backend.hasKey key
+	unless (inbackend) $ error $
+		"key ("++keyname++") is not present in backend"
+	showStart "fromkey" file
+	return $ Just $ perform file key
+perform :: FilePath -> Key -> SubCmdPerform
+perform file key = do
+	link <- calcGitLink file key
+	liftIO $ createDirectoryIfMissing True (parentDir file)
+	liftIO $ createSymbolicLink link file
+	return $ Just $ cleanup file
+cleanup :: FilePath -> SubCmdCleanup
+cleanup file = do
+	Annex.queue "add" [] file
+	return True
diff --git a/Command/Get.hs b/Command/Get.hs
new file mode 100644
index 000000000..1433bc8d0
--- /dev/null
+++ b/Command/Get.hs
@@ -0,0 +1,31 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Get where
+
+import Command
+import qualified Backend
+import Types
+import Core
+
+{- Gets an annexed file from one of the backends. -}
+start :: SubCmdStartString
+start file = isAnnexed file $ \(key, backend) -> do
+	inannex <- inAnnex key
+	if (inannex)
+		then return Nothing
+		else do
+			showStart "get" file
+			return $ Just $ perform key backend
+
+perform :: Key -> Backend -> SubCmdPerform
+perform key backend = do
+	ok <- getViaTmp key (Backend.retrieveKeyFile backend key)
+	if (ok)
+		then return $ Just $ return True -- no cleanup needed
+		else return Nothing
+
diff --git a/Command/Init.hs b/Command/Init.hs
new file mode 100644
index 000000000..b1e4e0e06
--- /dev/null
+++ b/Command/Init.hs
@@ -0,0 +1,42 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Init where
+
+import Control.Monad.State (liftIO)
+import Control.Monad (when)
+
+import Command
+import qualified Annex
+import Core
+import qualified GitRepo as Git
+import UUID
+
+{- Stores description for the repository etc. -}
+start :: SubCmdStartString
+start description = do
+	when (null description) $ error $
+		"please specify a description of this repository\n"
+	showStart "init" description
+	return $ Just $ perform description
+
+perform :: String -> SubCmdPerform
+perform description = do
+	g <- Annex.gitRepo
+	u <- getUUID g
+	describeUUID u description
+	liftIO $ gitAttributes g
+	liftIO $ gitPreCommitHook g
+	return $ Just $ cleanup
+
+cleanup :: SubCmdCleanup
+cleanup = do
+	g <- Annex.gitRepo
+	logfile <- uuidLog
+	liftIO $ Git.run g ["add", logfile]
+	liftIO $ Git.run g ["commit", "-m", "git annex init", logfile]
+	return True
diff --git a/Command/Move.hs b/Command/Move.hs
new file mode 100644
index 000000000..cee941622
--- /dev/null
+++ b/Command/Move.hs
@@ -0,0 +1,131 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Move where
+
+import Control.Monad.State (liftIO)
+import Monad (when)
+
+import Command
+import Command.Drop
+import qualified Annex
+import Locations
+import LocationLog
+import Types
+import Core
+import qualified GitRepo as Git
+import qualified Remotes
+import UUID
+
+{- Move a file either --to or --from a repository.
+ -
+ - This only operates on the cached file content; it does not involve
+ - moving data in the key-value backend. -}
+start :: SubCmdStartString
+start file = do
+	fromName <- Annex.flagGet "fromrepository"
+	toName <- Annex.flagGet "torepository"
+	case (fromName, toName) of
+		("", "") -> error "specify either --from or --to"
+		("",  _) -> moveToStart file
+		(_ , "") -> moveFromStart file
+		(_ ,  _) -> error "only one of --from or --to can be specified"
+
+{- Moves the content of an annexed file to another repository,
+ - removing it from the current repository, and updates locationlog
+ - information on both.
+ -
+ - If the destination already has the content, it is still removed
+ - from the current repository.
+ -
+ - Note that unlike drop, this does not honor annex.numcopies.
+ - A file's content can be moved even if there are insufficient copies to
+ - allow it to be dropped.
+ -}
+moveToStart :: SubCmdStartString
+moveToStart file = isAnnexed file $ \(key, _) -> do
+	ishere <- inAnnex key
+	if (not ishere)
+		then return Nothing -- not here, so nothing to do
+		else do
+			showStart "move" file
+			return $ Just $ moveToPerform key
+moveToPerform :: Key -> SubCmdPerform
+moveToPerform key = do
+	-- checking the remote is expensive, so not done in the start step
+	remote <- Remotes.commandLineRemote
+	isthere <- Remotes.inAnnex remote key
+	case isthere of
+		Left err -> do
+			showNote $ show err
+			return Nothing
+		Right False -> do
+			Core.showNote $ "moving to " ++ (Git.repoDescribe remote) ++ "..."
+			let tmpfile = (annexTmpLocation remote) ++ (keyFile key)
+			ok <- Remotes.copyToRemote remote key tmpfile
+			if (ok)
+				then return $ Just $ moveToCleanup remote key tmpfile
+				else return Nothing -- failed
+		Right True -> return $ Just $ Command.Drop.cleanup key
+moveToCleanup :: Git.Repo -> Key -> FilePath -> SubCmdCleanup
+moveToCleanup remote key tmpfile = do
+	-- Tell remote to use the transferred content.
+	ok <- Remotes.runCmd remote "git-annex" ["setkey", "--quiet",
+		"--backend=" ++ (backendName key),
+		"--key=" ++ keyName key,
+		tmpfile]
+	if ok
+		then do
+			-- Record that the key is present on the remote.
+			g <- Annex.gitRepo
+			remoteuuid <- getUUID remote
+			logfile <- liftIO $ logChange g key remoteuuid ValuePresent
+			Annex.queue "add" [] logfile
+			-- Cleanup on the local side is the same as done for the
+			-- drop subcommand.
+			Command.Drop.cleanup key
+		else return False
+
+{- Moves the content of an annexed file from another repository to the current
+ - repository and updates locationlog information on both.
+ -
+ - If the current repository already has the content, it is still removed
+ - from the other repository.
+ -}
+moveFromStart :: SubCmdStartString
+moveFromStart file = isAnnexed file $ \(key, _) -> do
+	remote <- Remotes.commandLineRemote
+	l <- Remotes.keyPossibilities key
+	if (null $ filter (\r -> Remotes.same r remote) l)
+		then return Nothing
+		else do
+			showStart "move" file
+			return $ Just $ moveFromPerform key
+moveFromPerform :: Key -> SubCmdPerform
+moveFromPerform key = do
+	remote <- Remotes.commandLineRemote
+	ishere <- inAnnex key
+	if (ishere)
+		then return $ Just $ moveFromCleanup remote key
+		else do
+			Core.showNote $ "moving from " ++ (Git.repoDescribe remote) ++ "..."
+			ok <- getViaTmp key (Remotes.copyFromRemote remote key)
+			if (ok)
+				then return $ Just $ moveFromCleanup remote key
+				else return Nothing -- fail
+moveFromCleanup :: Git.Repo -> Key -> SubCmdCleanup
+moveFromCleanup remote key = do
+	ok <- Remotes.runCmd remote "git-annex" ["dropkey", "--quiet", "--force",
+		"--backend=" ++ (backendName key),
+		keyName key]
+	when ok $ do
+		-- Record locally that the key is not on the remote.
+		remoteuuid <- getUUID remote
+		g <- Annex.gitRepo
+		logfile <- liftIO $ logChange g key remoteuuid ValueMissing
+		Annex.queue "add" [] logfile
+	return ok
diff --git a/Command/SetKey.hs b/Command/SetKey.hs
new file mode 100644
index 000000000..a5710643e
--- /dev/null
+++ b/Command/SetKey.hs
@@ -0,0 +1,43 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.SetKey where
+
+import Control.Monad.State (liftIO)
+import Control.Monad (when)
+
+import Command
+import qualified Annex
+import Utility
+import Locations
+import qualified Backend
+import LocationLog
+import Types
+import Core
+
+{- Sets cached content for a key. -}
+start :: SubCmdStartString
+start tmpfile = do
+	keyname <- Annex.flagGet "key"
+	when (null keyname) $ error "please specify the key with --key"
+	backends <- Backend.list
+	let key = genKey (backends !! 0) keyname
+	showStart "setkey" tmpfile
+	return $ Just $ perform tmpfile key
+perform :: FilePath -> Key -> SubCmdPerform
+perform tmpfile key = do
+	g <- Annex.gitRepo
+	let loc = annexLocation g key
+	ok <- liftIO $ boolSystem "mv" [tmpfile, loc]
+	if (not ok)
+		then error "mv failed!"
+		else return $ Just $ cleanup key
+cleanup :: Key -> SubCmdCleanup
+cleanup key = do
+	logStatus key ValuePresent
+	return True
+
diff --git a/Command/Unannex.hs b/Command/Unannex.hs
new file mode 100644
index 000000000..5cffb2d89
--- /dev/null
+++ b/Command/Unannex.hs
@@ -0,0 +1,48 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Unannex where
+
+import Control.Monad.State (liftIO)
+import System.Directory
+
+import Command
+import qualified Annex
+import Utility
+import Locations
+import qualified Backend
+import LocationLog
+import Types
+import Core
+import qualified GitRepo as Git
+
+{- The unannex subcommand undoes an add. -}
+start :: SubCmdStartString
+start file = isAnnexed file $ \(key, backend) -> do
+	showStart "unannex" file
+	return $ Just $ perform file key backend
+
+perform :: FilePath -> Key -> Backend -> SubCmdPerform
+perform file key backend = do
+	-- force backend to always remove
+	Annex.flagChange "force" $ FlagBool True
+	ok <- Backend.removeKey backend key
+	if (ok)
+		then return $ Just $ cleanup file key
+		else return Nothing
+
+cleanup :: FilePath -> Key -> SubCmdCleanup
+cleanup file key = do
+	logStatus key ValueMissing
+	g <- Annex.gitRepo
+	let src = annexLocation g key
+	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
+	return True