Dynamically add css piece

brandonchinn178 · Jul 23, 2022 · 969915e · 969915e
1 parent 1daad17
commit 969915e
Show file tree

Hide file tree

Showing 5 changed files with 31 additions and 13 deletions.
diff --git 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
@@ -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 "<head>") dochtml of
+                ((h,t),True) -> h `BSL.append` extraCss `BSL.append` t
+                _ -> dochtml
+        where extraCss = BSL.pack "<style type=\"text/css\">#synopsis details:not([open]) > ul { visibility: hidden; }</style>"
 
     -- 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
@@ -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
@@ -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
@@ -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