Fix input-output-hk#42: use patches for revisions

Co-authored-by: Michael Peyton Jones <[email protected]>

app/Foliage/CmdBuild.hs

@@ -10,7 +10,6 @@ import Codec.Compression.GZip qualified as GZip
 import Control.Monad (unless, void, when)
 import Data.Aeson qualified as Aeson
 import Data.Bifunctor (second)
-import Data.ByteString.Char8 qualified as BS
 import Data.ByteString.Lazy.Char8 qualified as BL
 import Data.List (sortOn)
 import Data.List.NonEmpty qualified as NE
@@ -28,7 +27,7 @@ import Foliage.Meta
 import Foliage.Meta.Aeson ()
 import Foliage.Options
 import Foliage.Pages
-import Foliage.PreparePackageVersion (PreparedPackageVersion (..), preparePackageVersion)
+import Foliage.PreparePackageVersion (PreparedPackageVersion (..), Timestamped (..), preparePackageVersion)
 import Foliage.PrepareSdist (addPrepareSdistRule)
 import Foliage.PrepareSource (addPrepareSourceRule)
 import Foliage.RemoteAsset (addFetchRemoteAssetRule)
@@ -113,18 +112,14 @@ buildAction
 
     cabalEntries <-
       foldMap
-        ( \PreparedPackageVersion {pkgId, pkgTimestamp, originalCabalFilePath, cabalFileRevisions} -> do
+        ( \PreparedPackageVersion {pkgId, pkgTimestamp, originalCabalFilePath, cabalFileRevisions} ->
             -- original cabal file, with its timestamp (if specified)
             let cabalFileTimestamp = fromMaybe currentTime pkgTimestamp
-            cf <- prepareIndexPkgCabal pkgId cabalFileTimestamp originalCabalFilePath
-
-            -- all revised cabal files, with their timestamp
-            revcf <- for cabalFileRevisions $ uncurry (prepareIndexPkgCabal pkgId)
-
             -- WARN: So far Foliage allows publishing a package and a cabal file revision with the same timestamp
             -- This accidentally works because 1) the following inserts the original cabal file before the revisions
             -- AND 2) Data.List.sortOn is stable. The revised cabal file will always be after the original one.
-            return $ cf : revcf
+             in -- all revised cabal files, with their timestamp
+                prepareIndexPkgCabal pkgId (Timestamped cabalFileTimestamp originalCabalFilePath) (sortOn timestamp cabalFileRevisions)
         )
         packageVersions
 
@@ -138,9 +133,8 @@ buildAction
         liftIO $ BL.writeFile path $ renderSignedJSON targetKeys targets
         pure $
           mkTarEntry
-            (renderSignedJSON targetKeys targets)
+            (Timestamped (fromMaybe currentTime pkgTimestamp) (renderSignedJSON targetKeys targets))
             (IndexPkgMetadata pkgId)
-            (fromMaybe currentTime pkgTimestamp)
 
     let extraEntries = getExtraEntries packageVersions
 
@@ -284,11 +278,29 @@ getPackageVersions inputDir = do
 
   forP metaFiles $ preparePackageVersion inputDir
 
