summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2010-10-31 18:04:34 -0400
committerGravatar Joey Hess <joey@kitenet.net>2010-10-31 18:04:34 -0400
commitfd6611f9554e43f2bc365f7ef70f90877c9403d0 (patch)
treeb4b91e6448ea839a419e8a94e9f8dc1c013c99c7
parentb220e117f2e06133919ad31e9cc225470f501566 (diff)
Fix crash on unknown symlinks.
-rw-r--r--Backend.hs41
-rw-r--r--Core.hs7
-rw-r--r--debian/changelog1
-rw-r--r--git-annex.hs7
4 files changed, 37 insertions, 19 deletions
diff --git a/Backend.hs b/Backend.hs
index d75c2a761..f1b4c2897 100644
--- a/Backend.hs
+++ b/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 ++ ")"
diff --git a/Core.hs b/Core.hs
index ebe5d2966..e2e6eaa0c 100644
--- a/Core.hs
+++ b/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
diff --git a/debian/changelog b/debian/changelog
index 70e905223..83e76b6ec 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -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
diff --git a/git-annex.hs b/git-annex.hs
index e9e0d6f02..d798d417b 100644
--- a/git-annex.hs
+++ b/git-annex.hs
@@ -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)