Skip to content

Commit 969915e

Browse files
AliasQliAliasQli
committed
Dynamically add css piece
1 parent 1daad17 commit 969915e

File tree

5 files changed

+31
-13
lines changed

5 files changed

+31
-13
lines changed

‎hackage-server.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -404,6 +404,7 @@ library lib-server
404404
, semigroups ^>= 0.19
405405
, split ^>= 0.2
406406
, stm ^>= 2.5.0
407+
, stringsearch ^>= 0.3.6.6
407408
, tagged ^>= 0.8.5
408409
, xhtml ^>= 3000.2
409410
, xmlgen ^>= 0.6

‎src/Distribution/Server/Features/Documentation.hs

Lines changed: 10 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -32,7 +32,9 @@ import Distribution.Package
3232
import qualified Distribution.Parsec as P
3333

3434
import qualified Data.ByteString.Char8 as C
35-
import qualified Data.ByteString.Lazy as BSL
35+
import qualified Data.ByteString.Lazy.Char8 as BSL
36+
import qualified Data.ByteString.Lazy.Search as BSL
37+
import qualified Data.ByteString.Char8 as BS
3638
import qualified Data.Map as Map
3739
import Data.Function (fix)
3840

@@ -283,7 +285,13 @@ documentationFeature name
283285
let maxAge = documentationCacheTime age
284286
ServerTarball.serveTarball (display pkgid ++ " documentation")
285287
[{-no index-}] (display pkgid ++ "-docs")
286-
tarball index [Public, maxAge] etag
288+
tarball index [Public, maxAge] etag (Just rewriteDocs)
289+
290+
rewriteDocs :: BSL.ByteString -> BSL.ByteString
291+
rewriteDocs dochtml = case BSL.breakFindAfter (BS.pack "<head>") dochtml of
292+
((h,t),True) -> h `BSL.append` extraCss `BSL.append` t
293+
_ -> dochtml
294+
where extraCss = BSL.pack "<style type=\"text/css\">#synopsis details:not([open]) > ul { visibility: hidden; }</style>"
287295

288296
-- The cache time for documentation starts at ten minutes and
289297
-- increases exponentially for four days, when it cuts off at

‎src/Distribution/Server/Features/PackageCandidates.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -611,7 +611,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
611611
Right (fp, etag, index) ->
612612
serveTarball (display (packageId pkg) ++ " candidate source tarball")
613613
["index.html"] (display (packageId pkg)) fp index
614-
[Public, maxAgeMinutes 5] etag
614+
[Public, maxAgeMinutes 5] etag Nothing
615615

616616
unpackUtf8 :: BS.ByteString -> String
617617
unpackUtf8 = T.unpack

‎src/Distribution/Server/Features/PackageContents.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -208,7 +208,7 @@ packageContentsFeature CoreFeature{ coreResource = CoreResource{
208208
Right (fp, etag, index) ->
209209
serveTarball (display (packageId pkg) ++ " source tarball")
210210
[] (display (packageId pkg)) fp index
211-
[Public, maxAgeDays 30] etag
211+
[Public, maxAgeDays 30] etag Nothing
212212

213213
unpackUtf8 :: BS.ByteString -> String
214214
unpackUtf8 = T.unpack

‎src/Distribution/Server/Util/ServeTarball.hs

Lines changed: 18 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -52,8 +52,9 @@ serveTarball :: (MonadIO m, MonadPlus m)
5252
-> TarIndex -- index for tarball
5353
-> [CacheControl]
5454
-> ETag -- the etag
55+
-> Maybe (BS.ByteString -> BS.ByteString) -- optional transform to files
5556
-> ServerPartT m Response
56-
serveTarball descr indices tarRoot tarball tarIndex cacheCtls etag = do
57+
serveTarball descr indices tarRoot tarball tarIndex cacheCtls etag transform = do
5758
rq <- askRq
5859
action GET $ remainingPath $ \paths -> do
5960

@@ -74,7 +75,7 @@ serveTarball descr indices tarRoot tarball tarIndex cacheCtls etag = do
7475
Just (TarIndex.TarFileEntry off)
7576
-> do
7677
cacheControl cacheCtls etag
77-
tfe <- liftIO $ serveTarEntry tarball off path
78+
tfe <- liftIO $ serveTarEntry_ transform tarball off path
7879
ok (toResponse tfe)
7980
_ -> mzero
8081

@@ -116,22 +117,30 @@ renderDirIndex descr topdir topentries =
116117

117118

118119
loadTarEntry :: FilePath -> TarIndex.TarEntryOffset -> IO (Either String (Tar.FileSize, BS.ByteString))
119-
loadTarEntry tarfile off = do
120+
loadTarEntry = loadTarEntry_ Nothing
121+
122+
loadTarEntry_ :: Maybe (BS.ByteString -> BS.ByteString) -> FilePath -> TarIndex.TarEntryOffset -> IO (Either String (Tar.FileSize, BS.ByteString))
123+
loadTarEntry_ transform tarfile off = do
120124
htar <- openFile tarfile ReadMode
121125
hSeek htar AbsoluteSeek (fromIntegral $ off * 512)
122126
header <- BS.hGet htar 512
123127
case Tar.read header of
124128
(Tar.Next Tar.Entry{Tar.entryContent = Tar.NormalFile _ size} _) -> do
125129
body <- BS.hGet htar (fromIntegral size)
126-
return $ Right (size, body)
130+
case transform of
131+
Just f -> let x = f body in return $ Right (BS.length x, x)
132+
Nothing -> return $ Right (size, body)
127133
_ -> fail "failed to read entry from tar file"
128134

129135
serveTarEntry :: FilePath -> TarIndex.TarEntryOffset -> FilePath -> IO Response
130-
serveTarEntry tarfile off fname = do
131-
Right (size, body) <- loadTarEntry tarfile off
132-
return . setHeader "Content-Length" (show size)
133-
. setHeader "Content-Type" mimeType
134-
$ resultBS 200 body
136+
serveTarEntry = serveTarEntry_ Nothing
137+
138+
serveTarEntry_ :: Maybe (BS.ByteString -> BS.ByteString) -> FilePath -> TarIndex.TarEntryOffset -> FilePath -> IO Response
139+
serveTarEntry_ transform tarfile off fname = do
140+
Right (size, body) <- loadTarEntry_ transform tarfile off
141+
return . ((setHeader "Content-Length" (show size)) .
142+
(setHeader "Content-Type" mimeType)) $
143+
resultBS 200 body
135144
where mimeType = mime fname
136145

137146
constructTarIndexFromFile :: FilePath -> IO TarIndex

0 commit comments

Comments
 (0)