-prepareIndexPkgCabal :: PackageId -> UTCTime -> FilePath -> Action Tar.Entry
-prepareIndexPkgCabal pkgId timestamp filePath = do
-  need [filePath]
-  contents <- liftIO $ BS.readFile filePath
-  pure $ mkTarEntry (BL.fromStrict contents) (IndexPkgCabal pkgId) timestamp
+prepareIndexPkgCabal :: PackageId -> Timestamped FilePath -> [Timestamped FilePath] -> Action [Tar.Entry]
+prepareIndexPkgCabal pkgId (Timestamped timestamp originalFilePath) revisions = do
+  need (originalFilePath : map timestampedValue revisions)
+  original <- liftIO (BL.readFile originalFilePath)
+  revisionsApplied <- applyRevisionsInOrder [Timestamped timestamp original] revisions
+  pure $ map (\content -> mkTarEntry content (IndexPkgCabal pkgId)) revisionsApplied
+
+applyRevisionsInOrder :: [Timestamped BL.ByteString] -> [Timestamped FilePath] -> Action [Timestamped BL.ByteString]
+applyRevisionsInOrder acc [] = pure (reverse acc)
+applyRevisionsInOrder acc (patch : remainingPatches) = do
+  newContent <- applyRevision (timestampedValue $ last acc) patch
+  applyRevisionsInOrder (newContent : acc) remainingPatches
+
+applyRevision :: BL.ByteString -> Timestamped FilePath -> Action (Timestamped BL.ByteString)
+applyRevision lastRevisionContents (Timestamped timestamp revisionPath) = do
+  content <-
+    if takeExtension revisionPath `elem` [".diff", ".patch"]
+      then do
+        liftIO $ putStrLn $ "Applying patch " ++ revisionPath
+        cmd_ (StdinBS lastRevisionContents) ["patch", "-i", revisionPath]
+        liftIO $ BL.readFile revisionPath
+      else pure lastRevisionContents
+  return $ Timestamped timestamp content
 
 prepareIndexPkgMetadata :: Maybe UTCTime -> PreparedPackageVersion -> Action Targets
 prepareIndexPkgMetadata expiryTime PreparedPackageVersion {pkgId, sdistPath} = do
@@ -324,7 +336,7 @@ getExtraEntries packageVersions =
           effectiveRanges :: [(UTCTime, VersionRange)]
           effectiveRanges = NE.tail $ NE.scanl applyChangeToRange (posixSecondsToUTCTime 0, anyVersion) deprecationChanges
           -- Create a `Tar.Entry` for the package group, its computed `VersionRange` and a timestamp.
-          createTarEntry (ts, effectiveRange) = mkTarEntry (BL.pack $ prettyShow effectiveRange) (IndexPkgPrefs pn) ts
+          createTarEntry (ts, effectiveRange) = mkTarEntry (Timestamped ts (BL.pack $ prettyShow effectiveRange)) (IndexPkgPrefs pn)
    in foldMap generateEntriesForGroup groupedPackageVersions
 
 -- TODO: the functions belows should be moved to Foliage.PreparedPackageVersion
@@ -351,8 +363,8 @@ applyDeprecation pkgVersion deprecated =
     then intersectVersionRanges (notThisVersion pkgVersion)
     else unionVersionRanges (thisVersion pkgVersion)
 
-mkTarEntry :: BL.ByteString -> IndexFile dec -> UTCTime -> Tar.Entry
-mkTarEntry contents indexFile timestamp =
+mkTarEntry :: Timestamped BL.ByteString -> IndexFile dec -> Tar.Entry
+mkTarEntry (Timestamped timestamp contents) indexFile =
   (Tar.fileEntry tarPath contents)
     { Tar.entryTime = floor $ Time.utcTimeToPOSIXSeconds timestamp,
       Tar.entryOwnership =

app/Foliage/Pages.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 
@@ -29,7 +30,7 @@ import Distribution.Package (PackageIdentifier (pkgName, pkgVersion))
 import Distribution.Pretty (prettyShow)
 import Foliage.Meta (PackageVersionSource)
 import Foliage.Meta.Aeson ()
-import Foliage.PreparePackageVersion (PreparedPackageVersion (..))
+import Foliage.PreparePackageVersion (PreparedPackageVersion (..), Timestamped (..))
 import Foliage.Utils.Aeson (MyAesonEncoding (..))
 import GHC.Generics (Generic)
 import System.Directory qualified as IO
@@ -83,7 +84,7 @@ makeAllPackagesPage currentTime outputDir packageVersions =
                           allPackagesPageEntryTimestamp = fromMaybe currentTime pkgTimestamp,
                           allPackagesPageEntryTimestampPosix = utcTimeToPOSIXSeconds (fromMaybe currentTime pkgTimestamp),
                           allPackagesPageEntrySource = pkgVersionSource,
-                          allPackagesPageEntryLatestRevisionTimestamp = fst <$> listToMaybe cabalFileRevisions
+                          allPackagesPageEntryLatestRevisionTimestamp = timestamp <$> listToMaybe cabalFileRevisions
                         }
                   )
           )
