Skip to content

Commit 49bc947

Browse files
gbazgbaz
authored
Merge pull request #1113 from AliasQli/css
Dynamically add css piece
2 parents 2f9a4ee + 969915e commit 49bc947

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
@@ -423,6 +423,7 @@ library lib-server
423423
, semigroups ^>= 0.20
424424
, split ^>= 0.2
425425
, stm ^>= 2.5.0
426+
, stringsearch ^>= 0.3.6.6
426427
, tagged ^>= 0.8.5
427428
, xhtml ^>= 3000.2
428429
, xmlgen ^>= 0.6

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

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

3535
import qualified Data.ByteString.Char8 as C
36-
import qualified Data.ByteString.Lazy as BSL
36+
import qualified Data.ByteString.Lazy.Char8 as BSL
37+
import qualified Data.ByteString.Lazy.Search as BSL
38+
import qualified Data.ByteString.Char8 as BS
3739
import qualified Data.Map as Map
3840
import Data.Function (fix)
3941

@@ -292,7 +294,13 @@ documentationFeature name
292294
let maxAge = documentationCacheTime age
293295
ServerTarball.serveTarball (display pkgid ++ " documentation")
294296
[{-no index-}] (display pkgid ++ "-docs")
295-
tarball index [Public, maxAge] etag
297+
tarball index [Public, maxAge] etag (Just rewriteDocs)
298+
299+
rewriteDocs :: BSL.ByteString -> BSL.ByteString
300+
rewriteDocs dochtml = case BSL.breakFindAfter (BS.pack "<head>") dochtml of
301+
((h,t),True) -> h `BSL.append` extraCss `BSL.append` t
302+
_ -> dochtml
303+
where extraCss = BSL.pack "<style type=\"text/css\">#synopsis details:not([open]) > ul { visibility: hidden; }</style>"
296304

297305
-- The cache time for documentation starts at ten minutes and
298306
-- 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)