diff options
| -rw-r--r-- | Backend.hs | 22 | ||||
| -rw-r--r-- | Commands.hs | 64 |
2 files changed, 51 insertions, 35 deletions
diff --git a/Backend.hs b/Backend.hs index f1b4c2897..693e1371b 100644 --- a/Backend.hs +++ b/Backend.hs @@ -23,7 +23,8 @@ module Backend ( retrieveKeyFile, removeKey, hasKey, - lookupFile + lookupFile, + chooseBackends ) where import Control.Monad.State @@ -74,12 +75,15 @@ maybeLookupBackendName bs s = where matches = filter (\b -> s == Internals.name b) bs {- Attempts to store a file in one of the backends. -} -storeFileKey :: FilePath -> Annex (Maybe (Key, Backend)) -storeFileKey file = do +storeFileKey :: FilePath -> Maybe Backend -> Annex (Maybe (Key, Backend)) +storeFileKey file trybackend = do g <- Annex.gitRepo let relfile = Git.relative g file - b <- list - storeFileKey' b file relfile + bs <- list + let bs' = case trybackend of + Nothing -> bs + Just backend -> backend:bs + storeFileKey' bs' file relfile storeFileKey' :: [Backend] -> FilePath -> FilePath -> Annex (Maybe (Key, Backend)) storeFileKey' [] _ _ = return Nothing storeFileKey' (b:bs) file relfile = do @@ -136,3 +140,11 @@ lookupFile file = do kname = keyName k skip = "skipping " ++ file ++ " (unknown backend " ++ bname ++ ")" + +{- Looks up the backends that should be used for each file in a list. + - That can be configured on a per-file basis in the gitattributes file. + -} +chooseBackends :: [FilePath] -> Annex [(FilePath, Maybe Backend)] +chooseBackends fs = do + -- TODO + return $ map (\f -> (f, Nothing)) fs diff --git a/Commands.hs b/Commands.hs index 80b355f79..c012cdca0 100644 --- a/Commands.hs +++ b/Commands.hs @@ -25,7 +25,6 @@ import LocationLog import Types import Core import qualified Remotes -import qualified TypeInternals {- A subcommand runs in four stages. Each stage can return the next stage - to run. @@ -34,7 +33,7 @@ import qualified TypeInternals - looks through the repo to find the ones that are relevant - to that subcommand (ie, new files to add), and returns a list of - start stage actions to run. -} -type SubCmdParse = [String] -> Git.Repo -> IO [SubCmdStart] +type SubCmdParse = [String] -> Annex [SubCmdStart] {- 1. The start stage is run before anything is printed about the - subcommand, is passed some input, and can early abort it - if the input does not make sense. It should run quickly and @@ -125,9 +124,9 @@ usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs {- Prepares a set of actions to run to perform a subcommand, based on - the parameters passed to it. -} -prepSubCmd :: SubCommand -> Git.Repo -> [String] -> IO [Annex Bool] -prepSubCmd SubCommand { subcmdparse = parse } repo params = do - list <- parse params repo :: IO [SubCmdStart] +prepSubCmd :: SubCommand -> AnnexState -> [String] -> IO [Annex Bool] +prepSubCmd SubCommand { subcmdparse = parse } state params = do + list <- Annex.eval state $ parse params return $ map (\a -> doSubCmd a) list {- Runs a subcommand through the start, perform and cleanup stages -} @@ -155,37 +154,43 @@ doSubCmd start = do {- These functions parse a user's parameters into a list of SubCmdStart actions to perform. -} type ParseStrings = (String -> SubCmdStart) -> SubCmdParse -withFilesNotInGit :: ParseStrings -withFilesNotInGit a params repo = do - files <- mapM (Git.notInRepo repo) params - return $ map a $ notState $ foldl (++) [] files +type ParseBackendFiles = ((FilePath, Maybe Backend) -> SubCmdStart) -> SubCmdParse +withFilesNotInGit :: ParseBackendFiles +withFilesNotInGit a params = do + repo <- Annex.gitRepo + files <- liftIO $ mapM (Git.notInRepo repo) params + let files' = foldl (++) [] files + pairs <- Backend.chooseBackends files' + return $ map a $ filter (\(f,_) -> notState f) pairs withFilesInGit :: ParseStrings -withFilesInGit a params repo = do - files <- mapM (Git.inRepo repo) params - return $ map a $ notState $ foldl (++) [] files +withFilesInGit a params = do + repo <- Annex.gitRepo + files <- liftIO $ mapM (Git.inRepo repo) params + return $ map a $ filter notState $ foldl (++) [] files withFilesMissing :: ParseStrings -withFilesMissing a params _ = do +withFilesMissing a params = do files <- liftIO $ filterM missing params - return $ map a $ notState files + return $ map a $ filter notState files where missing f = do e <- doesFileExist f return $ not e withDescription :: ParseStrings -withDescription a params _ = do +withDescription a params = do return $ [a $ unwords params] withFilesToBeCommitted :: ParseStrings -withFilesToBeCommitted a params repo = do - files <- mapM (Git.stagedFiles repo) params - return $ map a $ notState $ foldl (++) [] files +withFilesToBeCommitted a params = do + repo <- Annex.gitRepo + files <- liftIO $ mapM (Git.stagedFiles repo) params + return $ map a $ filter notState $ foldl (++) [] files withKeys :: ParseStrings -withKeys a params _ = return $ map a params +withKeys a params = return $ map a params withTempFile :: ParseStrings -withTempFile a params _ = return $ map a params +withTempFile a params = return $ map a params {- filter out files from the state directory -} -notState :: [FilePath] -> [FilePath] -notState fs = filter (\f -> stateLoc /= take (length stateLoc) f) fs +notState :: FilePath -> Bool +notState f = stateLoc /= take (length stateLoc) f {- Parses command line and returns two lists of actions to be - run in the Annex monad. The first actions configure it @@ -198,8 +203,7 @@ parseCmd argv state = do case lookupCmd (params !! 0) of [] -> error usage [subcommand] -> do - let repo = TypeInternals.repo state - actions <- prepSubCmd subcommand repo (drop 1 params) + actions <- prepSubCmd subcommand state (drop 1 params) let configactions = map (\flag -> do flag return True) flags @@ -214,17 +218,17 @@ parseCmd argv state = do {- 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. -} -addStart :: FilePath -> SubCmdStart -addStart file = notAnnexed file $ do +addStart :: (FilePath, Maybe Backend) -> SubCmdStart +addStart 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 $ addPerform file -addPerform :: FilePath -> SubCmdPerform -addPerform file = do - stored <- Backend.storeFileKey file + return $ Just $ addPerform pair +addPerform :: (FilePath, Maybe Backend) -> SubCmdPerform +addPerform (file, backend) = do + stored <- Backend.storeFileKey file backend case (stored) of Nothing -> return Nothing Just (key, _) -> return $ Just $ addCleanup file key |