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,
|
||||
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
|
||||
|
|
64
Commands.hs
64
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
|
||||
|
|
Loading…
Reference in a new issue