Converted serveTarball to use the useETag helper.

ServeTarball deals with serving individual files from a package's tar file.

The previous code handled ETags by hand, and would include them
in the response but ignore any ETags in the request header.

Distribution/Server/Features/PackageCandidates.hs

@@ -403,8 +403,9 @@ candidatesFeature ServerEnv{serverBlobStore = store}
       case mChangeLog of
         Left err ->
           errNotFound "Changelog not found" [MText err]
-        Right (fp, etag, offset, name) ->
-          liftIO $ serveTarEntry fp offset name etag
+        Right (fp, etag, offset, name) -> do
+          useETag etag
+          liftIO $ serveTarEntry fp offset name
 
     -- return: not-found error or tarball
     serveContents :: DynamicPath -> ServerPartE Response

Distribution/Server/Features/PackageContents.hs

@@ -100,8 +100,9 @@ packageContentsFeature ServerEnv{serverBlobStore = store}
       case mChangeLog of
         Left err ->
           errNotFound "Changelog not found" [MText err]
-        Right (fp, etag, offset, name) ->
-          liftIO $ serveTarEntry fp offset name etag
+        Right (fp, etag, offset, name) -> do
+          useETag etag
+          liftIO $ serveTarEntry fp offset name
 
     -- return: not-found error or tarball
     serveContents :: DynamicPath -> ServerPartE Response

Distribution/Server/Util/ServeTarball.hs

@@ -23,7 +23,7 @@ import Happstack.Server.Monads
 import Happstack.Server.Routing (method)
 import Happstack.Server.Response
 import Happstack.Server.FileServe as Happstack (mimeTypes)
-import Distribution.Server.Util.Happstack (remainingPath, ETag(..), formatETag)
+import Distribution.Server.Util.Happstack (remainingPath, ETag, useETag)
 import Distribution.Server.Pages.Template (hackagePage)
 import Distribution.Server.Framework.ResponseContentTypes as Resource
 
@@ -70,7 +70,8 @@ serveTarball indices tarRoot tarball tarIndex etag = do
              case TarIndex.lookup tarIndex path of
                Just (TarIndex.TarFileEntry off)
                    -> do
-                 tfe <- liftIO $ serveTarEntry tarball off path etag
+                 useETag etag
+                 tfe <- liftIO $ serveTarEntry tarball off path
                  ok (toResponse tfe)
                _ -> mzero
 
@@ -84,8 +85,9 @@ serveTarball indices tarRoot tarball tarIndex etag = do
                  -> seeOther (addTrailingPathSeparator fullPath) (toResponse ())
 
                  | otherwise
-                 -> ok $ setHeader "ETag" (formatETag etag) $
-                         toResponse $ Resource.XHtml $ renderDirIndex fs
+                 -> do
+                      useETag etag
+                      ok $ toResponse $ Resource.XHtml $ renderDirIndex fs
                _ -> mzero
 
 renderDirIndex :: [FilePath] -> XHtml.Html
@@ -94,8 +96,8 @@ renderDirIndex entries = hackagePage "Directory Listing"
       XHtml.+++ XHtml.br
     | e <- entries ]
 
-serveTarEntry :: FilePath -> Int -> FilePath -> ETag -> IO Response
-serveTarEntry tarfile off fname etag = do
+serveTarEntry :: FilePath -> Int -> FilePath -> IO Response
+serveTarEntry tarfile off fname = do
   htar <- openFile tarfile ReadMode
   hSeek htar AbsoluteSeek (fromIntegral (off * 512))
   header <- BS.hGet htar 512
@@ -107,8 +109,7 @@ serveTarEntry tarfile off fname etag = do
                            ext       -> ext
              mimeType = Map.findWithDefault "text/plain" extension mimeTypes'
              response = ((setHeader "Content-Length" (show size)) .
-                         (setHeader "Content-Type" mimeType) .
-                         (setHeader "ETag" (formatETag etag))) $
+                         (setHeader "Content-Type" mimeType)) $
                          resultBS 200 body
          return response
     _ -> fail "oh noes!!"

tests/HackageClientUtils.hs

@@ -245,20 +245,21 @@ getUrl auth url = Http.execRequest auth (mkGetReq url)
 getETag :: RelativeURL -> IO String
 getETag url = Http.responseHeader HdrETag (mkGetReq url)
 
-checkETag :: String -> RelativeURL -> IO ()
-checkETag etag url = void $
-  Http.execRequest' NoAuth (mkGetReqWithETag url etag) isNotModified
-
-checkETagMismatch :: String -> RelativeURL -> IO ()
-checkETagMismatch etag url = void $
-  Http.execRequest NoAuth (mkGetReqWithETag url etag)
-
 mkGetReqWithETag :: String -> RelativeURL -> Request_String
 mkGetReqWithETag url etag =
     Request (fromJust $ parseURI $ mkUrl url) GET hdrs ""
   where
     hdrs = [mkHeader HdrIfNoneMatch etag]
 
+validateETagHandling :: RelativeURL -> IO ()
+validateETagHandling url = void $ do
+    etag <- getETag url
+    checkETag etag
+    checkETagMismatch (etag ++ "garbled123")
+  where
+    checkETag etag = void $ Http.execRequest' NoAuth (mkGetReqWithETag url etag) isNotModified
+    checkETagMismatch etag = void $ Http.execRequest NoAuth (mkGetReqWithETag url etag)
+
 getJSONStrings :: RelativeURL -> IO [String]
 getJSONStrings url = getUrl NoAuth url >>= decodeJSON
 

tests/HighLevelTest.hs

@@ -187,10 +187,7 @@ runPackageTests = do
            _ ->
                die "Bad index contents"
     do info "Getting package index with etag"
-       etag <- getETag "/packages/index.tar.gz"
-       info $ "Got etag: " ++ etag
-       checkETag etag "/packages/index.tar.gz"
-       checkETagMismatch (etag ++ "garbled123") "/packages/index.tar.gz"
+       validateETagHandling "/packages/index.tar.gz"
     do info "Getting testpackage info"
        xs <- validate NoAuth "/package/testpackage"
        unless ("The testpackage package" `isInfixOf` xs) $
@@ -211,6 +208,8 @@ runPackageTests = do
        hsFile <- getUrl NoAuth ("/package/testpackage/src" </> testpackageHaskellFilename)
        unless (hsFile == testpackageHaskellFileContent) $
            die "Bad Haskell file"
+    do info "Getting testpackage source with etag"
+       validateETagHandling ("/package/testpackage/src" </> testpackageHaskellFilename)
     do info "Getting testpackage maintainer info"
        xs <- getGroup "/package/testpackage/maintainers/.json"
        unless (map userName (groupMembers xs) == ["HackageTestUser1"]) $