Skip to content

Commit 866279e

Browse files
ysangkokysangkok
authored
Merge pull request #1468 from haskell/strict-CabalFileText
Make CabalFileText to wrap a strict ByteString, not a lazy one
2 parents 3679c5a + 36f2763 commit 866279e

File tree

19 files changed

+107
-142
lines changed

19 files changed

+107
-142
lines changed

‎hackage-server.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -149,7 +149,7 @@ common defaults
149149
, array >= 0.5 && < 0.6
150150
, base >= 4.18 && < 4.22
151151
, binary >= 0.8 && < 0.9
152-
, bytestring >= 0.10 && < 0.13
152+
, bytestring >= 0.11.2 && < 0.13
153153
, containers >= 0.6.0 && < 0.9
154154
, deepseq >= 1.4 && < 1.6
155155
, directory >= 1.3 && < 1.4

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

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -27,7 +27,7 @@ import qualified Codec.Compression.GZip as GZip
2727
import Data.Aeson (Value (..), toJSON)
2828
import qualified Data.Aeson.Key as Key
2929
import qualified Data.Aeson.KeyMap as KeyMap
30-
import Data.ByteString.Lazy (ByteString)
30+
import Data.ByteString.Lazy (LazyByteString, fromStrict)
3131
import qualified Data.Foldable as Foldable
3232
import qualified Data.Text as Text
3333
import Data.Time.Clock (UTCTime, getCurrentTime)
@@ -130,7 +130,7 @@ data CoreFeature = CoreFeature {
130130
-- modification time for the tar entry.
131131
--
132132
-- This runs a `PackageChangeIndexExtra` hook when done.
133-
updateArchiveIndexEntry :: forall m. MonadIO m => FilePath -> ByteString -> UTCTime -> m (),
133+
updateArchiveIndexEntry :: forall m. MonadIO m => FilePath -> LazyByteString -> UTCTime -> m (),
134134

135135
-- | Notification of package or index changes.
136136
packageChangeHook :: Hook PackageChange (),
@@ -175,7 +175,7 @@ data PackageChange
175175
| PackageChangeInfo PackageUpdate PkgInfo PkgInfo
176176
-- | A file has changed in the package index tar not covered by any of the
177177
-- other change types.
178-
| PackageChangeIndexExtra String ByteString UTCTime
178+
| PackageChangeIndexExtra String LazyByteString UTCTime
179179

180180
-- | A predicate to use with `packageChangeHook` and `registerHookJust` for
181181
-- keeping other features synchronized with the main package index.
@@ -212,7 +212,7 @@ isPackageDeleteVersion :: Maybe PackageId,
212212
isPackageChangeCabalFile :: Maybe (PackageId, CabalFileText),
213213
isPackageChangeCabalFileUploadInfo :: Maybe (PackageId, UploadInfo),
214214
isPackageChangeTarball :: Maybe (PackageId, PkgTarball),
215-
isPackageIndexExtraChange :: Maybe (String, ByteString, UTCTime)
215+
isPackageIndexExtraChange :: Maybe (String, LazyByteString, UTCTime)
216216
-}
217217

