diff options
author | Joey Hess <joey@kitenet.net> | 2011-01-16 16:05:05 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2011-01-16 16:05:05 -0400 |
commit | e7b557ef5d347831142fd98eac901d79c7e1305d (patch) | |
tree | dbd5d0bcb578e457a6bb23a856b27f4aa27abd36 /Core.hs | |
parent | 84836ed804633fa3d8ff50064331b8b90bb160dd (diff) |
got rid of Core module
Most of it was to do with managing annexed Content, so put there
Diffstat (limited to 'Core.hs')
-rw-r--r-- | Core.hs | 210 |
1 files changed, 0 insertions, 210 deletions
diff --git a/Core.hs b/Core.hs deleted file mode 100644 index d59120d67..000000000 --- a/Core.hs +++ /dev/null @@ -1,210 +0,0 @@ -{- git-annex core functions - - - - Copyright 2010 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Core where - -import System.IO.Error (try) -import System.Directory -import Control.Monad.State (liftIO) -import System.Path -import Control.Monad (when, unless, filterM) -import System.Posix.Files -import Data.Maybe -import System.FilePath - -import Types -import Locations -import LocationLog -import UUID -import qualified GitRepo as Git -import qualified GitQueue -import qualified Annex -import qualified Backend -import Utility -import Messages - -{- Runs a list of Annex actions. Catches IO errors and continues - - (but explicitly thrown errors terminate the whole command). - - Runs shutdown and propigates an overall error status at the end. - -} -tryRun :: AnnexState -> [Annex Bool] -> IO () -tryRun state actions = tryRun' state 0 actions -tryRun' :: AnnexState -> Integer -> [Annex Bool] -> IO () -tryRun' state errnum (a:as) = do - result <- try $ Annex.run state a - case result of - Left err -> do - Annex.eval state $ showErr err - tryRun' state (errnum + 1) as - Right (True,state') -> tryRun' state' errnum as - Right (False,state') -> tryRun' state' (errnum + 1) as -tryRun' state errnum [] = do - _ <- try $ Annex.run state $ shutdown errnum - when (errnum > 0) $ error $ show errnum ++ " failed" - -{- Actions to perform each time ran. -} -startup :: Annex Bool -startup = do - prepUUID - return True - -{- When git-annex is done, it runs this. -} -shutdown :: Integer -> Annex Bool -shutdown errnum = do - q <- Annex.queueGet - unless (q == GitQueue.empty) $ do - showSideAction "Recording state in git..." - Annex.queueRun - - -- If nothing failed, clean up any files left in the temp directory, - -- but leave the directory itself. If something failed, temp files - -- are left behind to allow resuming on re-run. - when (errnum == 0) $ do - g <- Annex.gitRepo - let tmp = annexTmpLocation g - exists <- liftIO $ doesDirectoryExist tmp - when exists $ liftIO $ removeDirectoryRecursive tmp - liftIO $ createDirectoryIfMissing True tmp - - return True - -{- 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 - -{- List of keys referenced by symlinks in the git repo. -} -getKeysReferenced :: Annex [Key] -getKeysReferenced = do - g <- Annex.gitRepo - files <- liftIO $ Git.inRepo g [Git.workTree g] - keypairs <- mapM Backend.lookupFile files - return $ map fst $ catMaybes keypairs |