diff --git a/hackage-server.cabal b/hackage-server.cabal index ba6b86341..c7e27f29a 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -404,6 +404,7 @@ library lib-server , semigroups ^>= 0.19 , split ^>= 0.2 , stm ^>= 2.5.0 + , stringsearch ^>= 0.3.6.6 , tagged ^>= 0.8.5 , xhtml ^>= 3000.2 , xmlgen ^>= 0.6 diff --git a/src/Distribution/Server/Features/Documentation.hs b/src/Distribution/Server/Features/Documentation.hs index 98dcfbd81..9fbbb14bb 100644 --- a/src/Distribution/Server/Features/Documentation.hs +++ b/src/Distribution/Server/Features/Documentation.hs @@ -32,7 +32,9 @@ import Distribution.Package import qualified Distribution.Parsec as P import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.ByteString.Lazy.Search as BSL +import qualified Data.ByteString.Char8 as BS import qualified Data.Map as Map import Data.Function (fix) @@ -283,7 +285,13 @@ documentationFeature name let maxAge = documentationCacheTime age ServerTarball.serveTarball (display pkgid ++ " documentation") [{-no index-}] (display pkgid ++ "-docs") - tarball index [Public, maxAge] etag + tarball index [Public, maxAge] etag (Just rewriteDocs) + + rewriteDocs :: BSL.ByteString -> BSL.ByteString + rewriteDocs dochtml = case BSL.breakFindAfter (BS.pack "") dochtml of + ((h,t),True) -> h `BSL.append` extraCss `BSL.append` t + _ -> dochtml + where extraCss = BSL.pack "" -- The cache time for documentation starts at ten minutes and -- increases exponentially for four days, when it cuts off at diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs index d222beb3f..4b0e2e819 100644 --- a/src/Distribution/Server/Features/PackageCandidates.hs +++ b/src/Distribution/Server/Features/PackageCandidates.hs @@ -611,7 +611,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} Right (fp, etag, index) -> serveTarball (display (packageId pkg) ++ " candidate source tarball") ["index.html"] (display (packageId pkg)) fp index - [Public, maxAgeMinutes 5] etag + [Public, maxAgeMinutes 5] etag Nothing unpackUtf8 :: BS.ByteString -> String unpackUtf8 = T.unpack diff --git a/src/Distribution/Server/Features/PackageContents.hs b/src/Distribution/Server/Features/PackageContents.hs index 7770ffecf..a3f5a2382 100644 --- a/src/Distribution/Server/Features/PackageContents.hs +++ b/src/Distribution/Server/Features/PackageContents.hs @@ -208,7 +208,7 @@ packageContentsFeature CoreFeature{ coreResource = CoreResource{ Right (fp, etag, index) -> serveTarball (display (packageId pkg) ++ " source tarball") [] (display (packageId pkg)) fp index - [Public, maxAgeDays 30] etag + [Public, maxAgeDays 30] etag Nothing unpackUtf8 :: BS.ByteString -> String unpackUtf8 = T.unpack diff --git a/src/Distribution/Server/Util/ServeTarball.hs b/src/Distribution/Server/Util/ServeTarball.hs index b4391f6d2..5d975f490 100644 --- a/src/Distribution/Server/Util/ServeTarball.hs +++ b/src/Distribution/Server/Util/ServeTarball.hs @@ -52,8 +52,9 @@ serveTarball :: (MonadIO m, MonadPlus m) -> TarIndex -- index for tarball -> [CacheControl] -> ETag -- the etag + -> Maybe (BS.ByteString -> BS.ByteString) -- optional transform to files -> ServerPartT m Response -serveTarball descr indices tarRoot tarball tarIndex cacheCtls etag = do +serveTarball descr indices tarRoot tarball tarIndex cacheCtls etag transform = do rq <- askRq action GET $ remainingPath $ \paths -> do @@ -74,7 +75,7 @@ serveTarball descr indices tarRoot tarball tarIndex cacheCtls etag = do Just (TarIndex.TarFileEntry off) -> do cacheControl cacheCtls etag - tfe <- liftIO $ serveTarEntry tarball off path + tfe <- liftIO $ serveTarEntry_ transform tarball off path ok (toResponse tfe) _ -> mzero @@ -116,22 +117,30 @@ renderDirIndex descr topdir topentries = loadTarEntry :: FilePath -> TarIndex.TarEntryOffset -> IO (Either String (Tar.FileSize, BS.ByteString)) -loadTarEntry tarfile off = do +loadTarEntry = loadTarEntry_ Nothing + +loadTarEntry_ :: Maybe (BS.ByteString -> BS.ByteString) -> FilePath -> TarIndex.TarEntryOffset -> IO (Either String (Tar.FileSize, BS.ByteString)) +loadTarEntry_ transform tarfile off = do htar <- openFile tarfile ReadMode hSeek htar AbsoluteSeek (fromIntegral $ off * 512) header <- BS.hGet htar 512 case Tar.read header of (Tar.Next Tar.Entry{Tar.entryContent = Tar.NormalFile _ size} _) -> do body <- BS.hGet htar (fromIntegral size) - return $ Right (size, body) + case transform of + Just f -> let x = f body in return $ Right (BS.length x, x) + Nothing -> return $ Right (size, body) _ -> fail "failed to read entry from tar file" serveTarEntry :: FilePath -> TarIndex.TarEntryOffset -> FilePath -> IO Response -serveTarEntry tarfile off fname = do - Right (size, body) <- loadTarEntry tarfile off - return . setHeader "Content-Length" (show size) - . setHeader "Content-Type" mimeType - $ resultBS 200 body +serveTarEntry = serveTarEntry_ Nothing + +serveTarEntry_ :: Maybe (BS.ByteString -> BS.ByteString) -> FilePath -> TarIndex.TarEntryOffset -> FilePath -> IO Response +serveTarEntry_ transform tarfile off fname = do + Right (size, body) <- loadTarEntry_ transform tarfile off + return . ((setHeader "Content-Length" (show size)) . + (setHeader "Content-Type" mimeType)) $ + resultBS 200 body where mimeType = mime fname constructTarIndexFromFile :: FilePath -> IO TarIndex