Merge pull request #22 from commercialhaskell/b/permit-missing-sdists

Permit missing sdists

Author: chreekat

all-cabal-tool.cabal

@@ -102,7 +102,10 @@ test-suite all-cabal-tool-test
                      , all-cabal-tool
                      , bytestring
                      , containers
+                     , hackage-security
                      , hit
+                     , http-client
+                     , network-uri
                      , QuickCheck
                      , tasty
                      , tasty-quickcheck

nix/packages/all-cabal-tool.nix

@@ -29,8 +29,8 @@ mkDerivation {
     temporary zlib
   ];
   testHaskellDepends = [
-    aeson base bytestring containers hit QuickCheck tasty
-    tasty-quickcheck text
+    aeson base bytestring containers hackage-security hit http-client
+    network-uri QuickCheck tasty tasty-quickcheck text
   ];
   homepage = "https://github.com/commercialhaskell/all-cabal-tool#readme";
   description = "Update the various all-cabal-* repos";

src/Stackage/Package/Hackage.hs

@@ -6,13 +6,14 @@
 module Stackage.Package.Hackage
   ( Hackage
   , HasUpdates(..)
+  , SdistUnavailable(..)
   , withHackage
   , refreshIndex
   , withSdist
   , sdistLocations
   ) where
 
-import Control.Exception (bracket)
+import Control.Exception (Exception(..), bracket, throwIO)
 import Control.Monad (when)
 import GHC.Stack (HasCallStack)
 import Data.Time (UTCTime)
@@ -33,10 +34,11 @@ import Hackage.Security.Client.Formats (Format(..))
 import Hackage.Security.Client.Repository.Cache
        (Cache(..), getCachedIndex)
 import qualified Hackage.Security.Client.Repository.Remote as Remote
+import Hackage.Security.Util.Checked (tryChecked)
 import Hackage.Security.Util.Path (fromFilePath, makeAbsolute, toFilePath)
-import Hackage.Security.Util.Pretty (pretty)
+import Hackage.Security.Util.Pretty (Pretty(..))
 
-import Stackage.Package.HttpLib (withHttpLib)
+import Stackage.Package.HttpLib (unexpectedResponseStatus, withHttpLib)
 
 -- | A bootstrapped connection to Hackage together with the local cache backing
 -- it.
@@ -45,6 +47,22 @@ data Hackage = Hackage
   , hackageCache :: Cache
   }
 
+-- | A package whose source tarball no mirror would serve.
+--
+-- This can happen for moderated packages. The index is append-only, so they're
+-- still there... just not downloadable.
+data SdistUnavailable = SdistUnavailable
+  { unavailablePackage :: PackageIdentifier
+  , unavailableStatus :: Int -- ^ What the last mirror tried answered with
+  } deriving (Show)
+
+instance Pretty SdistUnavailable where
+  pretty (SdistUnavailable pkgId code) =
+    "No mirror would serve " ++ display pkgId ++ ": status " ++ show code
+
+instance Exception SdistUnavailable where
+  displayException = pretty
+
 -- | Primary server first, then out-of-band mirrors.
 --
 -- Hackage's own @mirrors.json@ currently lists only defunct mirrors, so the
@@ -118,14 +136,25 @@ refreshIndex hackage now = do
 --
 -- The tarball lands under the cache root because @hackage-security@ moves it
 -- there from a temporary file of its own with a plain rename.
-withSdist :: Hackage -> PackageIdentifier -> (FilePath -> IO a) -> IO a
+withSdist
+  :: Hackage
+  -> PackageIdentifier
+  -> (FilePath -> IO a)
+  -> IO (Either SdistUnavailable a)
 withSdist hackage pkgId action = do
   let tmpDir = toFilePath (cacheRoot (hackageCache hackage)) </> "sdists"
   createDirectoryIfMissing True tmpDir
   bracket (newTempFile tmpDir) removeFile $ \dest -> do
-    uncheckClientErrors $
+    fetched <-
+      uncheckClientErrors $
+      tryChecked $
       downloadPackage' (hackageRepository hackage) pkgId dest
-    action dest
+    case fetched of
+      Right () -> Right <$> action dest
+      Left err ->
+        case unexpectedResponseStatus err of
+          Just code -> return (Left (SdistUnavailable pkgId code))
+          Nothing -> throwIO err
   where
     newTempFile dir = do
       (path, h) <- openBinaryTempFile dir (display pkgId ++ ".tar.gz")

src/Stackage/Package/Hashes.hs

@@ -120,14 +120,17 @@ createHashesIfMissing hackage hashesRepo hackageHashMap pkgName pkgVersion =
           hackageHashMap
           (packageHashes package)
       Nothing -> do