@@ -127,16 +128,16 @@ makeAllPackageVersionsPage currentTime outputDir packageVersions =
                 allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds (fromMaybe currentTime pkgTimestamp),
                 allPackageVersionsPageEntrySource = pkgVersionSource,
                 allPackageVersionsPageEntryDeprecated = pkgVersionIsDeprecated
-              }
-              -- list of revisions
-              : [ AllPackageVersionsPageEntryRevision
-                    { allPackageVersionsPageEntryPkgId = pkgId,
-                      allPackageVersionsPageEntryTimestamp = revisionTimestamp,
-                      allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds revisionTimestamp,
-                      allPackageVersionsPageEntryDeprecated = pkgVersionIsDeprecated
-                    }
-                  | (revisionTimestamp, _) <- cabalFileRevisions
-                ]
+              } -- list of revisions
+            :
+              [ AllPackageVersionsPageEntryRevision
+                  { allPackageVersionsPageEntryPkgId = pkgId,
+                    allPackageVersionsPageEntryTimestamp = timestamp revision,
+                    allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds $ timestamp revision,
+                    allPackageVersionsPageEntryDeprecated = pkgVersionIsDeprecated
+                  }
+                | revision <- cabalFileRevisions
+              ]
         )
         packageVersions
         -- sort them by timestamp
@@ -150,7 +151,7 @@ makePackageVersionPage outputDir PreparedPackageVersion {pkgId, pkgTimestamp, pk
       renderMustache packageVersionPageTemplate $
         object
           [ "pkgVersionSource" .= pkgVersionSource,
-            "cabalFileRevisions" .= map fst cabalFileRevisions,
+            "cabalFileRevisions" .= map timestamp cabalFileRevisions,
             "pkgDesc" .= jsonGenericPackageDescription pkgDesc,
             "pkgTimestamp" .= pkgTimestamp,
             "pkgVersionDeprecated" .= pkgVersionIsDeprecated

app/Foliage/PreparePackageVersion.hs

@@ -1,6 +1,6 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ViewPatterns #-}
 
 module Foliage.PreparePackageVersion
   ( PreparedPackageVersion
@@ -18,6 +18,7 @@ module Foliage.PreparePackageVersion
       ),
     pattern PreparedPackageVersion,
     preparePackageVersion,
+    Timestamped (..),
   )
 where
 
@@ -39,6 +40,9 @@ import Foliage.PrepareSource (prepareSource)
 import Foliage.Shake (readGenericPackageDescription', readPackageVersionSpec')
 import System.FilePath (takeBaseName, takeFileName, (<.>), (</>))
 
+data Timestamped a = Timestamped {timestamp :: UTCTime, timestampedValue :: a}
+  deriving (Eq, Ord, Show)
+
 -- TODO: can we ensure that `pkgVersionDeprecationChanges` and `cabalFileRevisions` are
 -- sorted by timestamp? e.g https://hackage.haskell.org/package/sorted-list
 data PreparedPackageVersion = PreparedPackageVersion
@@ -52,7 +56,7 @@ data PreparedPackageVersion = PreparedPackageVersion
     sdistPath :: FilePath,
     cabalFilePath :: FilePath,
     originalCabalFilePath :: FilePath,
-    cabalFileRevisions :: [(UTCTime, FilePath)]
+    cabalFileRevisions :: [Timestamped FilePath]
   }
 
 -- @andreabedini comments:
@@ -93,65 +97,42 @@ preparePackageVersion inputDir metaFile = do
   let pkgId = PackageIdentifier pkgName pkgVersion
 
   pkgSpec <-
-    readPackageVersionSpec' (inputDir </> metaFile) >>= \meta@PackageVersionSpec {..} -> do
-      case (NE.nonEmpty packageVersionRevisions, packageVersionTimestamp) of
-        (Just _someRevisions, Nothing) ->
+    readPackageVersionSpec' (inputDir </> metaFile) >>= \case
+      PackageVersionSpec {packageVersionRevisions, packageVersionTimestamp = Nothing}
+        | not (null packageVersionRevisions) -> do
           error $
             unlines
