Fix crash on unknown symlinks.

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)