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

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

app/Foliage/CmdBuild.hs

@@ -10,7 +10,7 @@ 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.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 +28,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 +113,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
-
+            let cabalFileTimestamp = fromMaybe currentTime pkgTimestamp in
             -- all revised cabal files, with their timestamp
-            revcf <- for cabalFileRevisions $ uncurry (prepareIndexPkgCabal pkgId)
-
+            prepareIndexPkgCabal pkgId (Timestamped cabalFileTimestamp originalCabalFilePath) (sortOn timestamp cabalFileRevisions)
             -- 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
         )
         packageVersions
 
@@ -138,9 +134,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 +279,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 +337,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 +364,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

@@ -29,7 +29,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 +83,7 @@ makeAllPackagesPage currentTime outputDir packageVersions =
                           allPackagesPageEntryTimestamp = fromMaybe currentTime pkgTimestamp,
                           allPackagesPageEntryTimestampPosix = utcTimeToPOSIXSeconds (fromMaybe currentTime pkgTimestamp),
                           allPackagesPageEntrySource = pkgVersionSource,
-                          allPackagesPageEntryLatestRevisionTimestamp = fst <$> listToMaybe cabalFileRevisions
+                          allPackagesPageEntryLatestRevisionTimestamp = timestamp <$> listToMaybe cabalFileRevisions
                         }
                   )
           )
@@ -130,13 +130,13 @@ makeAllPackageVersionsPage currentTime outputDir packageVersions =
               }
               -- list of revisions
               : [ AllPackageVersionsPageEntryRevision
-                    { allPackageVersionsPageEntryPkgId = pkgId,
-                      allPackageVersionsPageEntryTimestamp = revisionTimestamp,
-                      allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds revisionTimestamp,
-                      allPackageVersionsPageEntryDeprecated = pkgVersionIsDeprecated
-                    }
-                  | (revisionTimestamp, _) <- cabalFileRevisions
-                ]
+                  { allPackageVersionsPageEntryPkgId = pkgId,
+                    allPackageVersionsPageEntryTimestamp = timestamp revision,
+                    allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds $ timestamp revision,
+                    allPackageVersionsPageEntryDeprecated = pkgVersionIsDeprecated
+                  }
+                | revision <- cabalFileRevisions
+              ]
         )
         packageVersions
         -- sort them by timestamp
@@ -150,7 +150,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,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns #-}
@@ -18,6 +19,7 @@ module Foliage.PreparePackageVersion
       ),
     pattern PreparedPackageVersion,
     preparePackageVersion,
+    Timestamped (..),
   )
 where
 
@@ -38,6 +40,10 @@ import Foliage.PrepareSdist (prepareSdist)
 import Foliage.PrepareSource (prepareSource)
 import Foliage.Shake (readGenericPackageDescription', readPackageVersionSpec')
 import System.FilePath (takeBaseName, takeFileName, (<.>), (</>))
+import Foliage.HackageSecurity (Header(headerExpires))
+
+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
@@ -52,7 +58,7 @@ data PreparedPackageVersion = PreparedPackageVersion
     sdistPath :: FilePath,
     cabalFilePath :: FilePath,
     originalCabalFilePath :: FilePath,
-    cabalFileRevisions :: [(UTCTime, FilePath)]
+    cabalFileRevisions :: [Timestamped FilePath]
   }
 
 -- @andreabedini comments:
@@ -93,65 +99,31 @@ 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`!
   let originalCabalFilePath = srcDir </> prettyShow pkgName <.> "cabal"
 
       cabalFileRevisionPath revisionNumber =
@@ -189,8 +161,8 @@ preparePackageVersion inputDir metaFile = do
 
   let cabalFileRevisions =
         sortOn
-          Down
-          [ (revisionTimestamp, cabalFileRevisionPath revisionNumber)
+          (Down . timestamp)
+          [ Timestamped revisionTimestamp (cabalFileRevisionPath revisionNumber)
             | RevisionSpec {revisionTimestamp, revisionNumber} <- packageVersionRevisions pkgSpec
           ]