From 9030f684521ce8db3e9cd6a4e2a10f4edce7bfee Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Fri, 10 Feb 2012 19:17:41 -0400
Subject: When checking that an url has a key, verify that the Content-Length,
 if available, matches the size of the key.

If there's no Content-Length, or the key has no size, this check is not
done, but it should happen most of the time, and protect against web
content that has changed.
---
 Remote/Git.hs    |  4 +++-
 Remote/Web.hs    |  9 +++++----
 Utility/Url.hs   | 24 +++++++++++++++++++-----
 debian/changelog |  2 ++
 git-annex.cabal  |  2 +-
 5 files changed, 30 insertions(+), 11 deletions(-)

diff --git a/Remote/Git.hs b/Remote/Git.hs
index 829ad1ccb..390524775 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -28,6 +28,7 @@ import qualified Utility.Url as Url
 import Utility.TempFile
 import Config
 import Init
+import Types.Key
 
 remote :: RemoteType
 remote = RemoteType {
@@ -143,7 +144,8 @@ inAnnex r key
 			where
 				go e [] = return $ Left e
 				go _ (u:us) = do
-					res <- catchMsgIO $ Url.exists u
+					res <- catchMsgIO $
+						Url.check u (keySize key)
 					case res of
 						Left e -> go e us
 						v -> return v
diff --git a/Remote/Web.hs b/Remote/Web.hs
index 49c3f43f3..6bd04d4b1 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -15,6 +15,7 @@ import Annex.Content
 import Config
 import Logs.Web
 import qualified Utility.Url as Url
+import Types.Key
 
 remote :: RemoteType
 remote = RemoteType {
@@ -77,8 +78,8 @@ checkKey key = do
 	us <- getUrls key
 	if null us
 		then return $ Right False
-		else return . Right =<< checkKey' us
-checkKey' :: [URLString] -> Annex Bool
-checkKey' us = untilTrue us $ \u -> do
+		else return . Right =<< checkKey' key us
+checkKey' :: Key -> [URLString] -> Annex Bool
+checkKey' key us = untilTrue us $ \u -> do
 	showAction $ "checking " ++ u
-	liftIO $ Url.exists u
+	liftIO $ Url.check u (keySize key)
diff --git a/Utility/Url.hs b/Utility/Url.hs
index e10b8a92a..efd6ad16d 100644
--- a/Utility/Url.hs
+++ b/Utility/Url.hs
@@ -7,6 +7,7 @@
 
 module Utility.Url (
 	URLString,
+	check,
 	exists,
 	canDownload,
 	download,
@@ -14,6 +15,7 @@ module Utility.Url (
 ) where
 
 import Control.Applicative
+import Control.Monad
 import qualified Network.Browser as Browser
 import Network.HTTP
 import Network.URI
@@ -23,16 +25,28 @@ import Utility.Path
 
 type URLString = String
 
-{- Checks that an url exists and could be successfully downloaded. -}
-exists :: URLString -> IO Bool
+{- Checks that an url exists and could be successfully downloaded,
+ - also checking that its size, if available, matches a specified size. -}
+check :: URLString -> Maybe Integer -> IO Bool
+check url expected_size = handle <$> exists url
+	where
+		handle (False, _) = False
+		handle (True, Nothing) = True
+		handle (True, s) = expected_size == s
+
+{- Checks that an url exists and could be successfully downloaded,
+ - also returning its size if available. -}
+exists :: URLString -> IO (Bool, Maybe Integer)
 exists url =
 	case parseURI url of
-		Nothing -> return False
+		Nothing -> return (False, Nothing)
 		Just u -> do
 			r <- request u HEAD
 			case rspCode r of
-				(2,_,_) -> return True
-				_ -> return False
+				(2,_,_) -> return (True, size r)
+				_ -> return (False, Nothing)
+	where
+		size = liftM read . lookupHeader HdrContentLength . rspHeaders
 
 canDownload :: IO Bool
 canDownload = (||) <$> inPath "wget" <*> inPath "curl"
diff --git a/debian/changelog b/debian/changelog
index fdc909e3e..36034f2ae 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -18,6 +18,8 @@ git-annex (3.20120124) UNRELEASED; urgency=low
     location of the file.
   * addurl: Normalize badly encoded urls.
   * Fix teardown of stale cached ssh connections.
+  * When checking that an url has a key, verify that the Content-Length,
+    if available, matches the size of the key.
 
  -- Joey Hess <joeyh@debian.org>  Tue, 24 Jan 2012 16:21:55 -0400
 
diff --git a/git-annex.cabal b/git-annex.cabal
index 3f152ea4b..0c343e42c 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -1,5 +1,5 @@
 Name: git-annex
-Version: 3.20120123
+Version: 3.20120124
 Cabal-Version: >= 1.6
 License: GPL
 Maintainer: Joey Hess <joey@kitenet.net>
-- 
cgit v1.2.3