Fix crash on unknown symlinks.
This commit is contained in:
parent
b220e117f2
commit
fd6611f955
4 changed files with 37 additions and 19 deletions
41
Backend.hs
41
Backend.hs
|
@ -27,9 +27,10 @@ module Backend (
|
|||
) where
|
||||
|
||||
import Control.Monad.State
|
||||
import Control.Exception.Extensible
|
||||
import IO (try)
|
||||
import System.FilePath
|
||||
import System.Posix.Files
|
||||
import Core
|
||||
|
||||
import Locations
|
||||
import qualified GitRepo as Git
|
||||
|
@ -59,12 +60,17 @@ list = do
|
|||
then bs
|
||||
else map (lookupBackendName bs) $ words s
|
||||
|
||||
{- Looks up a backend in a list -}
|
||||
{- Looks up a backend in a list. May fail if unknown. -}
|
||||
lookupBackendName :: [Backend] -> String -> Backend
|
||||
lookupBackendName bs s =
|
||||
case maybeLookupBackendName bs s of
|
||||
Just b -> b
|
||||
Nothing -> error $ "unknown backend " ++ s
|
||||
maybeLookupBackendName :: [Backend] -> String -> Maybe Backend
|
||||
maybeLookupBackendName bs s =
|
||||
if ((length matches) /= 1)
|
||||
then error $ "unknown backend " ++ s
|
||||
else matches !! 0
|
||||
then Nothing
|
||||
else Just $ matches !! 0
|
||||
where matches = filter (\b -> s == Internals.name b) bs
|
||||
|
||||
{- Attempts to store a file in one of the backends. -}
|
||||
|
@ -109,15 +115,24 @@ hasKey key = do
|
|||
lookupFile :: FilePath -> Annex (Maybe (Key, Backend))
|
||||
lookupFile file = do
|
||||
bs <- Annex.supportedBackends
|
||||
result <- liftIO $ (try (find bs)::IO (Either SomeException (Maybe (Key, Backend))))
|
||||
case (result) of
|
||||
tl <- liftIO $ try getsymlink
|
||||
case tl of
|
||||
Left _ -> return Nothing
|
||||
Right val -> return val
|
||||
where
|
||||
find bs = do
|
||||
Right l -> makekey bs l
|
||||
where
|
||||
getsymlink = do
|
||||
l <- readSymbolicLink file
|
||||
return $ Just $ pair bs $ takeFileName l
|
||||
pair bs f = (k, b)
|
||||
return $ takeFileName l
|
||||
makekey bs l = do
|
||||
case maybeLookupBackendName bs $ bname of
|
||||
Nothing -> do
|
||||
unless (null kname || null bname) $
|
||||
warning skip
|
||||
return Nothing
|
||||
Just backend -> return $ Just (k, backend)
|
||||
where
|
||||
k = fileKey f
|
||||
b = lookupBackendName bs $ backendName k
|
||||
k = fileKey l
|
||||
bname = backendName k
|
||||
kname = keyName k
|
||||
skip = "skipping " ++ file ++
|
||||
" (unknown backend " ++ bname ++ ")"
|
||||
|
|
7
Core.hs
7
Core.hs
|
@ -165,3 +165,10 @@ showEndOk = verbose $ do
|
|||
showEndFail :: Annex ()
|
||||
showEndFail = verbose $ do
|
||||
liftIO $ putStrLn "\nfailed"
|
||||
|
||||
{- Exception pretty-printing. -}
|
||||
showErr :: (Show a) => a -> Annex ()
|
||||
showErr e = warning $ show e
|
||||
|
||||
warning :: String -> Annex ()
|
||||
warning s = liftIO $ hPutStrLn stderr $ "git-annex: " ++ s
|
||||
|
|
1
debian/changelog
vendored
1
debian/changelog
vendored
|
@ -7,6 +7,7 @@ git-annex (0.03) UNRELEASED; urgency=low
|
|||
* Support building with Debian stable's ghc.
|
||||
* Fixed memory leak; git-annex no longer reads the whole file list
|
||||
from git before starting, and will be much faster with large repos.
|
||||
* Fix crash on unknown symlinks.
|
||||
|
||||
-- Joey Hess <joeyh@debian.org> Thu, 28 Oct 2010 13:46:59 -0400
|
||||
|
||||
|
|
|
@ -6,7 +6,6 @@
|
|||
-}
|
||||
|
||||
import IO (try)
|
||||
import System.IO
|
||||
import System.Environment
|
||||
import Monad
|
||||
|
||||
|
@ -41,13 +40,9 @@ tryRun' state errnum (a:as) = do
|
|||
result <- try $ Annex.run state a
|
||||
case (result) of
|
||||
Left err -> do
|
||||
showErr err
|
||||
_ <- Annex.run state $ showErr err
|
||||
tryRun' state (errnum + 1) as
|
||||
Right (True,state') -> tryRun' state' errnum as
|
||||
Right (False,state') -> tryRun' state' (errnum + 1) as
|
||||
tryRun' _ errnum [] =
|
||||
when (errnum > 0) $ error $ (show errnum) ++ " failed"
|
||||
|
||||
{- Exception pretty-printing. -}
|
||||
showErr :: (Show a) => a -> IO ()
|
||||
showErr e = hPutStrLn stderr $ "git-annex: " ++ (show e)
|
||||
|
|
Loading…
Reference in a new issue