Implement force version

Doesn't quite work because srcDir is unique by url, so if you have the
same url with different versions, things will collide. This is a bug
that might affect patching too.

Author: andreabedini

app/Foliage/CmdBuild.hs

@@ -69,8 +69,8 @@ cmdBuild
       getSourceMeta <- addOracle $ \(GetSourceMeta PackageId {pkgName, pkgVersion}) ->
         readSourceMeta' $ inputDir </> pkgName </> pkgVersion </> "meta.toml"
 
-      getSourceDir <- addOracle $ \(GetSourceDir pkgId@PackageId {pkgName, pkgVersion}) -> do
-        SourceMeta {sourceUrl, sourceSubdir} <- getSourceMeta (GetSourceMeta pkgId)
+      getSourceDir <- addOracle $ \(GetSourceDir pkgId) -> do
+        SourceMeta {sourceUrl, sourceSubdir, sourceForceVersion} <- getSourceMeta (GetSourceMeta pkgId)
         let urlDir = "_cache" </> urlToFileName sourceUrl
 
         need [urlDir </> ".downloaded"]
@@ -86,15 +86,10 @@ cmdBuild
               Just s -> urlDir </> s
               Nothing -> urlDir
 
-        let patchesDir = inputDir </> pkgName </> pkgVersion </> "patches"
-        hasPatches <- doesDirectoryExist patchesDir
+        when sourceForceVersion $
+          forcePackageVersion srcDir pkgId
 
-        when hasPatches $ do
-          patches <- getDirectoryFiles (inputDir </> pkgName </> pkgVersion </> "patches") ["*.patch"]
-          for_ patches $ \patch -> do
-            let patchfile = inputDir </> pkgName </> pkgVersion </> "patches" </> patch
-            putInfo $ "Applying patch: " <> patch
-            cmd_ Shell (Cwd srcDir) (FileStdin patchfile) "patch --backup -p1"
+        applyPatches inputDir srcDir pkgId
 
         return srcDir
 
@@ -421,3 +416,33 @@ mkTarEntry filePath indexPath timestamp = do
               Tar.groupId = 0
             }
       }
+
+applyPatches :: FilePath -> FilePath -> PackageId -> Action ()
+applyPatches inputDir srcDir PackageId {pkgName, pkgVersion} = do
+  let patchesDir = inputDir </> pkgName </> pkgVersion </> "patches"
+  hasPatches <- doesDirectoryExist patchesDir
+
+  when hasPatches $ do
+    patches <- getDirectoryFiles (inputDir </> pkgName </> pkgVersion </> "patches") ["*.patch"]
+    for_ patches $ \patch -> do
+      let patchfile = inputDir </> pkgName </> pkgVersion </> "patches" </> patch
+      putInfo $ "Applying patch: " <> patch
+      cmd_ Shell (Cwd srcDir) (FileStdin patchfile) "patch --backup -p1"
+
+forcePackageVersion :: FilePath -> PackageId -> Action ()
+forcePackageVersion srcDir PackageId {pkgName, pkgVersion} = do
+  let cabalFilePath = srcDir </> pkgName <.> "cabal"
+  cabalFile <- readFile' cabalFilePath
+  writeFile' cabalFilePath (replaceVersion pkgVersion cabalFile)
+
+replaceVersion :: String -> String -> String
+replaceVersion version = unlines . map f . lines
+  where
+    f line
+      | "version" `isPrefixOf` line =
+        unlines
+          [ "-- version field replaced by foliage",
+            "--" <> line,
+            "version:\t" ++ version
+          ]
+    f line = line

app/Foliage/CmdImportHackage.hs

@@ -59,7 +59,8 @@ importIndex f (Tar.Next e es) m =
                           { sourceUrl = pkgIdToHackageUrl pkgId,
                             sourceTimestamp = Just time,
                             sourceSubdir = Nothing,
-                            sourceRevisions = []
+                            sourceRevisions = [],
+                            sourceForceVersion = False
                           }
                   -- Existing package, new revision
                   Just sm -> do

app/Foliage/Meta.hs

@@ -11,6 +11,7 @@ module Foliage.Meta
     sourceUrl,
     sourceSubdir,
     sourceRevisions,
+    sourceForceVersion,
     readSourceMeta,
     writeSourceMeta,
     RevisionMeta,
@@ -24,6 +25,7 @@ where
 
 import Control.Monad (void)
 import Data.Coerce (coerce)
+import Data.Maybe (fromMaybe)
 import Data.Time.Format.ISO8601
 import Data.Time.LocalTime (utc, utcToZonedTime, zonedTimeToUTC)
 import Development.Shake.Classes
@@ -32,15 +34,26 @@ import GHC.Generics
 import Toml (TomlCodec, (.=))
 import Toml qualified
 
-data SourceMeta = SourceMeta' (Maybe WrapUTCTime) String (Maybe String) [RevisionMeta]
+data SourceMeta
+  = SourceMeta'
+      (Maybe WrapUTCTime)
+      -- ^ timestamp
+      String
+      -- ^ url
+      (Maybe String)
+      -- ^ subdir
+      [RevisionMeta]
+      -- ^ revisions
+      Bool
+      -- ^ force version
   deriving (Show, Eq, Generic)
   deriving anyclass (Binary, Hashable, NFData)
 
-pattern SourceMeta :: Maybe UTCTime -> String -> Maybe String -> [RevisionMeta] -> SourceMeta
-pattern SourceMeta {sourceTimestamp, sourceUrl, sourceSubdir, sourceRevisions} <-
-  SourceMeta' (coerce -> sourceTimestamp) sourceUrl sourceSubdir sourceRevisions
+pattern SourceMeta :: Maybe UTCTime -> String -> Maybe String -> [RevisionMeta] -> Bool -> SourceMeta
+pattern SourceMeta {sourceTimestamp, sourceUrl, sourceSubdir, sourceRevisions, sourceForceVersion} <-
+  SourceMeta' (coerce -> sourceTimestamp) sourceUrl sourceSubdir sourceRevisions sourceForceVersion
   where
-    SourceMeta timestamp url subdir revisions = SourceMeta' (coerce timestamp) url subdir revisions
+    SourceMeta timestamp url subdir revisions forceversion = SourceMeta' (coerce timestamp) url subdir revisions forceversion
 
 sourceMetaCodec :: TomlCodec SourceMeta
 sourceMetaCodec =
@@ -49,6 +62,12 @@ sourceMetaCodec =
     <*> Toml.string "url" .= sourceUrl
     <*> Toml.dioptional (Toml.string "subdir") .= sourceSubdir
     <*> Toml.list revisionMetaCodec "revisions" .= sourceRevisions
+    <*> withDefault False (Toml.bool "force-version") .= sourceForceVersion
+
+withDefault :: Eq a => a -> TomlCodec a -> TomlCodec a
+withDefault d c = (fromMaybe d <$> Toml.dioptional c) .= f
+  where
+    f a = if a == d then Nothing else Just a
 
 readSourceMeta :: FilePath -> IO SourceMeta
 readSourceMeta = Toml.decodeFile sourceMetaCodec