Fix #42: use patches for revisions

Co-authored-by: Michael Peyton Jones <me@michaelpj.com>
input-output-hk · May 5, 2023 · 9ecb7da · 9ecb7da
1 parent acc0f88
commit 9ecb7da
Show file tree

Hide file tree

Showing 3 changed files with 68 additions and 46 deletions.
diff --git a/app/Foliage/CmdBuild.hs b/app/Foliage/CmdBuild.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Foliage.CmdBuild (cmdBuild) where
@@ -8,7 +9,6 @@ import Codec.Archive.Tar.Entry qualified as Tar
 import Codec.Compression.GZip qualified as GZip
 import Control.Monad (unless, void, when)
 import Data.Aeson qualified as Aeson
-import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as BL
 import Data.List (sortOn)
 import Data.Maybe (fromMaybe)
@@ -23,7 +23,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)
@@ -101,21 +101,16 @@ buildAction
 
     void $ forP packageVersions $ makePackageVersionPage outputDir
 
-    void $ forP packageVersions $ \PreparedPackageVersion {pkgId, cabalFilePath} -> do
-      let PackageIdentifier {pkgName, pkgVersion} = pkgId
-      copyFileChanged cabalFilePath (outputDir </> "index" </> prettyShow pkgName </> prettyShow pkgVersion </> prettyShow pkgName <.> "cabal")
+    void $
+      forP packageVersions $ \PreparedPackageVersion {pkgId, cabalFilePath} -> do
+        let PackageIdentifier {pkgName, pkgVersion} = pkgId
+        copyFileChanged cabalFilePath (outputDir </> "index" </> prettyShow pkgName </> prettyShow pkgVersion </> prettyShow pkgName <.> "cabal")
 
     cabalEntries <-
       foldMap
         ( \PreparedPackageVersion {pkgId, pkgTimestamp, originalCabalFilePath, cabalFileRevisions} -> do
-            -- 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)
-
-            return $ cf : revcf
+            prepareIndexPkgCabal pkgId (Timestamped cabalFileTimestamp originalCabalFilePath) (sortOn timestamp cabalFileRevisions)
         )
         packageVersions
 
@@ -129,9 +124,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 tarContents = Tar.write $ sortOn Tar.entryTime (cabalEntries ++ metadataEntries)
     traced "Writing index" $ do
@@ -272,11 +266,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
@@ -290,8 +302,8 @@ prepareIndexPkgMetadata expiryTime PreparedPackageVersion {pkgId, sdistPath} = d
         targetsDelegations = Nothing
       }
 
-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 =

diff --git a/app/Foliage/Pages.hs b/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
                         }
                   )
           )
@@ -123,15 +123,15 @@ makeAllPackageVersionsPage currentTime outputDir packageVersions =
                 allPackageVersionsPageEntryTimestamp = fromMaybe currentTime pkgTimestamp,
                 allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds (fromMaybe currentTime pkgTimestamp),
                 allPackageVersionsPageEntrySource = pkgVersionSource
-              }
-              -- list of revisions
-              : [ AllPackageVersionsPageEntryRevision
-                    { allPackageVersionsPageEntryPkgId = pkgId,
-                      allPackageVersionsPageEntryTimestamp = revisionTimestamp,
-                      allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds revisionTimestamp
-                    }
-                  | (revisionTimestamp, _) <- cabalFileRevisions
-                ]
+              } -- list of revisions
+            :
+              [ AllPackageVersionsPageEntryRevision
+                  { allPackageVersionsPageEntryPkgId = pkgId,
+                    allPackageVersionsPageEntryTimestamp = timestamp revision,
+                    allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds $ timestamp revision
+                  }
+                | revision <- cabalFileRevisions
+              ]
         )
         packageVersions
         -- sort them by timestamp
@@ -145,7 +145,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
           ]

diff --git a/app/Foliage/PreparePackageVersion.hs b/app/Foliage/PreparePackageVersion.hs
@@ -15,6 +15,7 @@ module Foliage.PreparePackageVersion
       ),
     pattern PreparedPackageVersion,
     preparePackageVersion,
+    Timestamped (..),
   )
 where
 
@@ -33,6 +34,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)
 
 data PreparedPackageVersion = PreparedPackageVersion
   { pkgId :: PackageId,
@@ -43,7 +48,7 @@ data PreparedPackageVersion = PreparedPackageVersion
     sdistPath :: FilePath,
     cabalFilePath :: FilePath,
     originalCabalFilePath :: FilePath,
-    cabalFileRevisions :: [(UTCTime, FilePath)]
+    cabalFileRevisions :: [Timestamped FilePath]
   }
 
 preparePackageVersion :: FilePath -> FilePath -> Action PreparedPackageVersion
@@ -60,23 +65,28 @@ preparePackageVersion inputDir metaFile = do
     readPackageVersionSpec' (inputDir </> metaFile) >>= \case
       PackageVersionSpec {packageVersionRevisions, packageVersionTimestamp = Nothing}
         | not (null packageVersionRevisions) -> do
-            error $
-              unlines
-                [ 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"
-                ]
+          error $
+            unlines
+              [ 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"
+              ]
       PackageVersionSpec {packageVersionRevisions, packageVersionTimestamp = Just pkgTs}
         | any ((< pkgTs) . revisionTimestamp) packageVersionRevisions -> do
-            error $
-              unlines
-                [ inputDir </> metaFile <> " has a revision with timestamp earlier than the package itself.",
-                  "Adjust the timestamps so that all revisions come after the original package"
-                ]
+          error $
+            unlines
+              [ inputDir </> metaFile <> " has a revision with timestamp earlier than the package itself.",
+                "Adjust the timestamps so that all revisions come after the original package"
+              ]
       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 =
         joinPath
@@ -113,8 +123,8 @@ preparePackageVersion inputDir metaFile = do
 
   let cabalFileRevisions =
         sortOn
-          (Down . fst)
-          [ (revisionTimestamp, cabalFileRevisionPath revisionNumber)
+          (Down . timestamp)
+          [ Timestamped revisionTimestamp (cabalFileRevisionPath revisionNumber)
             | RevisionSpec {revisionTimestamp, revisionNumber} <- packageVersionRevisions pkgSpec
           ]