-        package <- computePackage hackage pkgName pkgVersion
-        areAllValid <-
-          validateHackageHashes
-            (pack $ getPackageFullName pkgName pkgVersion)
-            hackageHashMap
-            (packageHashes package)
-        when areAllValid $ repoWriteFile hashesRepo jsonfp (encode package)
-        return areAllValid
+        mpackage <- computePackage hackage pkgName pkgVersion
+        case mpackage of
+          Nothing -> return False
+          Just package -> do
+            areAllValid <-
+              validateHackageHashes
+                (pack $ getPackageFullName pkgName pkgVersion)
+                hackageHashMap
+                (packageHashes package)
+            when areAllValid $ repoWriteFile hashesRepo jsonfp (encode package)
+            return areAllValid
 
 -- | Kinda like sequence, except not.
 flatten :: Package Maybe -> Maybe (Package Identity)
@@ -151,25 +154,31 @@ instance FromJSON (Package Maybe) where
        Package <$> o .: "package-hashes" <*> o .: "package-locations" <*>
        o .:? "package-size"
 
--- | Fetch a source tarball and derive its hashes and size.
+-- | Fetch a source tarball and derive its hashes and size, or nothing at all if
+-- the tarball is no longer served.
 computePackage
   :: MonadIO m
   => Hackage
   -> PackageName -- ^ Package name
   -> Version -- ^ Package version
-  -> m (Package Identity)
+  -> m (Maybe (Package Identity))
 computePackage hackage pkgName pkgVersion = liftIO $ do
   putStrLn $ "Computing package information for: " ++ pack pkgFullName
-  (hashes, size) <-
+  fetched <-
     withSdist hackage pkgId $ \path -> do
       lbs <- L.readFile path
       runConduit $ CL.sourceList (L.toChunks lbs) .| getZipSink pairSink
-  return
-    Package
-    { packageHashes = hashes
-    , packageLocations = map pack (sdistLocations pkgId)
-    , packageSize = Identity size
-    }
+  case fetched of
+    Left unavailable -> do
+      hPutStrLn stderr $ pack $ displayException unavailable
+      return Nothing
+    Right (hashes, size) ->
+      return $ Just
+        Package
+        { packageHashes = hashes
+        , packageLocations = map pack (sdistLocations pkgId)
+        , packageSize = Identity size
+        }
   where
     pkgId = PackageIdentifier pkgName pkgVersion
     pkgFullName = getPackageFullName pkgName pkgVersion

src/Stackage/Package/HttpLib.hs

@@ -15,11 +15,13 @@
 module Stackage.Package.HttpLib
   ( withHttpLib
   , UnexpectedResponse(..)
+  , unexpectedResponseStatus
   ) where
 
 import Control.Exception (Exception(..), IOException)
 import qualified Data.ByteString.Char8 as S8
 import Data.List (intercalate)
+import Data.Typeable (cast)
 import Network.HTTP.Client
        (Manager, Request(..), Response(..), requestFromURI)
 import qualified Network.HTTP.Client as HTTP
@@ -118,9 +120,11 @@ wrapCustomEx act =
   where
     go ex = throwChecked (SomeRemoteError ex)
 
-data UnexpectedResponse =
-  UnexpectedResponse URI
-                     Int
+-- | A mirror answered with something other than the file that was asked for.
+data UnexpectedResponse = UnexpectedResponse
+  { unexpectedUri :: URI
+  , unexpectedStatus :: Int
+  }
 
 instance Pretty UnexpectedResponse where
   pretty (UnexpectedResponse uri code) =
@@ -130,3 +134,8 @@ deriving instance Show UnexpectedResponse
 
 instance Exception UnexpectedResponse where
   displayException = pretty
+
+-- | The status a mirror answered with, for failures that came from the
+-- response rather than from the transport underneath it.
+unexpectedResponseStatus :: SomeRemoteError -> Maybe Int
+unexpectedResponseStatus (SomeRemoteError inner) = unexpectedStatus <$> cast inner

src/Stackage/Package/Metadata.hs

@@ -8,6 +8,7 @@ module Stackage.Package.Metadata
   ) where
 
 import qualified Codec.Archive.Tar as Tar
+import Control.Exception (displayException)
 import Control.Monad (when)
 import Control.Monad.IO.Class (MonadIO(liftIO))
 import qualified Data.ByteString.Lazy as L
