tweaks
This commit is contained in:
parent
10edaf6dc9
commit
025ded4a2d
3 changed files with 34 additions and 40 deletions
|
@ -215,18 +215,14 @@ set file content = do
|
|||
-
|
||||
- Returns an empty string if the file doesn't exist yet. -}
|
||||
get :: FilePath -> Annex String
|
||||
get file = do
|
||||
cached <- getCache file
|
||||
case cached of
|
||||
Just content -> return content
|
||||
Nothing -> do
|
||||
j <- getJournalFile file
|
||||
case j of
|
||||
Just content -> do
|
||||
setCache file content
|
||||
return content
|
||||
Nothing -> withIndexUpdate $ do
|
||||
content <- catFile fullname file
|
||||
get file = fromcache =<< getCache file
|
||||
where
|
||||
fromcache (Just content) = return content
|
||||
fromcache Nothing = fromjournal =<< getJournalFile file
|
||||
fromjournal (Just content) = cache content
|
||||
fromjournal Nothing = withIndexUpdate $
|
||||
cache =<< catFile fullname file
|
||||
cache content = do
|
||||
setCache file content
|
||||
return content
|
||||
|
||||
|
@ -287,8 +283,7 @@ stageJournalFiles = do
|
|||
let paths = map (dir </>) fs
|
||||
-- inject all the journal files directly into git
|
||||
-- in one quick command
|
||||
(pid, fromh, toh) <- hPipeBoth "git" $ toCommand $
|
||||
Git.gitCommandLine g [Param "hash-object", Param "-w", Param "--stdin-paths"]
|
||||
(pid, fromh, toh) <- hPipeBoth "git" $ toCommand $ git_hash_object g
|
||||
_ <- forkProcess $ do
|
||||
hPutStr toh $ unlines paths
|
||||
hClose toh
|
||||
|
@ -304,6 +299,9 @@ stageJournalFiles = do
|
|||
where
|
||||
index_lines shas = map genline . zip shas
|
||||
genline (sha, file) = Git.UnionMerge.update_index_line sha file
|
||||
git_hash_object g = Git.gitCommandLine g
|
||||
[Param "hash-object", Param "-w", Param "--stdin-paths"]
|
||||
|
||||
|
||||
{- Checks if there are changes in the journal. -}
|
||||
journalDirty :: Annex Bool
|
||||
|
|
36
Backend.hs
36
Backend.hs
|
@ -39,23 +39,20 @@ orderedList = do
|
|||
l <- Annex.getState Annex.backends -- list is cached here
|
||||
if not $ null l
|
||||
then return l
|
||||
else do
|
||||
s <- getstandard
|
||||
d <- Annex.getState Annex.forcebackend
|
||||
handle d s
|
||||
else handle =<< Annex.getState Annex.forcebackend
|
||||
where
|
||||
parseBackendList [] = list
|
||||
parseBackendList s = map lookupBackendName $ words s
|
||||
handle Nothing s = return s
|
||||
handle (Just "") s = return s
|
||||
handle (Just name) s = do
|
||||
let l' = lookupBackendName name : s
|
||||
Annex.changeState $ \state -> state { Annex.backends = l' }
|
||||
handle Nothing = standard
|
||||
handle (Just "") = standard
|
||||
handle (Just name) = do
|
||||
l' <- (lookupBackendName name :) <$> standard
|
||||
Annex.changeState $ \s -> s { Annex.backends = l' }
|
||||
return l'
|
||||
getstandard = do
|
||||
standard = do
|
||||
g <- gitRepo
|
||||
return $ parseBackendList $
|
||||
Git.configGet g "annex.backends" ""
|
||||
parseBackendList [] = list
|
||||
parseBackendList s = map lookupBackendName $ words s
|
||||
|
||||
{- Generates a key for a file, trying each backend in turn until one
|
||||
- accepts it. -}
|
||||
|
@ -83,17 +80,15 @@ lookupFile file = do
|
|||
where
|
||||
getsymlink = takeFileName <$> readSymbolicLink file
|
||||
makekey l = maybe (return Nothing) (makeret l) (fileKey l)
|
||||
makeret l k =
|
||||
makeret l k = let bname = keyBackendName k in
|
||||
case maybeLookupBackendName bname of
|
||||
Just backend -> return $ Just (k, backend)
|
||||
Nothing -> do
|
||||
when (isLinkToAnnex l) $
|
||||
warning skip
|
||||
when (isLinkToAnnex l) $ warning $
|
||||
"skipping " ++ file ++
|
||||
" (unknown backend " ++
|
||||
bname ++ ")"
|
||||
return Nothing
|
||||
where
|
||||
bname = keyBackendName k
|
||||
skip = "skipping " ++ file ++
|
||||
" (unknown backend " ++ bname ++ ")"
|
||||
|
||||
type BackendFile = (Maybe (Backend Annex), FilePath)
|
||||
|
||||
|
@ -121,4 +116,5 @@ maybeLookupBackendName :: String -> Maybe (Backend Annex)
|
|||
maybeLookupBackendName s
|
||||
| length matches == 1 = Just $ head matches
|
||||
| otherwise = Nothing
|
||||
where matches = filter (\b -> s == B.name b) list
|
||||
where
|
||||
matches = filter (\b -> s == B.name b) list
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
{- git-annex key/value backend data type
|
||||
-
|
||||
- Most things should not need this, using Types instead
|
||||
- Most things should not need this, using Remotes instead
|
||||
-
|
||||
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
|
|
Loading…
Reference in a new issue