Skip to content

Dynamically add css piece #1113

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 1 commit into from
Jan 2, 2023
Merged

Dynamically add css piece #1113

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions hackage-server.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
12 changes: 10 additions & 2 deletions src/Distribution/Server/Features/Documentation.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)

Expand Down Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion src/Distribution/Server/Features/PackageCandidates.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion src/Distribution/Server/Features/PackageContents.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
27 changes: 18 additions & 9 deletions src/Distribution/Server/Util/ServeTarball.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand All @@ -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

Expand Down Expand Up @@ -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
Expand Down