diff options
| -rw-r--r-- | Remote/Git.hs | 4 | ||||
| -rw-r--r-- | Remote/Web.hs | 9 | ||||
| -rw-r--r-- | Utility/Url.hs | 24 | ||||
| -rw-r--r-- | debian/changelog | 2 | ||||
| -rw-r--r-- | 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> |