218218
data CoreResource = CoreResource {
@@ -591,7 +591,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
591591
runHook_ packageChangeHook (PackageChangeInfo PackageUpdatedUploadTime oldpkginfo newpkginfo)
592592
return True
593593

594-
updateArchiveIndexEntry :: MonadIO m => FilePath -> ByteString -> UTCTime -> m ()
594+
updateArchiveIndexEntry :: MonadIO m => FilePath -> LazyByteString -> UTCTime -> m ()
595595
updateArchiveIndexEntry entryName entryData entryTime = logTiming maxBound ("updateArchiveIndexEntry " ++ show entryName) $ do
596596
updateState packagesState $
597597
AddOtherIndexEntry $ ExtraEntry entryName entryData entryTime
@@ -721,7 +721,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
721721
-- check that the cabal name matches the package
722722
guard (lookup "cabal" dpath == Just (display $ packageName pkginfo))
723723
let (fileRev, (utime, _uid)) = pkgLatestRevision pkginfo
724-
cabalfile = Resource.CabalFile (cabalFileByteString fileRev) utime
724+
cabalfile = Resource.CabalFile (fromStrict $ cabalFileByteString fileRev) utime
725725
return $ toResponse cabalfile
726726

727727
serveCabalFileRevisionsList :: DynamicPath -> ServerPartE Response
@@ -731,7 +731,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
731731
let revisions = pkgMetadataRevisions pkginfo
732732
revisionToObj rev (cabalFileText, (utime, uid)) =
733733
let uname = userIdToName users uid
734-
hash = sha256 (cabalFileByteString cabalFileText)
734+
hash = sha256 (fromStrict $ cabalFileByteString cabalFileText)
735735
in
736736
Object $ KeyMap.fromList
737737
[ (Key.fromString "number", Number (fromIntegral rev))
@@ -750,7 +750,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
750750
case mrev >>= \rev -> revisions Vec.!? rev of
751751
Just (fileRev, (utime, _uid)) -> return $ toResponse cabalfile
752752
where
753-
cabalfile = Resource.CabalFile (cabalFileByteString fileRev) utime
753+
cabalfile = Resource.CabalFile (fromStrict $ cabalFileByteString fileRev) utime
754754
Nothing -> errNotFound "Package revision not found"
755755
[MText "Cannot parse revision, or revision out of range."]
756756

‎src/Distribution/Server/Features/Core/Backup.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -98,7 +98,7 @@ doPackageImport (PartialIndex packages updatelog) entry = case entry of
9898
list <- importCSV "tarball.csv" bs >>= importTarballMetadata fp
9999
return $ partial { partialTarballUpload = list }
100100
[other] | Just version <- extractVersion other (packageName pkgId) ".cabal" ->
101-
return $ partial { partialCabal = (version, CabalFileText bs):partialCabal partial }
101+
return $ partial { partialCabal = (version, CabalFileText $ BS.toStrict bs) : partialCabal partial }
102102
_ -> return partial
103103
return $! PartialIndex (Map.insert pkgId partial' packages) updatelog
104104
BackupBlob filename@["package",pkgStr,other] blobId -> do
@@ -198,7 +198,7 @@ partialToFullPkg (pkgId, PartialPkg{..}) = do
198198
filename = display pkgId ++ ".cabal"
199199

200200
case runParseResult $ parseGenericPackageDescription $
201-
BS.toStrict $ cabalFileByteString latestCabalFile of
201+
cabalFileByteString latestCabalFile of
202202
(_, Left (_, errs)) -> fail $ unlines (map (showPError filename) $ toList errs)
203203
(_, Right _) -> return ()
204204

@@ -322,8 +322,8 @@ cabalListToExport pkgId cabalInfos =
322322
cabalName = display (packageName pkgId) ++ ".cabal"
323323

324324
blobEntry :: (Int, CabalFileText) -> BackupEntry
325-
blobEntry (0, CabalFileText bs) = BackupByteString (pkgPath pkgId cabalName) bs
326-
blobEntry (n, CabalFileText bs) = BackupByteString (pkgPath pkgId (cabalName ++ "-" ++ show n)) bs
325+
blobEntry (0, CabalFileText bs) = BackupByteString (pkgPath pkgId cabalName) (BS.fromStrict bs)
326+
blobEntry (n, CabalFileText bs) = BackupByteString (pkgPath pkgId (cabalName ++ "-" ++ show n)) (BS.fromStrict bs)
327327

328328
cabalMetadata :: CSV
329329
cabalMetadata =

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

Lines changed: 10 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,8 @@ import Distribution.Server.Util.CabalRevisions
2323
(Change(..), diffCabalRevisions, insertRevisionField)
2424
import Text.StringTemplate.Classes (SElem(SM))
2525

26-
import Data.ByteString.Lazy (ByteString)
26+
import Data.ByteString (StrictByteString)
27+
import Data.ByteString.Lazy (LazyByteString)
2728
import qualified Data.ByteString.Lazy as BS.L
2829
import qualified Data.Map as Map
2930
import Data.Time (getCurrentTime)
@@ -84,7 +85,7 @@ editCabalFilesFeature _env templates
8485
ok $ toResponse $ template
8586
[ "pkgid" $= pkgid
8687
, "cabalfile" $= insertRevisionField (pkgNumRevisions pkg)
87-
(cabalFileByteString (pkgLatestCabalFileText pkg))
88+
(BS.L.fromStrict (cabalFileByteString (pkgLatestCabalFileText pkg)))
8889
]
8990

9091
serveEditCabalFilePost :: DynamicPath -> ServerPartE Response
@@ -98,11 +99,11 @@ editCabalFilesFeature _env templates
9899
uid <- guardAuthorised [ InGroup (maintainersGroup pkgname)
99100
, InGroup trusteesGroup ]
100101
let oldVersion = cabalFileByteString (pkgLatestCabalFileText pkg)
101-
newRevision <- getCabalFile
102+
newRevision <- BS.L.toStrict <$> getCabalFile
102103
shouldPublish <- getPublish
103104
case diffCabalRevisionsByteString oldVersion newRevision of
104105
Left errs ->
105-
responseTemplate template pkgid newRevision
106+
responseTemplate template pkgid (BS.L.fromStrict newRevision)
106107
shouldPublish [errs] []
107108

108109
Right changes
@@ -117,7 +118,7 @@ editCabalFilesFeature _env templates
117118
, "changes" $= changes
118119
]
119120
| otherwise ->
120-
responseTemplate template pkgid newRevision
121+
responseTemplate template pkgid (BS.L.fromStrict newRevision)
121122
shouldPublish [] changes
122123

123124
where
@@ -126,7 +127,7 @@ editCabalFilesFeature _env templates
126127
(look "publish" >> return True)
127128

128129
responseTemplate :: ([TemplateAttr] -> Template) -> PackageId
129-
-> ByteString -> Bool -> [String] -> [Change]
130+
-> LazyByteString -> Bool -> [String] -> [Change]
130131
-> ServerPartE Response
131132
responseTemplate template pkgid cabalFile publish errors changes =
132133
ok $ toResponse $ template
@@ -139,11 +140,11 @@ editCabalFilesFeature _env templates
139140

140141

141142
-- | Wrapper around 'diffCabalRevisions' which operates on
142-
-- 'ByteString' decoded with lenient UTF8 and with any leading BOM
143+
-- 'LazyByteString' decoded with lenient UTF8 and with any leading BOM
143144
-- stripped.
144-
diffCabalRevisionsByteString :: ByteString -> ByteString -> Either String [Change]
145+
diffCabalRevisionsByteString :: StrictByteString -> StrictByteString -> Either String [Change]
145146
diffCabalRevisionsByteString oldRevision newRevision =
146-
maybe (diffCabalRevisions (BS.L.toStrict oldRevision) (BS.L.toStrict newRevision))
147+
maybe (diffCabalRevisions oldRevision newRevision)
147148
Left
148149
parseSpecVerCheck
149150
where

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

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -68,7 +68,7 @@ import qualified Data.Map as Map
6868
import qualified Data.Set as Set
6969
import qualified Data.Vector as Vec
7070
import qualified Data.Text as T
71-
import qualified Data.ByteString.Lazy.Char8 as BS (ByteString)
71+
import qualified Data.ByteString.Lazy as BS (LazyByteString, fromStrict)
7272
import qualified Network.URI as URI
7373

7474
import Text.XHtml.Strict
@@ -812,9 +812,9 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
812812
start [] = []
813813
start (curr:rest) = go curr rest
814814

815-
go curr [] = [(sha256 (cabalFileByteString (fst curr)), [])]
815+
go curr [] = [(sha256 (BS.fromStrict (cabalFileByteString (fst curr))), [])]
816816
go curr (prev:rest) =
817-
( sha256 (cabalFileByteString (fst curr))
817+
( sha256 (BS.fromStrict (cabalFileByteString (fst curr)))
818818
, changes curr prev )
819819
: go prev rest
820820

@@ -849,7 +849,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
849849

850850

851851
-- | Common helper used by 'serveCandidatePage' and 'servePackagePage'
852-
makeReadme :: MonadIO m => PackageRender -> m (Maybe BS.ByteString)
852+
makeReadme :: MonadIO m => PackageRender -> m (Maybe BS.LazyByteString)
853853
makeReadme render = case rendReadme render of
854854
Just (tarfile, _, offset, _) ->
855855
either (\_err -> return Nothing) (return . Just . snd) =<<

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -243,12 +243,12 @@ mirrorFeature ServerEnv{serverBlobStore = store}
243243
cabalPut dpath = do
244244
uid <- guardMirrorGroup
245245
pkgid :: PackageId <- packageInPath dpath
246-
fileContent <- expectTextPlain
246+
fileContent <- BS.L.toStrict <$> expectTextPlain
247247
time <- liftIO getCurrentTime
248248
let uploadData = (time, uid)
249249
filename = display pkgid <.> "cabal"
250250

251-
case runParseResult $ parseGenericPackageDescription $ BS.L.toStrict fileContent of
251+
case runParseResult $ parseGenericPackageDescription fileContent of
252252
(_, Left (_, err NE.:| _)) -> badRequest (toResponse $ showPError filename err)
253253
(_, Right pkg) | pkgid /= packageId pkg ->
254254
errBadRequest "Wrong package Id"

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

Lines changed: 6 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ import Distribution.Server.Packages.PackageIndex (PackageIndex)
3232
import qualified Distribution.Server.Framework.ResponseContentTypes as Resource
3333
import Distribution.Server.Features.Security.Migration
3434

35+
import Distribution.Server.Util.Parse (unpackUTF8)
3536
import Distribution.Server.Util.ServeTarball
3637
import Distribution.Server.Util.Markdown (renderMarkdown, supposedToBeMarkdown)
3738
import Distribution.Server.Pages.Template (hackagePage)
@@ -40,10 +41,8 @@ import Distribution.Text
4041
import Distribution.Package
4142
import Distribution.Version
4243

44+
import qualified Data.ByteString.Lazy as BS (toStrict, fromStrict)
4345
import qualified Data.Text as T
44-
import qualified Data.Text.Encoding as T
45-
import qualified Data.Text.Encoding.Error as T
46-
import qualified Data.ByteString.Lazy as BS (ByteString, toStrict)
4746
import qualified Text.XHtml.Strict as XHtml
4847
import Text.XHtml.Strict ((<<), (!))
4948
import Data.Aeson (Value (..), object, toJSON, (.=))
@@ -383,7 +382,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
383382
pkg <- packageInPath dpath >>= lookupCandidateId
384383
guard (lookup "cabal" dpath == Just (display $ packageName pkg))
385384
let (fileRev, (utime, _uid)) = pkgLatestRevision (candPkgInfo pkg)
386-
cabalfile = Resource.CabalFile (cabalFileByteString fileRev) utime
385+
cabalfile = Resource.CabalFile (BS.fromStrict (cabalFileByteString fileRev)) utime
387386
return $ toResponse cabalfile
388387

389388
uploadCandidate :: (PackageId -> Bool) -> ServerPartE CandPkgInfo
@@ -396,7 +395,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
396395
now <- liftIO getCurrentTime
397396
let (UploadResult pkg pkgStr _) = uresult
398397
pkgid = packageId pkg
399-
cabalfile = CabalFileText pkgStr
398+
cabalfile = CabalFileText $ BS.toStrict pkgStr
400399
uploadinfo = (now, uid)
401400
candidate = CandPkgInfo {
402401
candPkgInfo = PkgInfo {
@@ -453,7 +452,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
453452
-- run filters
454453
let pkgInfo = candPkgInfo candidate
455454
uresult = UploadResult (pkgDesc pkgInfo)
456-
(cabalFileByteString (pkgLatestCabalFileText pkgInfo))
455+
(BS.fromStrict (cabalFileByteString (pkgLatestCabalFileText pkgInfo)))
457456
(candWarnings candidate)
458457
time <- liftIO getCurrentTime
459458
let uploadInfo = (time, uid)
@@ -596,7 +595,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
596595
<< if supposedToBeMarkdown filename
597596
then renderMarkdown filename contents
598597
else XHtml.thediv ! [XHtml.theclass "preformatted"]
599-
<< unpackUtf8 contents
598+
<< unpackUTF8 contents
600599
]
601600

602601

@@ -614,8 +613,3 @@ candidatesFeature ServerEnv{serverBlobStore = store}
614613
["index.html"] (display (packageId pkg)) fp index
615614
[Public, maxAgeMinutes 5] etag Nothing
616615
requireUserContent userFeatureServerEnv (tarServeResponse tarServe)
617-
618-
unpackUtf8 :: BS.ByteString -> String
619-
unpackUtf8 = T.unpack
620-
. T.decodeUtf8With T.lenientDecode
621-
. BS.toStrict

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

Lines changed: 3 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -18,16 +18,13 @@ import Distribution.Server.Packages.Render
1818
import Distribution.Server.Features.Users
1919
import Distribution.Server.Util.ServeTarball
2020
import Distribution.Server.Util.Markdown (renderMarkdown, supposedToBeMarkdown)
21+
import Distribution.Server.Util.Parse (unpackUTF8)
2122
import Distribution.Server.Pages.Template (hackagePage)
2223

2324
import Distribution.Text
2425
import Distribution.Package
2526
import Distribution.PackageDescription
2627

27-
import qualified Data.Text as T
28-
import qualified Data.Text.Encoding as T
29-
import qualified Data.Text.Encoding.Error as T
30-
import qualified Data.ByteString.Lazy as BS (ByteString, toStrict)
3128
import qualified Text.XHtml.Strict as XHtml
3229
import qualified Distribution.Utils.ShortText as ST
3330
import Text.XHtml.Strict ((<<), (!))
@@ -160,7 +157,7 @@ packageContentsFeature CoreFeature{ coreResource = CoreResource{
160157
<< if supposedToBeMarkdown filename
161158
then renderMarkdown filename contents
162159
else XHtml.thediv ! [XHtml.theclass "preformatted"]
163-
<< unpackUtf8 contents
160+
<< unpackUTF8 contents
164161
]
165162

166163
serveReadmeText :: DynamicPath -> ServerPartE Response
@@ -194,7 +191,7 @@ packageContentsFeature CoreFeature{ coreResource = CoreResource{
194191
<< if supposedToBeMarkdown filename
195192
then renderMarkdown filename contents
196193
else XHtml.thediv ! [XHtml.theclass "preformatted"]
197-
<< unpackUtf8 contents
194+
<< unpackUTF8 contents
198195
]
199196

200197
-- return: not-found error or tarball
@@ -212,11 +209,6 @@ packageContentsFeature CoreFeature{ coreResource = CoreResource{
212209
[Public, maxAgeDays 30] etag Nothing
213210
requireUserContent userFeatureServerEnv (tarServeResponse tarServe)
214211

215-
unpackUtf8 :: BS.ByteString -> String
216-
unpackUtf8 = T.unpack
217-
. T.decodeUtf8With T.lenientDecode
218-
. BS.toStrict
219-
220212
-- TODO: this helper is defined in at least two other places; consolidate
221213
-- | URL describing a package.
222214
packageURL :: PackageIdentifier -> XHtml.URL

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

Lines changed: 2 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ import Distribution.Server.Packages.ChangeLog
1010
import Distribution.Server.Packages.Types
1111
import qualified Distribution.Server.Users.Users as Users
1212
import Distribution.Server.Users.Users (Users)
13+
import Distribution.Server.Util.Parse (unpackUTF8)
1314
import Distribution.Server.Util.ServeTarball (loadTarEntry)
1415
import Distribution.Server.Util.Markdown (renderMarkdown, supposedToBeMarkdown)
1516
import Distribution.Server.Pages.Package () -- for ShortText html instance, for now.
@@ -19,13 +20,9 @@ import Distribution.PackageDescription
1920
import Distribution.Text
2021
import Distribution.Utils.ShortText (fromShortText)
2122

22-
import qualified Data.ByteString.Lazy as BS (ByteString, toStrict)
2323
import Data.List (sortOn)
2424
import Data.Maybe (listToMaybe)
2525
import Data.Ord (Down(..))
26-
import qualified Data.Text as T
27-
import qualified Data.Text.Encoding as T
28-
import qualified Data.Text.Encoding.Error as T
2926
import Data.Time.Clock (UTCTime, getCurrentTime)
3027
import Data.Time.Format
3128
import Network.URI( URI(..), uriToString )
@@ -96,7 +93,7 @@ packageFeedFeature ServerEnv{..}
9693
Right (_, content) ->
9794
if supposedToBeMarkdown filename
9895
then return (pkg, renderMarkdown filename content)
99-
else return (pkg, XHtml.pre << unpackUtf8 content)
96+
else return (pkg, XHtml.pre << unpackUTF8 content)
10097

10198
renderPackageFeed :: Users -> URI -> UTCTime -> PackageName -> [(PkgInfo, XHtml.Html)] -> RSS
10299
renderPackageFeed users hostURI now name pkgs = RSS title uri desc (channel updated) items
@@ -139,9 +136,3 @@ feedItems users hostURI (pkgInfo, chlog) =
139136
uploader = display $ Users.userIdToName users uploaderId
140137
pd = packageDescription (pkgDesc pkgInfo)
141138
d dt dd = XHtml.dterm (XHtml.toHtml dt) +++ XHtml.ddef (XHtml.toHtml dd)
142-
143-
144-
unpackUtf8 :: BS.ByteString -> String
145-
unpackUtf8 = T.unpack
146-
. T.decodeUtf8With T.lenientDecode
147-
. BS.toStrict

0 commit comments

Comments
 (0)