Merge pull request #21 from commercialhaskell/b/hackage-security

Use hackage-security and TUF

Author: chreekat

all-cabal-tool.cabal

@@ -12,6 +12,11 @@ build-type:          Simple
 extra-source-files:  README.md ChangeLog.md
 cabal-version:       >=1.10
 
+flag integration
+  description:       Build the test suite that talks to the live Hackage repository.
+  default:           False
+  manual:            True
+
 library
   hs-source-dirs:      src
   exposed-modules:     Stackage.Package.Hashes
@@ -22,6 +27,8 @@ library
                      , Stackage.Package.Git.Repository
                      , Stackage.Package.Git.Types
                      , Stackage.Package.Git.WorkTree
+                     , Stackage.Package.Hackage
+                     , Stackage.Package.HttpLib
                      , Stackage.Package.Metadata
                      , Stackage.Package.Metadata.Types
                      , Stackage.Package.Update
@@ -39,19 +46,22 @@ library
                      , directory
                      , enclosed-exceptions
                      , filepath
+                     , hackage-security
                      , hit
                      , hourglass
                      , http-client
                      , http-client-tls
                      , http-conduit
                      , http-types
                      , memory
+                     , network-uri
                      , pretty
                      , process
                      , resourcet
                      , system-filepath
                      , tar
                      , text
+                     , time
                      , utf8-string
                      , yaml
                      , zlib
@@ -71,6 +81,7 @@ executable all-cabal-tool
                      , classy-prelude-conduit
                      , conduit-extra
                      , directory
+                     , hackage-security
                      , http-client
                      , http-conduit
                      , http-types
@@ -99,6 +110,21 @@ test-suite all-cabal-tool-test
   default-language:    Haskell2010
   ghc-options:         -Wall
 
+test-suite all-cabal-tool-integration
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test-integration
+  main-is:             Main.hs
+  build-depends:       base
+                     , Cabal
+                     , all-cabal-tool
+                     , directory
+                     , temporary
+                     , time
+  default-language:    Haskell2010
+  ghc-options:         -Wall
+  if !flag(integration)
+    buildable:         False
+
 source-repository head
   type:     git
   location: https://github.com/commercialhaskell/all-cabal-tool

app/Main.hs

@@ -20,14 +20,13 @@ import Amazonka.Auth (fromKeys)
 import Amazonka.S3.PutObject
 import Amazonka.S3 (BucketName(..), ObjectKey(..), ObjectCannedACL(..))
 import Network.HTTP.Client (parseUrlThrow)
-import Network.HTTP.Simple
-       (Request, parseRequest, addRequestHeader, getResponseStatus,
-        getResponseStatusCode, getResponseHeader, getResponseBody, httpLBS)
+import Network.HTTP.Simple (getResponseBody, httpLBS)
 import Options.Applicative
 import System.Environment (getEnv, lookupEnv)
 import System.IO (hPutStrLn)
 
 import Stackage.Package.Update
+import Stackage.Package.Hackage
 import Stackage.Package.Locations
 import Stackage.Package.Git
 import Stackage.Package.IndexConduit
@@ -108,38 +107,25 @@ updateIndex00 awsMech bucketName = do
     Left e -> error $ show (key, e :: Error)
     Right _ -> putStrLn "Success"
 
+-- | Refresh the local index and, if it moved (or a refresh is being forced),
+-- regenerate the repositories from it.
 processIndexUpdate
   :: MonadIO m
-  => Repositories
-  -> Request -- ^ Request that should be processed
-  -> Maybe ByteString -- ^ Previous Etag, so we can check if the content has changed.
-  -> m (Bool, Maybe ByteString)
-processIndexUpdate repos indexReq mLastEtag = liftIO $ do
-  let indexReqWithEtag =
-        maybe id (addRequestHeader "if-none-match") mLastEtag indexReq
-  mValidVersionsWithEtag <-
-    httpTarballSink
-      indexReqWithEtag
-      True
-      (\res ->
-         case getResponseStatusCode res of
-           200 -> do
-             validVersions <- allHashesUpdate repos
-             return $
-               Just (validVersions, listToMaybe $ getResponseHeader "etag" res)
-           304 -> return Nothing
-           _ -> error $ "Unexpected status: " ++ show (getResponseStatus res))
-  case mValidVersionsWithEtag of
-    Nothing -> return (False, mLastEtag)
-    Just (validVersions, mNewEtag) ->
-      httpTarballSink
-        indexReqWithEtag
-        True
-        (\res ->
-           case getResponseStatusCode res of
-             200 -> (True, mNewEtag) <$ allCabalUpdate repos validVersions
-             304 -> return (False, mLastEtag)
-             _ -> error $ "Unexpected status: " ++ show (getResponseStatus res))
+  => Hackage
+  -> Repositories
+  -> UTCTime -- ^ Time to judge index metadata expiry against
+  -> Bool -- ^ Regenerate even when the index is unchanged.
+  -> m Bool
+processIndexUpdate hackage repos now forceUpdate = liftIO $ do
+  (hasUpdates, indexPath) <- refreshIndex hackage now
+  case hasUpdates of
+    NoUpdates
+      | not forceUpdate -> return False
+    _ -> do
+      validVersions <-
+        localTarballSink indexPath False (allHashesUpdate hackage repos)
+      localTarballSink indexPath False (allCabalUpdate hackage repos validVersions)
+      return True
 
 
 
