Make CabalFileText to wrap a strict ByteString, not a lazy one

hackage-server.cabal

@@ -149,7 +149,7 @@ common defaults
     , array                  >= 0.5   && < 0.6
     , base                   >= 4.18  && < 4.22
     , binary                 >= 0.8   && < 0.9
-    , bytestring             >= 0.10  && < 0.13
+    , bytestring             >= 0.11.2 && < 0.13
     , containers             >= 0.6.0 && < 0.9
     , deepseq                >= 1.4   && < 1.6
     , directory              >= 1.3   && < 1.4

src/Distribution/Server/Features/Core.hs

@@ -27,7 +27,7 @@ import qualified Codec.Compression.GZip                             as GZip
 import           Data.Aeson                                         (Value (..), toJSON)
 import qualified Data.Aeson.Key                                     as Key
 import qualified Data.Aeson.KeyMap                                  as KeyMap
-import           Data.ByteString.Lazy                               (ByteString)
+import           Data.ByteString.Lazy                               (LazyByteString, fromStrict)
 import qualified Data.Foldable                                      as Foldable
 import qualified Data.Text                                          as Text
 import           Data.Time.Clock                                    (UTCTime, getCurrentTime)
@@ -130,7 +130,7 @@ data CoreFeature = CoreFeature {
     -- modification time for the tar entry.
     --
     -- This runs a `PackageChangeIndexExtra` hook when done.
-    updateArchiveIndexEntry :: forall m. MonadIO m => FilePath -> ByteString -> UTCTime -> m (),
+    updateArchiveIndexEntry :: forall m. MonadIO m => FilePath -> LazyByteString -> UTCTime -> m (),
 
     -- | Notification of package or index changes.
     packageChangeHook :: Hook PackageChange (),
@@ -175,7 +175,7 @@ data PackageChange
     | PackageChangeInfo PackageUpdate PkgInfo PkgInfo
     -- | A file has changed in the package index tar not covered by any of the
     -- other change types.
-    | PackageChangeIndexExtra String ByteString UTCTime
+    | PackageChangeIndexExtra String LazyByteString UTCTime
 
 -- | A predicate to use with `packageChangeHook` and `registerHookJust` for
 -- keeping other features synchronized with the main package index.
@@ -212,7 +212,7 @@ isPackageDeleteVersion             :: Maybe PackageId,
 isPackageChangeCabalFile           :: Maybe (PackageId, CabalFileText),
 isPackageChangeCabalFileUploadInfo :: Maybe (PackageId, UploadInfo),
 isPackageChangeTarball             :: Maybe (PackageId, PkgTarball),
-isPackageIndexExtraChange          :: Maybe (String, ByteString, UTCTime)
+isPackageIndexExtraChange          :: Maybe (String, LazyByteString, UTCTime)
 -}
 
 data CoreResource = CoreResource {
@@ -591,7 +591,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
           runHook_ packageChangeHook  (PackageChangeInfo PackageUpdatedUploadTime oldpkginfo newpkginfo)
           return True
 
-    updateArchiveIndexEntry :: MonadIO m => FilePath -> ByteString -> UTCTime -> m ()
+    updateArchiveIndexEntry :: MonadIO m => FilePath -> LazyByteString -> UTCTime -> m ()
     updateArchiveIndexEntry entryName entryData entryTime = logTiming maxBound ("updateArchiveIndexEntry " ++ show entryName) $ do
       updateState packagesState $
         AddOtherIndexEntry $ ExtraEntry entryName entryData entryTime
@@ -721,7 +721,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
       -- check that the cabal name matches the package
       guard (lookup "cabal" dpath == Just (display $ packageName pkginfo))
       let (fileRev, (utime, _uid)) = pkgLatestRevision pkginfo
-          cabalfile = Resource.CabalFile (cabalFileByteString fileRev) utime
+          cabalfile = Resource.CabalFile (fromStrict $ cabalFileByteString fileRev) utime
       return $ toResponse cabalfile
 
     serveCabalFileRevisionsList :: DynamicPath -> ServerPartE Response
@@ -731,7 +731,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
       let revisions = pkgMetadataRevisions pkginfo
           revisionToObj rev (cabalFileText, (utime, uid)) =
             let uname = userIdToName users uid
-                hash = sha256 (cabalFileByteString cabalFileText)
+                hash = sha256 (fromStrict $ cabalFileByteString cabalFileText)
             in
             Object $ KeyMap.fromList
               [ (Key.fromString "number", Number (fromIntegral rev))
@@ -750,7 +750,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
       case mrev >>= \rev -> revisions Vec.!? rev of
         Just (fileRev, (utime, _uid)) -> return $ toResponse cabalfile
           where
-            cabalfile = Resource.CabalFile (cabalFileByteString fileRev) utime
+            cabalfile = Resource.CabalFile (fromStrict $ cabalFileByteString fileRev) utime
         Nothing -> errNotFound "Package revision not found"
                      [MText "Cannot parse revision, or revision out of range."]
 

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

@@ -98,7 +98,7 @@ doPackageImport (PartialIndex packages updatelog) entry = case entry of
         list <- importCSV "tarball.csv" bs >>= importTarballMetadata fp
         return $ partial { partialTarballUpload = list }
       [other] | Just version <- extractVersion other (packageName pkgId) ".cabal" ->
-        return $ partial { partialCabal = (version, CabalFileText bs):partialCabal partial }
+        return $ partial { partialCabal = (version, CabalFileText $ BS.toStrict bs) : partialCabal partial }
       _ -> return partial
     return $! PartialIndex (Map.insert pkgId partial' packages) updatelog
   BackupBlob filename@["package",pkgStr,other] blobId -> do
@@ -198,7 +198,7 @@ partialToFullPkg (pkgId, PartialPkg{..}) = do
         filename = display pkgId ++ ".cabal"
 
     case runParseResult $ parseGenericPackageDescription $
-         BS.toStrict $ cabalFileByteString latestCabalFile of
+         cabalFileByteString latestCabalFile of
       (_, Left (_, errs)) -> fail $ unlines (map (showPError filename) $ toList errs)
       (_, Right _)        -> return ()
 
@@ -322,8 +322,8 @@ cabalListToExport pkgId cabalInfos =
     cabalName = display (packageName pkgId) ++ ".cabal"
 
     blobEntry :: (Int, CabalFileText) -> BackupEntry
-    blobEntry (0, CabalFileText bs) = BackupByteString (pkgPath pkgId cabalName) bs
-    blobEntry (n, CabalFileText bs) = BackupByteString (pkgPath pkgId (cabalName ++ "-" ++ show n)) bs
+    blobEntry (0, CabalFileText bs) = BackupByteString (pkgPath pkgId cabalName) (BS.fromStrict bs)
+    blobEntry (n, CabalFileText bs) = BackupByteString (pkgPath pkgId (cabalName ++ "-" ++ show n)) (BS.fromStrict bs)
 
     cabalMetadata :: CSV
     cabalMetadata =

src/Distribution/Server/Features/EditCabalFiles.hs

@@ -23,7 +23,8 @@ import Distribution.Server.Util.CabalRevisions
          (Change(..), diffCabalRevisions, insertRevisionField)
 import Text.StringTemplate.Classes (SElem(SM))
 
-import Data.ByteString.Lazy (ByteString)
+import Data.ByteString (StrictByteString)
+import Data.ByteString.Lazy (LazyByteString)
 import qualified Data.ByteString.Lazy as BS.L
 import qualified Data.Map as Map
 import Data.Time (getCurrentTime)
@@ -84,7 +85,7 @@ editCabalFilesFeature _env templates
         ok $ toResponse $ template
           [ "pkgid"     $= pkgid
           , "cabalfile" $= insertRevisionField (pkgNumRevisions pkg)
-                             (cabalFileByteString (pkgLatestCabalFileText pkg))
+                             (BS.L.fromStrict (cabalFileByteString (pkgLatestCabalFileText pkg)))
           ]
 
     serveEditCabalFilePost :: DynamicPath -> ServerPartE Response
@@ -98,11 +99,11 @@ editCabalFilesFeature _env templates
         uid <- guardAuthorised [ InGroup (maintainersGroup pkgname)
                                , InGroup trusteesGroup ]
         let oldVersion = cabalFileByteString (pkgLatestCabalFileText pkg)
-        newRevision <- getCabalFile
+        newRevision <- BS.L.toStrict <$> getCabalFile
         shouldPublish <- getPublish
         case diffCabalRevisionsByteString oldVersion newRevision of
           Left errs ->
-            responseTemplate template pkgid newRevision
+            responseTemplate template pkgid (BS.L.fromStrict newRevision)
                              shouldPublish [errs] []
 
           Right changes
@@ -117,7 +118,7 @@ editCabalFilesFeature _env templates
                   , "changes"   $= changes
                   ]
             | otherwise ->
-                responseTemplate template pkgid newRevision
+                responseTemplate template pkgid (BS.L.fromStrict newRevision)
                                  shouldPublish [] changes
 
        where
@@ -126,7 +127,7 @@ editCabalFilesFeature _env templates
                                (look "publish" >> return True)
 
          responseTemplate :: ([TemplateAttr] -> Template) -> PackageId
-                          -> ByteString -> Bool -> [String] -> [Change]
+                          -> LazyByteString -> Bool -> [String] -> [Change]
                           -> ServerPartE Response
          responseTemplate template pkgid cabalFile publish errors changes =
            ok $ toResponse $ template
@@ -139,11 +140,11 @@ editCabalFilesFeature _env templates
 
 
 -- | Wrapper around 'diffCabalRevisions' which operates on
--- 'ByteString' decoded with lenient UTF8 and with any leading BOM
+-- 'LazyByteString' decoded with lenient UTF8 and with any leading BOM
 -- stripped.
-diffCabalRevisionsByteString :: ByteString -> ByteString -> Either String [Change]
+diffCabalRevisionsByteString :: StrictByteString -> StrictByteString -> Either String [Change]
 diffCabalRevisionsByteString oldRevision newRevision =
-    maybe (diffCabalRevisions (BS.L.toStrict oldRevision) (BS.L.toStrict newRevision))
+    maybe (diffCabalRevisions oldRevision newRevision)
           Left
           parseSpecVerCheck
   where

src/Distribution/Server/Features/Html.hs

@@ -68,7 +68,7 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Vector as Vec
 import qualified Data.Text as T
-import qualified Data.ByteString.Lazy.Char8 as BS (ByteString)
+import qualified Data.ByteString.Lazy as BS (LazyByteString, fromStrict)
 import qualified Network.URI as URI
 
 import Text.XHtml.Strict
@@ -812,9 +812,9 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
             start []          = []
             start (curr:rest) = go curr rest
 
-            go curr [] = [(sha256 (cabalFileByteString (fst curr)), [])]
+            go curr [] = [(sha256 (BS.fromStrict (cabalFileByteString (fst curr))), [])]
             go curr (prev:rest) =
-                ( sha256 (cabalFileByteString (fst curr))
+                ( sha256 (BS.fromStrict (cabalFileByteString (fst curr)))
                 , changes curr prev )
                 : go prev rest
 
@@ -849,7 +849,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
 
 
 -- | Common helper used by 'serveCandidatePage' and 'servePackagePage'
-makeReadme :: MonadIO m => PackageRender -> m (Maybe BS.ByteString)
+makeReadme :: MonadIO m => PackageRender -> m (Maybe BS.LazyByteString)
 makeReadme render = case rendReadme render of
   Just (tarfile, _, offset, _) ->
         either (\_err -> return Nothing) (return . Just . snd) =<<

src/Distribution/Server/Features/Mirror.hs

@@ -243,12 +243,12 @@ mirrorFeature ServerEnv{serverBlobStore = store}
     cabalPut dpath = do
         uid <- guardMirrorGroup
         pkgid :: PackageId <- packageInPath dpath
-        fileContent <- expectTextPlain
+        fileContent <- BS.L.toStrict <$> expectTextPlain
         time <- liftIO getCurrentTime
         let uploadData = (time, uid)
             filename = display pkgid <.> "cabal"
 
-        case runParseResult $ parseGenericPackageDescription $ BS.L.toStrict fileContent of
+        case runParseResult $ parseGenericPackageDescription fileContent of
             (_, Left (_, err NE.:| _)) -> badRequest (toResponse $ showPError filename err)
             (_, Right pkg) | pkgid /= packageId pkg ->
                 errBadRequest "Wrong package Id"

src/Distribution/Server/Features/PackageCandidates.hs

@@ -32,6 +32,7 @@ import Distribution.Server.Packages.PackageIndex (PackageIndex)
 import qualified Distribution.Server.Framework.ResponseContentTypes as Resource
 import Distribution.Server.Features.Security.Migration
 
+import Distribution.Server.Util.Parse (unpackUTF8)
 import Distribution.Server.Util.ServeTarball
 import Distribution.Server.Util.Markdown (renderMarkdown, supposedToBeMarkdown)
 import Distribution.Server.Pages.Template (hackagePage)
@@ -40,10 +41,8 @@ import Distribution.Text
 import Distribution.Package
 import Distribution.Version
 
+import qualified Data.ByteString.Lazy     as BS (toStrict, fromStrict)
 import qualified Data.Text                as T
-import qualified Data.Text.Encoding       as T
-import qualified Data.Text.Encoding.Error as T
-import qualified Data.ByteString.Lazy     as BS (ByteString, toStrict)
 import qualified Text.XHtml.Strict        as XHtml
 import           Text.XHtml.Strict        ((<<), (!))
 import           Data.Aeson               (Value (..), object, toJSON, (.=))
@@ -383,7 +382,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
       pkg <- packageInPath dpath >>= lookupCandidateId
       guard (lookup "cabal" dpath == Just (display $ packageName pkg))
       let (fileRev, (utime, _uid)) = pkgLatestRevision (candPkgInfo pkg)
-          cabalfile = Resource.CabalFile (cabalFileByteString fileRev) utime
+          cabalfile = Resource.CabalFile (BS.fromStrict (cabalFileByteString fileRev)) utime
       return $ toResponse cabalfile
 
     uploadCandidate :: (PackageId -> Bool) -> ServerPartE CandPkgInfo
@@ -396,7 +395,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
         now <- liftIO getCurrentTime
         let (UploadResult pkg pkgStr _) = uresult
             pkgid      = packageId pkg
-            cabalfile  = CabalFileText pkgStr
+            cabalfile  = CabalFileText $ BS.toStrict pkgStr
             uploadinfo = (now, uid)
             candidate = CandPkgInfo {
                 candPkgInfo = PkgInfo {
@@ -453,7 +452,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
           -- run filters
           let pkgInfo = candPkgInfo candidate
               uresult = UploadResult (pkgDesc pkgInfo)
-                                     (cabalFileByteString (pkgLatestCabalFileText pkgInfo))
+                                     (BS.fromStrict (cabalFileByteString (pkgLatestCabalFileText pkgInfo)))
                                      (candWarnings candidate)
           time <- liftIO getCurrentTime
           let uploadInfo = (time, uid)
@@ -596,7 +595,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
                             << if supposedToBeMarkdown filename
                                  then renderMarkdown filename contents
                                  else XHtml.thediv ! [XHtml.theclass "preformatted"]
-                                                  << unpackUtf8 contents
+                                                  << unpackUTF8 contents
               ]
 
 
@@ -614,8 +613,3 @@ candidatesFeature ServerEnv{serverBlobStore = store}
                          ["index.html"] (display (packageId pkg)) fp index
                          [Public, maxAgeMinutes 5] etag Nothing
           requireUserContent userFeatureServerEnv (tarServeResponse tarServe)
-
-unpackUtf8 :: BS.ByteString -> String
-unpackUtf8 = T.unpack
-           . T.decodeUtf8With T.lenientDecode
-           . BS.toStrict

src/Distribution/Server/Features/PackageContents.hs

@@ -18,16 +18,13 @@ import Distribution.Server.Packages.Render
 import Distribution.Server.Features.Users
 import Distribution.Server.Util.ServeTarball
 import Distribution.Server.Util.Markdown (renderMarkdown, supposedToBeMarkdown)
+import Distribution.Server.Util.Parse (unpackUTF8)
 import Distribution.Server.Pages.Template (hackagePage)
 
 import Distribution.Text
 import Distribution.Package
 import Distribution.PackageDescription
 
-import qualified Data.Text                as T
-import qualified Data.Text.Encoding       as T
-import qualified Data.Text.Encoding.Error as T
-import qualified Data.ByteString.Lazy as BS (ByteString, toStrict)
 import qualified Text.XHtml.Strict as XHtml
 import qualified Distribution.Utils.ShortText as ST
 import           Text.XHtml.Strict ((<<), (!))
@@ -160,7 +157,7 @@ packageContentsFeature CoreFeature{ coreResource = CoreResource{
                                << if supposedToBeMarkdown filename
                                     then renderMarkdown filename contents
                                     else XHtml.thediv ! [XHtml.theclass "preformatted"]
-                                                     << unpackUtf8 contents
+                                                     << unpackUTF8 contents
                  ]
 
     serveReadmeText :: DynamicPath -> ServerPartE Response
@@ -194,7 +191,7 @@ packageContentsFeature CoreFeature{ coreResource = CoreResource{
                             << if supposedToBeMarkdown filename
                                  then renderMarkdown filename contents
                                  else XHtml.thediv ! [XHtml.theclass "preformatted"]
-                                                  << unpackUtf8 contents
+                                                  << unpackUTF8 contents
               ]
 
     -- return: not-found error or tarball
@@ -212,11 +209,6 @@ packageContentsFeature CoreFeature{ coreResource = CoreResource{
                          [Public, maxAgeDays 30] etag Nothing
           requireUserContent userFeatureServerEnv (tarServeResponse tarServe)
 
-unpackUtf8 :: BS.ByteString -> String
-unpackUtf8 = T.unpack
-           . T.decodeUtf8With T.lenientDecode
-           . BS.toStrict
-
 -- TODO: this helper is defined in at least two other places; consolidate
 -- | URL describing a package.
 packageURL :: PackageIdentifier -> XHtml.URL

src/Distribution/Server/Features/PackageFeed.hs

@@ -10,6 +10,7 @@ import Distribution.Server.Packages.ChangeLog
 import Distribution.Server.Packages.Types
 import qualified Distribution.Server.Users.Users as Users
 import Distribution.Server.Users.Users (Users)
+import Distribution.Server.Util.Parse (unpackUTF8)
 import Distribution.Server.Util.ServeTarball (loadTarEntry)
 import Distribution.Server.Util.Markdown (renderMarkdown, supposedToBeMarkdown)
 import Distribution.Server.Pages.Package () -- for ShortText html instance, for now.
@@ -19,13 +20,9 @@ import Distribution.PackageDescription
 import Distribution.Text
 import Distribution.Utils.ShortText (fromShortText)
 
-import qualified Data.ByteString.Lazy as BS (ByteString, toStrict)
 import Data.List (sortOn)
 import Data.Maybe (listToMaybe)
 import Data.Ord (Down(..))
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import qualified Data.Text.Encoding.Error as T
 import Data.Time.Clock (UTCTime, getCurrentTime)
 import Data.Time.Format
 import Network.URI( URI(..), uriToString )
@@ -96,7 +93,7 @@ packageFeedFeature ServerEnv{..}
             Right (_, content) ->
               if supposedToBeMarkdown filename
                 then return (pkg, renderMarkdown filename content)
-                else return (pkg, XHtml.pre << unpackUtf8 content)
+                else return (pkg, XHtml.pre << unpackUTF8 content)
 
 renderPackageFeed :: Users -> URI -> UTCTime -> PackageName -> [(PkgInfo, XHtml.Html)] -> RSS
 renderPackageFeed users hostURI now name pkgs = RSS title uri desc (channel updated) items
@@ -139,9 +136,3 @@ feedItems users hostURI (pkgInfo, chlog) =
         uploader = display $ Users.userIdToName users uploaderId
         pd = packageDescription (pkgDesc pkgInfo)
         d dt dd = XHtml.dterm (XHtml.toHtml dt) +++ XHtml.ddef (XHtml.toHtml dd)
-
-
-unpackUtf8 :: BS.ByteString -> String
-unpackUtf8 = T.unpack
-           . T.decodeUtf8With T.lenientDecode
-           . BS.toStrict