Fix crash on unknown symlinks.

This commit is contained in:
Joey Hess 2010-10-31 18:04:34 -04:00
parent b220e117f2
commit fd6611f955
4 changed files with 37 additions and 19 deletions

View file

@ -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 ++ ")"

View file

@ -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
View file

@ -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

View file

@ -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)