now only need to add gitattributes lookup
This commit is contained in:
parent
287e6e5c13
commit
899a86f8f9
2 changed files with 51 additions and 35 deletions
22
Backend.hs
22
Backend.hs
|
@ -23,7 +23,8 @@ module Backend (
|
||||||
retrieveKeyFile,
|
retrieveKeyFile,
|
||||||
removeKey,
|
removeKey,
|
||||||
hasKey,
|
hasKey,
|
||||||
lookupFile
|
lookupFile,
|
||||||
|
chooseBackends
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
|
@ -74,12 +75,15 @@ maybeLookupBackendName bs s =
|
||||||
where matches = filter (\b -> s == Internals.name b) bs
|
where matches = filter (\b -> s == Internals.name b) bs
|
||||||
|
|
||||||
{- Attempts to store a file in one of the backends. -}
|
{- Attempts to store a file in one of the backends. -}
|
||||||
storeFileKey :: FilePath -> Annex (Maybe (Key, Backend))
|
storeFileKey :: FilePath -> Maybe Backend -> Annex (Maybe (Key, Backend))
|
||||||
storeFileKey file = do
|
storeFileKey file trybackend = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
let relfile = Git.relative g file
|
let relfile = Git.relative g file
|
||||||
b <- list
|
bs <- list
|
||||||
storeFileKey' b file relfile
|
let bs' = case trybackend of
|
||||||
|
Nothing -> bs
|
||||||
|
Just backend -> backend:bs
|
||||||
|
storeFileKey' bs' file relfile
|
||||||
storeFileKey' :: [Backend] -> FilePath -> FilePath -> Annex (Maybe (Key, Backend))
|
storeFileKey' :: [Backend] -> FilePath -> FilePath -> Annex (Maybe (Key, Backend))
|
||||||
storeFileKey' [] _ _ = return Nothing
|
storeFileKey' [] _ _ = return Nothing
|
||||||
storeFileKey' (b:bs) file relfile = do
|
storeFileKey' (b:bs) file relfile = do
|
||||||
|
@ -136,3 +140,11 @@ lookupFile file = do
|
||||||
kname = keyName k
|
kname = keyName k
|
||||||
skip = "skipping " ++ file ++
|
skip = "skipping " ++ file ++
|
||||||
" (unknown backend " ++ bname ++ ")"
|
" (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
|
||||||
|
|
64
Commands.hs
64
Commands.hs
|
@ -25,7 +25,6 @@ import LocationLog
|
||||||
import Types
|
import Types
|
||||||
import Core
|
import Core
|
||||||
import qualified Remotes
|
import qualified Remotes
|
||||||
import qualified TypeInternals
|
|
||||||
|
|
||||||
{- A subcommand runs in four stages. Each stage can return the next stage
|
{- A subcommand runs in four stages. Each stage can return the next stage
|
||||||
- to run.
|
- to run.
|
||||||
|
@ -34,7 +33,7 @@ import qualified TypeInternals
|
||||||
- looks through the repo to find the ones that are relevant
|
- looks through the repo to find the ones that are relevant
|
||||||
- to that subcommand (ie, new files to add), and returns a list of
|
- to that subcommand (ie, new files to add), and returns a list of
|
||||||
- start stage actions to run. -}
|
- 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
|
{- 1. The start stage is run before anything is printed about the
|
||||||
- subcommand, is passed some input, and can early abort it
|
- subcommand, is passed some input, and can early abort it
|
||||||
- if the input does not make sense. It should run quickly and
|
- 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
|
{- Prepares a set of actions to run to perform a subcommand, based on
|
||||||
- the parameters passed to it. -}
|
- the parameters passed to it. -}
|
||||||
prepSubCmd :: SubCommand -> Git.Repo -> [String] -> IO [Annex Bool]
|
prepSubCmd :: SubCommand -> AnnexState -> [String] -> IO [Annex Bool]
|
||||||
prepSubCmd SubCommand { subcmdparse = parse } repo params = do
|
prepSubCmd SubCommand { subcmdparse = parse } state params = do
|
||||||
list <- parse params repo :: IO [SubCmdStart]
|
list <- Annex.eval state $ parse params
|
||||||
return $ map (\a -> doSubCmd a) list
|
return $ map (\a -> doSubCmd a) list
|
||||||
|
|
||||||
{- Runs a subcommand through the start, perform and cleanup stages -}
|
{- 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
|
{- These functions parse a user's parameters into a list of SubCmdStart
|
||||||
actions to perform. -}
|
actions to perform. -}
|
||||||
type ParseStrings = (String -> SubCmdStart) -> SubCmdParse
|
type ParseStrings = (String -> SubCmdStart) -> SubCmdParse
|
||||||
withFilesNotInGit :: ParseStrings
|
type ParseBackendFiles = ((FilePath, Maybe Backend) -> SubCmdStart) -> SubCmdParse
|
||||||
withFilesNotInGit a params repo = do
|
withFilesNotInGit :: ParseBackendFiles
|
||||||
files <- mapM (Git.notInRepo repo) params
|
withFilesNotInGit a params = do
|
||||||
return $ map a $ notState $ foldl (++) [] files
|
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 :: ParseStrings
|
||||||
withFilesInGit a params repo = do
|
withFilesInGit a params = do
|
||||||
files <- mapM (Git.inRepo repo) params
|
repo <- Annex.gitRepo
|
||||||
return $ map a $ notState $ foldl (++) [] files
|
files <- liftIO $ mapM (Git.inRepo repo) params
|
||||||
|
return $ map a $ filter notState $ foldl (++) [] files
|
||||||
withFilesMissing :: ParseStrings
|
withFilesMissing :: ParseStrings
|
||||||
withFilesMissing a params _ = do
|
withFilesMissing a params = do
|
||||||
files <- liftIO $ filterM missing params
|
files <- liftIO $ filterM missing params
|
||||||
return $ map a $ notState files
|
return $ map a $ filter notState files
|
||||||
where
|
where
|
||||||
missing f = do
|
missing f = do
|
||||||
e <- doesFileExist f
|
e <- doesFileExist f
|
||||||
return $ not e
|
return $ not e
|
||||||
withDescription :: ParseStrings
|
withDescription :: ParseStrings
|
||||||
withDescription a params _ = do
|
withDescription a params = do
|
||||||
return $ [a $ unwords params]
|
return $ [a $ unwords params]
|
||||||
withFilesToBeCommitted :: ParseStrings
|
withFilesToBeCommitted :: ParseStrings
|
||||||
withFilesToBeCommitted a params repo = do
|
withFilesToBeCommitted a params = do
|
||||||
files <- mapM (Git.stagedFiles repo) params
|
repo <- Annex.gitRepo
|
||||||
return $ map a $ notState $ foldl (++) [] files
|
files <- liftIO $ mapM (Git.stagedFiles repo) params
|
||||||
|
return $ map a $ filter notState $ foldl (++) [] files
|
||||||
withKeys :: ParseStrings
|
withKeys :: ParseStrings
|
||||||
withKeys a params _ = return $ map a params
|
withKeys a params = return $ map a params
|
||||||
withTempFile :: ParseStrings
|
withTempFile :: ParseStrings
|
||||||
withTempFile a params _ = return $ map a params
|
withTempFile a params = return $ map a params
|
||||||
|
|
||||||
{- filter out files from the state directory -}
|
{- filter out files from the state directory -}
|
||||||
notState :: [FilePath] -> [FilePath]
|
notState :: FilePath -> Bool
|
||||||
notState fs = filter (\f -> stateLoc /= take (length stateLoc) f) fs
|
notState f = stateLoc /= take (length stateLoc) f
|
||||||
|
|
||||||
{- Parses command line and returns two lists of actions to be
|
{- Parses command line and returns two lists of actions to be
|
||||||
- run in the Annex monad. The first actions configure it
|
- run in the Annex monad. The first actions configure it
|
||||||
|
@ -198,8 +203,7 @@ parseCmd argv state = do
|
||||||
case lookupCmd (params !! 0) of
|
case lookupCmd (params !! 0) of
|
||||||
[] -> error usage
|
[] -> error usage
|
||||||
[subcommand] -> do
|
[subcommand] -> do
|
||||||
let repo = TypeInternals.repo state
|
actions <- prepSubCmd subcommand state (drop 1 params)
|
||||||
actions <- prepSubCmd subcommand repo (drop 1 params)
|
|
||||||
let configactions = map (\flag -> do
|
let configactions = map (\flag -> do
|
||||||
flag
|
flag
|
||||||
return True) flags
|
return True) flags
|
||||||
|
@ -214,17 +218,17 @@ parseCmd argv state = do
|
||||||
{- The add subcommand annexes a file, storing it in a backend, and then
|
{- 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
|
- moving it into the annex directory and setting up the symlink pointing
|
||||||
- to its content. -}
|
- to its content. -}
|
||||||
addStart :: FilePath -> SubCmdStart
|
addStart :: (FilePath, Maybe Backend) -> SubCmdStart
|
||||||
addStart file = notAnnexed file $ do
|
addStart pair@(file, _) = notAnnexed file $ do
|
||||||
s <- liftIO $ getSymbolicLinkStatus file
|
s <- liftIO $ getSymbolicLinkStatus file
|
||||||
if ((isSymbolicLink s) || (not $ isRegularFile s))
|
if ((isSymbolicLink s) || (not $ isRegularFile s))
|
||||||
then return Nothing
|
then return Nothing
|
||||||
else do
|
else do
|
||||||
showStart "add" file
|
showStart "add" file
|
||||||
return $ Just $ addPerform file
|
return $ Just $ addPerform pair
|
||||||
addPerform :: FilePath -> SubCmdPerform
|
addPerform :: (FilePath, Maybe Backend) -> SubCmdPerform
|
||||||
addPerform file = do
|
addPerform (file, backend) = do
|
||||||
stored <- Backend.storeFileKey file
|
stored <- Backend.storeFileKey file backend
|
||||||
case (stored) of
|
case (stored) of
|
||||||
Nothing -> return Nothing
|
Nothing -> return Nothing
|
||||||
Just (key, _) -> return $ Just $ addCleanup file key
|
Just (key, _) -> return $ Just $ addCleanup file key
|
||||||
|
|
Loading…
Reference in a new issue