-              [ inputDir </> metaFile <> " has cabal file revisions but the package has no timestamp.",
-                "This combination doesn't make sense. Either add a timestamp on the original package or remove the revisions."
+              [ inputDir </> metaFile <> " has cabal file revisions but the original package has no timestamp.",
+                "This combination doesn't make sense. Either add a timestamp on the original package or remove the revisions"
               ]
-        (Just (NE.sort -> someRevisions), Just ts)
-          -- WARN: this should really be a <=
-          | revisionTimestamp (NE.head someRevisions) < ts ->
-              error $
-                unlines
-                  [ inputDir </> metaFile <> " has a revision with timestamp earlier than the package itself.",
-                    "Adjust the timestamps so that all revisions come after the package publication."
-                  ]
-          | not (null $ duplicates (revisionTimestamp <$> someRevisions)) ->
-              error $
-                unlines
-                  [ inputDir </> metaFile <> " has two revisions entries with the same timestamp.",
-                    "Adjust the timestamps so that all the revisions happen at a different time."
-                  ]
-        _otherwise -> return ()
-
-      case (NE.nonEmpty packageVersionDeprecations, packageVersionTimestamp) of
-        (Just _someDeprecations, Nothing) ->
+      PackageVersionSpec {packageVersionRevisions, packageVersionTimestamp = Just pkgTs}
+        | any ((< pkgTs) . revisionTimestamp) packageVersionRevisions -> do
           error $
             unlines
-              [ inputDir </> metaFile <> " has deprecations but the package has no timestamp.",
-                "This combination doesn't make sense. Either add a timestamp on the original package or remove the deprecation."
+              [ inputDir </> metaFile <> " has a revision with timestamp earlier than the package itself.",
+                "Adjust the timestamps so that all revisions come after the original package"
               ]
-        (Just (NE.sort -> someDeprecations), Just ts)
-          | deprecationTimestamp (NE.head someDeprecations) <= ts ->
-              error $
-                unlines
-                  [ inputDir </> metaFile <> " has a deprecation entry with timestamp earlier (or equal) than the package itself.",
-                    "Adjust the timestamps so that all the (un-)deprecations come after the package publication."
-                  ]
-          | not (deprecationIsDeprecated (NE.head someDeprecations)) ->
-              error $
-                "The first deprecation entry in" <> inputDir </> metaFile <> " cannot be an un-deprecation"
-          | not (null $ duplicates (deprecationTimestamp <$> someDeprecations)) ->
-              error $
-                unlines
-                  [ inputDir </> metaFile <> " has two deprecation entries with the same timestamp.",
-                    "Adjust the timestamps so that all the (un-)deprecations happen at a different time."
-                  ]
-          | not (null $ doubleDeprecations someDeprecations) ->
-              error $
-                unlines
-                  [ inputDir </> metaFile <> " contains two consecutive deprecations or two consecutive un-deprecations.",
-                    "Make sure deprecations and un-deprecations alternate in time."
-                  ]
-        _otherwise -> return ()
-
-      return meta
+      meta ->
+        return meta
 
   srcDir <- prepareSource pkgId pkgSpec
 
+  -- FIXME: This produce a Shake error since it `need` the file:
+  --
+  --     revisionNumber <.> "cabal"
+  --
+  -- ... which could now be a `.diff` or a `.patch`!
+  --
+  -- @andreabedini commented:
+  --
+  -- > I don't think that cabalFileRevisions :: [Timestamped FilePath] can work
+  -- > anymore since there's no filepath for a computed revision (unless we put
+  -- > it in _cache but I would avoid that).
+  -- >
+  -- > @yvan-sraka I think the correct solution is to turn cabalFileRevisions
+  -- > into [Timestamped ByteString] and compute the revisions as part of
+  -- > preparePackageVersion (it's becoming a bit of a kitchen sink but shrug).
+
   let originalCabalFilePath = srcDir </> prettyShow pkgName <.> "cabal"
 
       cabalFileRevisionPath revisionNumber =
@@ -189,8 +170,8 @@ preparePackageVersion inputDir metaFile = do
 
   let cabalFileRevisions =
         sortOn
-          Down
-          [ (revisionTimestamp, cabalFileRevisionPath revisionNumber)
+          (Down . timestamp)
+          [ Timestamped revisionTimestamp (cabalFileRevisionPath revisionNumber)
             | RevisionSpec {revisionTimestamp, revisionNumber} <- packageVersionRevisions pkgSpec
           ]