@@ -156,17 +157,20 @@ updatePackageIfChanged hackage metadataRepo (cabalFile@CabalFile {..}, packageNa
     sink = CL.fold goEntry (cfDescription, "haddock", "", "")
     updatePackage = do
       checkCabalFile
-      (desc, desct, cl, clt) <-
+      fetched <-
         withSdist hackage (PackageIdentifier packageName pkgVersionMax) $
         \path -> localTarballSink path True sink
-      putStrLn $
-        "Updating Metadata for package: " ++
-        pkgNameStr ++ " to version: " ++ pkgVersionStr
-      repoWriteFile
-        metadataRepo
-        fp
-        (L.fromStrict . Y.encode $
-         makePackageInfo cabalFile versionSet desc desct cl clt)
+      case fetched of
+        Left unavailable -> hPutStrLn stderr $ displayException unavailable
+        Right (desc, desct, cl, clt) -> do
+          putStrLn $
+            "Updating Metadata for package: " ++
+            pkgNameStr ++ " to version: " ++ pkgVersionStr
+          repoWriteFile
+            metadataRepo
+            fp
+            (L.fromStrict . Y.encode $
+             makePackageInfo cabalFile versionSet desc desct cl clt)
     fp =
       "packages" </> (unpack $ toLower $ pack $ take 2 $ pkgNameStr ++ "XX") </>
       pkgNameStr <.>

test-integration/Main.hs

@@ -1,6 +1,6 @@
 -- | Exercises the @hackage-security@ client against the live Hackage
--- repository: bootstrapping trust, fetching the index, and fetching a
--- verified source tarball.
+-- repository: bootstrapping trust, fetching the index, and fetching both a
+-- verified source tarball and a withdrawn one.
 --
 -- Enable with @cabal test --flags=integration@.
 module Main where
@@ -21,6 +21,11 @@ sampleSdist :: (PackageIdentifier, Integer)
 sampleSdist =
   (PackageIdentifier (mkPackageName "text") (mkVersion [2, 1, 2]), 449871)
 
+-- | @hermes-1.3.4.3@ is still named by the index, but isn't available.
+withdrawnSdist :: PackageIdentifier
+withdrawnSdist =
+  PackageIdentifier (mkPackageName "hermes") (mkVersion [1, 3, 4, 3])
+
 main :: IO ()
 main = do
   hSetBuffering stdout LineBuffering
@@ -35,8 +40,16 @@ main = do
       indexSize <- getFileSize indexPath
       check "the index was cached" (indexSize > 0)
       let (pkgId, expectedSize) = sampleSdist
-      sdistSize <- withSdist hackage pkgId getFileSize
-      check "the source tarball has the published size" (sdistSize == expectedSize)
+      fetched <- withSdist hackage pkgId getFileSize
+      check "the source tarball has the published size" $
+        case fetched of
+          Right sdistSize -> sdistSize == expectedSize
+          Left _ -> False
+      withdrawn <- withSdist hackage withdrawnSdist getFileSize
+      check "a withdrawn source tarball is reported, not thrown" $
+        case withdrawn of
+          Left _ -> True
+          Right _ -> False
 
 check :: String -> Bool -> IO ()
 check what ok = do

test/Main.hs

@@ -9,16 +9,20 @@ import qualified Data.Text as T
 import Data.Aeson (fromJSON, toJSON)
 import qualified Data.Aeson as Aeson
 import Data.Word (Word8)
+import Network.HTTP.Client (HttpException(InvalidUrlException))
+import Network.URI (nullURI)
 import Test.QuickCheck
 import Test.QuickCheck.Monadic (monadicIO, run)
 import Test.Tasty
 import Test.Tasty.QuickCheck
 
 import Data.Git.Ref (Ref, fromBinary, toBinary)
+import Hackage.Security.Client (SomeRemoteError(..))
 
 import Stackage.Package.Git.Object (makeGitFile)
 import Stackage.Package.Git.Types (FileName(..), GitFile(..), TreePath, toShortRef, fromShortRef, overlaps)
 import Stackage.Package.Git.WorkTree (emptyWorkTree, insertGitFile, lookupFile, removeGitFile)
+import Stackage.Package.HttpLib (UnexpectedResponse(..), unexpectedResponseStatus)
 import Stackage.Package.Metadata.Types (Deprecation(..))
 
 -- | Arbitrary instance for FileName.
@@ -295,6 +299,21 @@ prop_deprecation_json_roundtrip dep =
     Aeson.Success dep' -> dep' == dep
     Aeson.Error _      -> False
 
+-- UnexpectedResponse properties
+
+-- | A mirror that answered with a status is reported as that status.
+prop_unexpected_response_status :: Int -> Bool
+prop_unexpected_response_status code =
+  unexpectedResponseStatus (SomeRemoteError (UnexpectedResponse nullURI code)) ==
+  Just code
+
+-- | A failure to reach a mirror at all is not a status.
+prop_transport_failure_has_no_status :: Property
+prop_transport_failure_has_no_status =
+  once $
+  unexpectedResponseStatus (SomeRemoteError (InvalidUrlException "" "")) ==
+  Nothing
+
 main :: IO ()
 main = defaultMain tests
 
@@ -322,4 +341,8 @@ tests = testGroup "all-cabal-tool"
   , testGroup "Deprecation"
     [ testProperty "JSON roundtrip" prop_deprecation_json_roundtrip
     ]
+  , testGroup "UnexpectedResponse"
+    [ testProperty "a response carries its status" prop_unexpected_response_status
+    , testProperty "a transport failure has no status" prop_transport_failure_has_no_status
+    ]
   ]