@@ -152,6 +138,7 @@ data Options = Options
                , oLocalPath :: Maybe FilePath -- default $HOME
                , oGithubAccount :: String -- default "commercialhaskell"
                , oDelay :: Maybe Int -- default 60 seconds
+               , oOneShot :: Bool
                , oS3Bucket :: Maybe BucketName
                , oAwsDiscoveryMech :: AwsDiscoverMechanism
                }
@@ -200,6 +187,10 @@ optionsParser =
          help
            ("Delay in seconds before next check for a new version " ++
             "of 01-index.tar.gz file")))) <*>
+  (switch
+     (long "one-shot" <>
+      help
+        ("Update once and exit, instead of polling forever. "))) <*>
   (optional
      ((BucketName . pack) <$>
       (strOption
@@ -233,29 +224,36 @@ main = do
   when (isNothing ms3Bucket) $
     putStrLn
       "WARNING: No s3-bucket is provided. Uploading of 00-index.tar.gz will be disabled."
-  indexReq <- parseRequest $ mirrorFPComplete ++ "/01-index.tar.gz"
   reposInfoInit <- getReposInfo localPath oGithubAccount gitUser
-  let innerLoop reposInfo mlastEtag = do
-        putStrLn $ "Checking index, etag == " ++ tshow mlastEtag
-        commitMessage <- getCommitMessage
-        (newInfo, mnewEtag) <- withRepositories reposInfo $ \ repos -> do
-          (updated, mnewEtag) <- processIndexUpdate repos indexReq mlastEtag
-          when updated $
-            do pushRepos repos commitMessage
-               case ms3Bucket of
-                 Just s3Bucket ->
-                   updateIndex00 oAwsDiscoveryMech s3Bucket
-                 _ -> return ()
-          return mnewEtag
-        threadDelay delay
-        innerLoop newInfo mnewEtag
-  let outerLoop = do
-        catchAny
-          (innerLoop reposInfoInit Nothing)
-          (\e -> do
-             hPutStrLn stderr $
-               "ERROR: Received an unexpected exception while updating repositories: " ++
-               show e
-             threadDelay delay
-             outerLoop)
-  outerLoop
+  withHackage (localPath </> "hackage-security-cache") $ \hackage -> do
+    let onePass reposInfo forceUpdate = do
+          putStrLn "Checking index"
+          now <- getCurrentTime
+          commitMessage <- getCommitMessage
+          (newInfo, ()) <- withRepositories reposInfo $ \ repos -> do
+            updated <- processIndexUpdate hackage repos now forceUpdate
+            when updated $
+              do pushRepos repos commitMessage
+                 case ms3Bucket of
+                   Just s3Bucket ->
+                     updateIndex00 oAwsDiscoveryMech s3Bucket
+                   _ -> return ()
+          return newInfo
+    let innerLoop reposInfo forceUpdate = do
+          newInfo <- onePass reposInfo forceUpdate
+          threadDelay delay
+          innerLoop newInfo False
+    let outerLoop = do
+          catchAny
+            -- A fresh process has no idea how far behind the repositories are,
+            -- so the first pass runs whether or not the index moved.
+            (innerLoop reposInfoInit True)
+            (\e -> do
+               hPutStrLn stderr $
+                 "ERROR: Received an unexpected exception while updating repositories: " ++
+                 show e
+               threadDelay delay
+               outerLoop)
+    if oOneShot
+      then void $ onePass reposInfoInit False
+      else outerLoop

justfile

@@ -16,6 +16,10 @@ push-cachix:
     nix develop --profile .dev-profile -c true
     cachix push stackage-infrastructure .dev-profile
 
+# Run the test suite that talks to the live Hackage repository
+test-integration:
+    nix develop --command cabal test all-cabal-tool-integration --flags=integration
+
 # Build with stack
 build-stack:
     stack build

nix/packages/all-cabal-tool.nix

@@ -2,11 +2,11 @@
 { mkDerivation, aeson, amazonka, amazonka-core, amazonka-s3, base
 , byteable, bytestring, Cabal, classy-prelude-conduit, conduit
 , conduit-extra, containers, cryptonite, cryptonite-conduit
-, directory, enclosed-exceptions, filepath, hit, hourglass
-, http-client, http-client-tls, http-conduit, http-types, lens, lib
-, memory, optparse-applicative, pretty, process, QuickCheck
-, resourcet, system-filepath, tar, tasty, tasty-quickcheck
-, temporary, text, utf8-string, yaml, zlib
+, directory, enclosed-exceptions, filepath, hackage-security, hit
+, hourglass, http-client, http-client-tls, http-conduit, http-types
+, lens, lib, memory, network-uri, optparse-applicative, pretty
+, process, QuickCheck, resourcet, system-filepath, tar, tasty
+, tasty-quickcheck, temporary, text, time, utf8-string, yaml, zlib
 }:
 mkDerivation {
   pname = "all-cabal-tool";
@@ -17,14 +17,16 @@ mkDerivation {
   libraryHaskellDepends = [
     aeson base byteable bytestring Cabal classy-prelude-conduit conduit
     conduit-extra containers cryptonite cryptonite-conduit directory
-    enclosed-exceptions filepath hit hourglass http-client
-    http-client-tls http-conduit http-types memory pretty process
-    resourcet system-filepath tar text utf8-string yaml zlib
+    enclosed-exceptions filepath hackage-security hit hourglass
+    http-client http-client-tls http-conduit http-types memory
+    network-uri pretty process resourcet system-filepath tar text time
+    utf8-string yaml zlib
   ];
   executableHaskellDepends = [
     aeson amazonka amazonka-core amazonka-s3 base bytestring
-    classy-prelude-conduit conduit-extra directory http-client
-    http-conduit http-types lens optparse-applicative temporary zlib
+    classy-prelude-conduit conduit-extra directory hackage-security
+    http-client http-conduit http-types lens optparse-applicative
+    temporary zlib
   ];
   testHaskellDepends = [
     aeson base bytestring containers hit QuickCheck tasty

src/Stackage/Package/Git/Object.hs

@@ -23,6 +23,7 @@ import Data.Git.Storage
 import Data.Git.Storage.Object
 import Data.Git.Ref
 import Data.Git.Storage.Loose
+import GHC.Stack (HasCallStack)
 import System.Directory
 import System.FilePath
 
@@ -40,17 +41,17 @@ data GitObject
 -- | Marshalls a bytestring into a git blob object, computes its SHA1,
 -- compresses it and returns a `GitFile` that is of type `NonExecFile`.
 makeGitFile
-  :: (MonadThrow m, PrimMonad m)
+  :: (HasCallStack, MonadThrow m, PrimMonad m)
   => LByteString -- ^ Content of the blob.
   -> Word64 -- ^ Size of the content.
   -> m GitFile
 makeGitFile lbs sz = do
   (sha1, zipped) <-
     runConduit $
-    srcWithHeader "blob" lbs sz =$=
+    srcWithHeader "blob" lbs sz .|
     getZipSink ((,) <$> ZipSink sha1Sink <*> ZipSink compressSink)
   unless (sz == fromIntegral (L.length lbs)) $
-    error "Stackage.Package.Git.makeGitFile: Size mismatch."
+    error "Size mismatch."
   return $
     GitFile
     { gitFileRef = unDigestRef sha1
@@ -122,11 +123,11 @@ srcWithHeader oType oContent oSize = do
 
 compressSink
   :: (PrimMonad m, MonadThrow m)
-  => Consumer ByteString m ByteString
-compressSink = compress 1 defaultWindowBits =$= foldC
+  => ConduitT ByteString Void m ByteString
+compressSink = compress 1 defaultWindowBits .| foldC
 
 
-sha1Sink :: (Monad m) => Consumer ByteString m (Digest SHA1)
+sha1Sink :: (Monad m) => ConduitT ByteString Void m (Digest SHA1)
 sha1Sink = sinkHash