got rid of Core module

Most of it was to do with managing annexed Content, so put there

1 files changed, 165 insertions, 0 deletions

diff --git a/Content.hs b/Content.hs
new file mode 100644
index 000000000..0cbd6905c
--- /dev/null
+++ b/Content.hs
@@ -0,0 +1,165 @@
+{- git-annex file content managing
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Content (
+	inAnnex,
+	calcGitLink,
+	logStatus,
+	getViaTmp,
+	preventWrite,
+	allowWrite,
+	moveAnnex,
+	removeAnnex,
+	fromAnnex,
+	moveBad,
+	getKeysPresent
+) where
+
+import System.IO.Error (try)
+import System.Directory
+import Control.Monad.State (liftIO)
+import System.Path
+import Control.Monad (when, filterM)
+import System.Posix.Files
+import System.FilePath
+
+import Types
+import Locations
+import LocationLog
+import UUID
+import qualified GitRepo as Git
+import qualified Annex
+import Utility
+
+{- Checks if a given key is currently present in the annexLocation. -}
+inAnnex :: Key -> Annex Bool
+inAnnex key = do
+	g <- Annex.gitRepo
+	when (Git.repoIsUrl g) $ error "inAnnex cannot check remote repo"
+	liftIO $ doesFileExist $ annexLocation g key
+
+{- Calculates the relative path to use to link a file to a key. -}
+calcGitLink :: FilePath -> Key -> Annex FilePath
+calcGitLink file key = do
+	g <- Annex.gitRepo
+	cwd <- liftIO $ getCurrentDirectory
+	let absfile = case absNormPath cwd file of
+		Just f -> f
+		Nothing -> error $ "unable to normalize " ++ file
+	return $ relPathDirToDir (parentDir absfile) (Git.workTree g) ++
+		annexLocationRelative key
+
+{- Updates the LocationLog when a key's presence changes. -}
+logStatus :: Key -> LogStatus -> Annex ()
+logStatus key status = do
+	g <- Annex.gitRepo
+	u <- getUUID g
+	logfile <- liftIO $ logChange g key u status
+	Annex.queue "add" ["--"] logfile
+
+{- Runs an action, passing it a temporary filename to download,
+ - and if the action succeeds, moves the temp file into 
+ - the annex as a key's content. -}
+getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool
+getViaTmp key action = do
+	g <- Annex.gitRepo
+	let tmp = annexTmpLocation g ++ keyFile key
+	liftIO $ createDirectoryIfMissing True (parentDir tmp)
+	success <- action tmp
+	if success
+		then do
+			moveAnnex key tmp
+			logStatus key ValuePresent
+			return True
+		else do
+			-- the tmp file is left behind, in case caller wants
+			-- to resume its transfer
+			return False
+
+{- Removes the write bits from a file. -}
+preventWrite :: FilePath -> IO ()
+preventWrite f = unsetFileMode f writebits
+	where
+		writebits = foldl unionFileModes ownerWriteMode
+					[groupWriteMode, otherWriteMode]
+
+{- Turns a file's write bit back on. -}
+allowWrite :: FilePath -> IO ()
+allowWrite f = do
+	s <- getFileStatus f
+	setFileMode f $ fileMode s `unionFileModes` ownerWriteMode
+
+{- Moves a file into .git/annex/objects/ -}
+moveAnnex :: Key -> FilePath -> Annex ()
+moveAnnex key src = do
+	g <- Annex.gitRepo
+	let dest = annexLocation g key
+	let dir = parentDir dest
+	liftIO $ do
+		createDirectoryIfMissing True dir
+		allowWrite dir -- in case the directory already exists
+		renameFile src dest
+		preventWrite dest
+		preventWrite dir
+
+{- Removes a key's file from .git/annex/objects/ -}
+removeAnnex :: Key -> Annex ()
+removeAnnex key = do
+	g <- Annex.gitRepo
+	let file = annexLocation g key
+	let dir = parentDir file
+	liftIO $ do
+		allowWrite dir
+		removeFile file
+		removeDirectory dir
+
+{- Moves a key's file out of .git/annex/objects/ -}
+fromAnnex :: Key -> FilePath -> Annex ()
+fromAnnex key dest = do
+	g <- Annex.gitRepo
+	let file = annexLocation g key
+	let dir = parentDir file
+	liftIO $ do
+		allowWrite dir
+		allowWrite file
+		renameFile file dest
+		removeDirectory dir
+
+{- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
+ - returns the file it was moved to. -}
+moveBad :: Key -> Annex FilePath
+moveBad key = do
+	g <- Annex.gitRepo
+	let src = annexLocation g key
+	let dest = annexBadLocation g ++ takeFileName src
+	liftIO $ createDirectoryIfMissing True (parentDir dest)
+	liftIO $ allowWrite (parentDir src)
+	liftIO $ renameFile src dest
+	liftIO $ removeDirectory (parentDir src)
+	return dest
+
+{- List of keys whose content exists in .git/annex/objects/ -}
+getKeysPresent :: Annex [Key]
+getKeysPresent = do
+	g <- Annex.gitRepo
+	getKeysPresent' $ annexObjectDir g
+getKeysPresent' :: FilePath -> Annex [Key]
+getKeysPresent' dir = do
+	exists <- liftIO $ doesDirectoryExist dir
+	if (not exists)
+		then return []
+		else do
+			contents <- liftIO $ getDirectoryContents dir
+			files <- liftIO $ filterM present contents
+			return $ map fileKey files
+	where
+		present d = do
+			result <- try $
+				getFileStatus $ dir ++ "/" ++ d ++ "/"  ++ takeFileName d
+			case result of
+				Right s -> return $ isRegularFile s
+				Left _ -> return False