diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,17 @@ +0.3.0.0 +------- +* Don't use compression for range requests (#101) +* Download index.tar.gz, not index.tar, if range request fails (#99) +* Minor change in the LogMessage type (hence the API version bumb) +* Include ChangeLog.md in the tarball (#98) + +0.2.0.0 +------- +* Allow for network-2.5 (rather than network-uri-2.6) +* Use cryptohash rather than SHA +* Various bugfixes +* API change: introduce RepoOpts in the Remote repository + +0.1.0.0 +------- +* Initial beta release diff --git a/hackage-security.cabal b/hackage-security.cabal --- a/hackage-security.cabal +++ b/hackage-security.cabal @@ -1,5 +1,5 @@ name: hackage-security -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Hackage security library description: The hackage security library provides both server and client utilities for securing the Hackage package server @@ -28,6 +28,9 @@ category: Distribution build-type: Simple cabal-version: >=1.10 + +extra-source-files: + ChangeLog.md flag base48 description: Are we using base 4.8 or later? diff --git a/src/Hackage/Security/Client/Repository.hs b/src/Hackage/Security/Client/Repository.hs --- a/src/Hackage/Security/Client/Repository.hs +++ b/src/Hackage/Security/Client/Repository.hs @@ -313,8 +313,8 @@ | LogSelectedMirror MirrorDescription -- | Updating a file failed - -- (we will try again by downloading it whole) - | LogUpdateFailed (Some RemoteFile) UpdateFailure + -- (we will instead download it whole) + | LogCannotUpdate (Some RemoteFile) UpdateFailure -- | We got an exception with a particular mirror -- (we will try with a different mirror if any are available) @@ -442,8 +442,8 @@ "Updating " ++ pretty file pretty (LogSelectedMirror mirror) = "Selected mirror " ++ mirror - pretty (LogUpdateFailed (Some file) ex) = - "Updating " ++ pretty file ++ " failed (" ++ pretty ex ++ ")" + pretty (LogCannotUpdate (Some file) ex) = + "Cannot update " ++ pretty file ++ " (" ++ pretty ex ++ ")" pretty (LogMirrorFailed mirror ex) = "Exception " ++ displayException ex ++ " when using mirror " ++ mirror diff --git a/src/Hackage/Security/Client/Repository/Remote.hs b/src/Hackage/Security/Client/Repository/Remote.hs --- a/src/Hackage/Security/Client/Repository/Remote.hs +++ b/src/Hackage/Security/Client/Repository/Remote.hs @@ -62,18 +62,11 @@ data ServerCapabilities_ = ServerCapabilities { -- | Does the server support range requests? serverAcceptRangesBytes :: Bool - - -- | Did the server apply content compression previously? - -- - -- We use this as a heuristic to decide whether we want to do an - -- incremental update of the index or not. - , serverUsedContentCompression :: Bool } newServerCapabilities :: IO ServerCapabilities newServerCapabilities = SC <$> newMVar ServerCapabilities { serverAcceptRangesBytes = False - , serverUsedContentCompression = False } updateServerCapabilities :: ServerCapabilities -> [HttpResponseHeader] -> IO () @@ -81,8 +74,6 @@ return $ caps { serverAcceptRangesBytes = serverAcceptRangesBytes caps || HttpResponseAcceptRangesBytes `elem` responseHeaders - , serverUsedContentCompression = serverUsedContentCompression caps - || HttpResponseContentCompression `elem` responseHeaders } checkServerCapability :: MonadIO m @@ -256,8 +247,11 @@ -- mess things up with respect to hashes etc). Additionally, after a validation -- error we want to make sure caches get files upstream in case the validation -- error was because the cache updated files out of order. -httpRequestHeaders :: RemoteConfig -> IsRetry -> [HttpRequestHeader] -httpRequestHeaders RemoteConfig{..} isRetry = +httpRequestHeaders :: RemoteConfig + -> IsRetry + -> DownloadMethod fs + -> [HttpRequestHeader] +httpRequestHeaders RemoteConfig{..} isRetry method = case isRetry of FirstAttempt -> defaultHeaders AfterVerificationError -> HttpRequestMaxAge0 : defaultHeaders @@ -267,10 +261,18 @@ defaultHeaders = concat [ [ HttpRequestNoTransform ] , [ HttpRequestContentCompression - | repoAllowContentCompression cfgOpts + | repoAllowContentCompression cfgOpts && not (isRangeRequest method) ] ] + -- If we are doing a range request, we must not request content compression: + -- servers such as Apache interpret this range against the _compressed_ + -- stream, making it near useless for our purposes here. + isRangeRequest :: DownloadMethod fs -> Bool + isRangeRequest NeverUpdated{} = False + isRangeRequest CannotUpdate{} = False + isRangeRequest Update{} = True + -- | Mirror selection withMirror :: forall a. HttpLib -- ^ HTTP client @@ -342,11 +344,12 @@ -- We record the trailer for the file; that is, the number of bytes -- (counted from the end of the file) that we should overwrite with -- the remote file. - | forall f. Update { - updateFormat :: HasFormat fs f - , updateInfo :: Trusted FileInfo - , updateLocal :: AbsolutePath - , updateTrailer :: Integer + | forall f f'. Update { + updateFormat :: HasFormat fs f + , updateInfo :: Trusted FileInfo + , updateLocal :: AbsolutePath + , updateTrailer :: Integer + , downloadFormat :: HasFormat fs f' -- ^ In case an update fails } pickDownloadMethod :: RemoteConfig @@ -391,24 +394,20 @@ let trailerLength = 1024 -- File sizes - canCompress <- checkServerCapability cfgCaps serverUsedContentCompression - localSize <- liftIO $ getFileSize cachedIndex - let infoGz = formatsLookup hasGz formats - infoUn = formatsLookup hasUn formats - estCompFactor = if canCompress && repoAllowContentCompression cfgOpts - then 10 - else 1 - estUpdateSize = (fileLength' infoUn - fromIntegral localSize) - `div` estCompFactor - unless (estUpdateSize < fileLength' infoGz) $ + localSize <- liftIO $ getFileSize cachedIndex + let infoGz = formatsLookup hasGz formats + infoUn = formatsLookup hasUn formats + updateSize = fileLength' infoUn - fromIntegral localSize + unless (updateSize < fileLength' infoGz) $ exit $ CannotUpdate hasGz UpdateTooLarge -- If all these checks pass try to do an incremental update. return Update { - updateFormat = hasUn - , updateInfo = infoUn - , updateLocal = cachedIndex - , updateTrailer = trailerLength + updateFormat = hasUn + , updateInfo = infoUn + , updateLocal = cachedIndex + , updateTrailer = trailerLength + , downloadFormat = hasGz } -- | Download the specified file using the given download method @@ -419,7 +418,8 @@ -> (forall f. HasFormat fs f -> TempPath -> IO a) -- ^ Callback -> DownloadMethod fs -- ^ Selected format -> IO a -getFile cfg@RemoteConfig{..} isRetry remoteFile callback = go +getFile cfg@RemoteConfig{..} isRetry remoteFile callback method = + go method where go :: (Throws VerificationError, Throws SomeRemoteError) => DownloadMethod fs -> IO a @@ -427,17 +427,14 @@ cfgLogger $ LogDownloading (Some remoteFile) download downloadFormat go CannotUpdate{..} = do - cfgLogger $ LogUpdateFailed (Some remoteFile) downloadReason + cfgLogger $ LogCannotUpdate (Some remoteFile) downloadReason cfgLogger $ LogDownloading (Some remoteFile) download downloadFormat go Update{..} = do cfgLogger $ LogUpdating (Some remoteFile) -- Attempt to download the file incrementally. let updateFailed :: SomeException -> IO a - updateFailed ex = do - let failure = UpdateFailed ex - cfgLogger $ LogUpdateFailed (Some remoteFile) failure - go $ CannotUpdate updateFormat failure + updateFailed = go . CannotUpdate downloadFormat . UpdateFailed -- If verification of the file fails, and this is the first attempt, -- we let the exception be thrown up to the security layer, so that @@ -459,7 +456,7 @@ update updateFormat updateInfo updateLocal updateTrailer headers :: [HttpRequestHeader] - headers = httpRequestHeaders cfg isRetry + headers = httpRequestHeaders cfg isRetry method -- Get any file from the server, without using incremental updates download :: Throws SomeRemoteError => HasFormat fs f -> IO a