Fix force-version implementation.

Now the tarballs are downloaded only once but now each package name and
version is unpacked independently in its own directory. Then patches are
applied there.

app/Foliage/CmdBuild.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE NamedFieldPuns #-}
 {-# OPTIONS_GHC -Wno-name-shadowing #-}
 
 module Foliage.CmdBuild (cmdBuild) where
@@ -8,8 +7,9 @@ import Codec.Archive.Tar.Entry qualified as Tar
 import Codec.Compression.GZip qualified as GZip
 import Control.Monad (unless, when)
 import Data.ByteString.Lazy qualified as BSL
+import Data.Char (isAlpha)
 import Data.Foldable (for_)
-import Data.List (isPrefixOf, sortOn)
+import Data.List (dropWhileEnd, isPrefixOf, sortOn)
 import Data.Maybe (fromMaybe)
 import Data.Traversable (for)
 import Development.Shake
@@ -21,8 +21,8 @@ import Foliage.Package
 import Foliage.Shake
 import Foliage.Shake.Oracle
 import Foliage.Time qualified as Time
-import Foliage.Utils
 import System.Directory qualified as IO
+import System.FilePath.Posix qualified as Posix
 
 cmdBuild :: BuildOptions -> IO ()
 cmdBuild
@@ -66,27 +66,51 @@ cmdBuild
         putInfo $ "🕐 Expiry time set to " <> Time.iso8601Show t <> " (a year from now)."
         return t
 
-      getSourceMeta <- addOracle $ \(GetSourceMeta PackageId {pkgName, pkgVersion}) ->
-        readSourceMeta' $ inputDir </> pkgName </> pkgVersion </> "meta.toml"
+      getPackageMeta <- addOracle $ \(GetPackageMeta PackageId {pkgName, pkgVersion}) ->
+        readPackageMeta' $ inputDir </> pkgName </> pkgVersion </> "meta.toml"
 
-      getSourceDir <- addOracle $ \(GetSourceDir pkgId) -> do
-        SourceMeta {sourceUrl, sourceSubdir, sourceForceVersion} <- getSourceMeta (GetSourceMeta pkgId)
-        let urlDir = "_cache" </> urlToFileName sourceUrl
+      preparePackageSource <- addOracle $ \(PreparePackageSource pkgId@PackageId {pkgName, pkgVersion}) -> do
+        PackageMeta {packageSource, packageForceVersion} <- getPackageMeta (GetPackageMeta pkgId)
 
-        need [urlDir </> ".downloaded"]
-        -- FIXME Without this, sometimes the download doesn't trigger
-        putInfo $ "👀 " <> sourceUrl
+        let srcDir = "_cache" </> "packages" </> pkgName </> pkgVersion
 
-        projectFiles <- liftIO $ filter ("cabal.project" `isPrefixOf`) <$> IO.getDirectoryContents urlDir
+        -- FIXME too much rework?
+        -- this action only depends on the tarball and the package metadata
+
+        -- delete everything inside the package source tree
+        liftIO $ do
+          -- FIXME this should only delete inside srcDir but apparently
+          -- also deletes srcDir itself
+          removeFiles srcDir ["//*"]
+          IO.createDirectoryIfMissing True srcDir
+
+        case packageSource of
+          TarballSource url mSubdir -> do
+            tarballPath <- fetchUrl url
+
+            withTempDir $ \tmpDir -> do
+              cmd_ ["tar", "xzf", tarballPath, "-C", tmpDir]
+
+              -- Special treatment of top-level directory: we remove it
+              --
+              -- Note: Don't let shake look into tmpDir! it will cause
+              -- unnecessary rework because tmpDir is always new
+              ls <- liftIO $ IO.getDirectoryContents tmpDir
+              let ls' = filter (not . all (== '.')) ls
+
+              let fix1 = case ls' of [l] -> (</> l); _ -> id
+                  fix2 = case mSubdir of Just s -> (</> s); _ -> id
+                  tdir = fix2 $ fix1 tmpDir
+
+              cmd_ ["cp", "--recursive", "--no-target-directory", "--dereference", tdir, srcDir]
+
+        -- Delete cabal.project files if present
+        projectFiles <- liftIO $ filter ("cabal.project" `isPrefixOf`) <$> IO.getDirectoryContents srcDir
         unless (null projectFiles) $ do
-          putWarn $ "⚠️ Deleting cabal project files from " ++ urlDir
-          liftIO $ for_ projectFiles $ IO.removeFile . (urlDir </>)
+          putWarn $ "⚠️ Deleting cabal project files from " ++ srcDir
+          liftIO $ for_ projectFiles $ IO.removeFile . (srcDir </>)
 
-        let srcDir = case sourceSubdir of
-              Just s -> urlDir </> s
-              Nothing -> urlDir
-
-        when sourceForceVersion $
+        when packageForceVersion $
           forcePackageVersion srcDir pkgId
 
         applyPatches inputDir srcDir pkgId
@@ -257,9 +281,9 @@ cmdBuild
           fmap concat $
             for pkgIds $ \pkgId -> do
               let PackageId {pkgName, pkgVersion} = pkgId
-              SourceMeta {sourceTimestamp, sourceRevisions} <- getSourceMeta (GetSourceMeta pkgId)
+              PackageMeta {packageTimestamp, packageRevisions} <- getPackageMeta (GetPackageMeta pkgId)
 
-              srcDir <- getSourceDir (GetSourceDir pkgId)
+              srcDir <- preparePackageSource $ PreparePackageSource pkgId
               now <- getCurrentTime GetCurrentTime
 
               sequence $
@@ -267,19 +291,19 @@ cmdBuild
                   mkTarEntry
                     (srcDir </> pkgName <.> "cabal")
                     (pkgName </> pkgVersion </> pkgName <.> "cabal")
-                    (fromMaybe now sourceTimestamp),
+                    (fromMaybe now packageTimestamp),
                   -- package.json
                   mkTarEntry
                     (outputDir </> "index" </> pkgName </> pkgVersion </> "package.json")
                     (pkgName </> pkgVersion </> "package.json")
-                    (fromMaybe now sourceTimestamp)
+                    (fromMaybe now packageTimestamp)
                 ]
                   ++ [ -- revised cabal files
                        mkTarEntry
                          (inputDir </> pkgName </> pkgVersion </> "revisions" </> show revNum <.> "cabal")
                          (pkgName </> pkgVersion </> pkgName <.> "cabal")
                          (fromMaybe now revTimestamp)
-                       | RevisionMeta revTimestamp revNum <- sourceRevisions
+                       | RevisionMeta revTimestamp revNum <- packageRevisions
                      ]
 
         liftIO $ BSL.writeFile path $ Tar.write (sortOn Tar.entryTime entries)
@@ -295,23 +319,24 @@ cmdBuild
         putInfo $ "✅ Written " <> path
 
       --
-      -- index cabal files (latest revision)
+      -- index cabal files
+      --
+      -- these come either from the package source or the revision files
       --
 
       outputDir </> "index/*/*/*.cabal" %> \path -> do
         let [_, _, pkgName, pkgVersion, _] = splitDirectories path
         let pkgId = PackageId pkgName pkgVersion
 
-        -- Figure out where to get it from
-        meta <- getSourceMeta $ GetSourceMeta pkgId
+        meta <- getPackageMeta $ GetPackageMeta pkgId
 
         case latestRevisionNumber meta of
           Nothing -> do
-            srcDir <- getSourceDir (GetSourceDir pkgId)
+            srcDir <- preparePackageSource $ PreparePackageSource pkgId
             copyFileChanged (srcDir </> pkgName <.> "cabal") path
           Just revNum -> do
-            let revisionCabal = inputDir </> pkgName </> pkgVersion </> "revisions" </> show revNum <.> "cabal"
-            copyFileChanged revisionCabal path
+            let revisionFile = inputDir </> pkgName </> pkgVersion </> "revisions" </> show revNum <.> "cabal"
+            copyFileChanged revisionFile path
 
         putInfo $ "✅ Written " <> path
 
@@ -343,17 +368,19 @@ cmdBuild
         putInfo $ "✅ Written " <> path
 
       --
-      -- source distributions
+      -- source distributions, including patching
       --
 
       outputDir </> "package/*.tar.gz" %> \path -> do
         let [_, _, filename] = splitDirectories path
         let Just pkgId = parsePkgId <$> stripExtension "tar.gz" filename
 
-        srcDir <- getSourceDir (GetSourceDir pkgId)
+        srcDir <- preparePackageSource $ PreparePackageSource pkgId
+        putInfo srcDir
 
         withTempDir $ \tmpDir -> do
-          putInfo $ " Creating source distribution for " <> pkgIdToString pkgId
+          putInfo $ "Creating source distribution for " <> pkgIdToString pkgId
+
           cmd_ Shell (Cwd srcDir) (FileStdout path) ("cabal sdist --ignore-project --output-directory " <> tmpDir)
 
           -- check cabal sdist has produced a single tarball with the
@@ -373,34 +400,25 @@ cmdBuild
         putInfo $ "✅ Written " <> path
 
       --
-      -- source tree downloads
+      -- tarball downloads
       --
 
-      "_cache/*/.downloaded" %> \path -> do
-        let [_, hashedUrl, _] = splitDirectories path
-        let url = fileNameToUrl hashedUrl
-        let srcDir = takeDirectory path
-
-        withTempDir $ \tmpDir -> do
-          -- Download and extract tarball
-          putInfo $ "🐢 Downloading " <> url
-          cmd_ Shell $ "curl --silent -L " <> url <> " | tar xz -C " <> tmpDir
-
-          -- Special treatment of top-level directory: we remove it
-          --
-          -- Note: Don't let shake look into tmpDir! it will cause
-          -- unnecessary rework because tmpDir is always new
-          ls <- liftIO $ IO.getDirectoryContents tmpDir
-          let ls' = filter (not . all (== '.')) ls
-          case ls' of
-            [l] -> cmd_ Shell ["mv", "-T", tmpDir </> l, srcDir]
-            _ -> cmd_ Shell ["mv", "-T", tmpDir, srcDir]
-
-        -- Touch the trigger file
-        writeFile' path ""
+      "_cache/downloads/**" %> \path -> do
+        let scheme : rest = drop 2 $ splitDirectories path
+        let url = scheme <> "://" <> Posix.joinPath rest
+        putInfo $ "🐢 Downloading " <> url
+        cmd_ Shell (FileStdout path) $ "curl --silent -L " <> url
 
     putStrLn $ "💥 All done. The repository is now available in " <> outputDir <> "."
 
+fetchUrl :: String -> Action FilePath
+fetchUrl url = do
+  let scheme : rest = Posix.splitPath url
+      scheme' = dropWhileEnd (not . isAlpha) scheme
+      urlPath = "_cache" </> "downloads" </> joinPath (scheme' : rest)
+  need [urlPath]
+  return urlPath
+
 mkTarEntry :: FilePath -> [Char] -> UTCTime -> Action Tar.Entry
 mkTarEntry filePath indexPath timestamp = do
   let Right tarPath = Tar.toTarPath False indexPath
@@ -417,17 +435,16 @@ mkTarEntry filePath indexPath timestamp = do
             }
       }
 
-applyPatches :: FilePath -> FilePath -> PackageId -> Action ()
+applyPatches :: [Char] -> 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"
+    patchfiles <- getDirectoryFiles patchesDir ["*.patch"]
+    for_ patchfiles $ \patchfile -> do
+      let patch = patchesDir </> patchfile
+      cmd_ Shell (Cwd srcDir) (FileStdin patch) "patch -p1"
 
 forcePackageVersion :: FilePath -> PackageId -> Action ()
 forcePackageVersion srcDir PackageId {pkgName, pkgVersion} = do
@@ -442,7 +459,7 @@ replaceVersion version = unlines . map f . lines
       | "version" `isPrefixOf` line =
         unlines
           [ "-- version field replaced by foliage",
-            "--" <> line,
-            "version:\t" ++ version
+            "-- " <> line,
+            "version: " ++ version
           ]
     f line = line

app/Foliage/CmdImportHackage.hs

@@ -40,8 +40,8 @@ importIndex ::
   Show e =>
   (PackageId -> Bool) ->
   Tar.Entries e ->
-  Map PackageId SourceMeta ->
-  IO (Map PackageId SourceMeta)
+  Map PackageId PackageMeta ->
+  IO (Map PackageId PackageMeta)
 importIndex f (Tar.Next e es) m =
   case isCabalFile e of
     Just (pkgId, contents, time)
@@ -55,19 +55,18 @@ importIndex f (Tar.Next e es) m =
                   Nothing ->
                     pure $
                       Just $
-                        SourceMeta
-                          { sourceUrl = pkgIdToHackageUrl pkgId,
-                            sourceTimestamp = Just time,
-                            sourceSubdir = Nothing,
-                            sourceRevisions = [],
-                            sourceForceVersion = False
+                        PackageMeta
+                          { packageSource = TarballSource (pkgIdToHackageUrl pkgId) Nothing,
+                            packageTimestamp = Just time,
+                            packageRevisions = [],
+                            packageForceVersion = False
                           }
                   -- Existing package, new revision
                   Just sm -> do
                     let revnum = 1 + fromMaybe 0 (latestRevisionNumber sm)
                         newRevision = RevisionMeta {revisionNumber = revnum, revisionTimestamp = Just time}
                     -- bad performance here but I don't care
-                    let sm' = sm {sourceRevisions = sourceRevisions sm ++ [newRevision]}
+                    let sm' = sm {packageRevisions = packageRevisions sm ++ [newRevision]}
                     let PackageId pkgName pkgVersion = pkgId
                     let outDir = "_sources" </> pkgName </> pkgVersion </> "revisions"
                     IO.createDirectoryIfMissing True outDir
@@ -85,12 +84,12 @@ importIndex _f (Tar.Fail e) _ =
 
 finalise ::
   PackageId ->
-  SourceMeta ->
+  PackageMeta ->
   IO ()
 finalise PackageId {pkgName, pkgVersion} meta = do
   let dir = "_sources" </> pkgName </> pkgVersion
   IO.createDirectoryIfMissing True dir
-  writeSourceMeta (dir </> "meta.toml") meta
+  writePackageMeta (dir </> "meta.toml") meta
 
 isCabalFile ::
   Tar.Entry ->

app/Foliage/Meta.hs

@@ -5,19 +5,20 @@
 {-# LANGUAGE PatternSynonyms #-}
 
 module Foliage.Meta
-  ( SourceMeta,
-    pattern SourceMeta,
-    sourceTimestamp,
-    sourceUrl,
-    sourceSubdir,
-    sourceRevisions,
-    sourceForceVersion,
-    readSourceMeta,
-    writeSourceMeta,
+  ( PackageMeta,
+    pattern PackageMeta,
+    packageTimestamp,
+    packageSource,
+    packageRevisions,
+    packageForceVersion,
+    readPackageMeta,
+    writePackageMeta,
     RevisionMeta,
     pattern RevisionMeta,
     revisionTimestamp,
     revisionNumber,
+    PackageSource,
+    pattern TarballSource,
     UTCTime,
     latestRevisionNumber,
   )
@@ -34,14 +35,30 @@ import GHC.Generics
 import Toml (TomlCodec, (.=))
 import Toml qualified
 
-data SourceMeta
-  = SourceMeta'
+data PackageSource
+  = TarballSource String (Maybe String)
+  deriving (Show, Eq, Generic)
+  deriving anyclass (Binary, Hashable, NFData)
+
+packageSourceCodec :: TomlCodec PackageSource
+packageSourceCodec =
+  Toml.dimatch matchTarballSource (uncurry TarballSource) tarballSourceCodec
+
+tarballSourceCodec :: TomlCodec (String, Maybe String)
+tarballSourceCodec =
+  Toml.pair
+    (Toml.string "url")
+    (Toml.dioptional $ Toml.string "subdir")
+
+matchTarballSource :: PackageSource -> Maybe (String, Maybe String)
+matchTarballSource (TarballSource url mSubdir) = Just (url, mSubdir)
+
+data PackageMeta
+  = PackageMeta'
       (Maybe WrapUTCTime)
       -- ^ timestamp
-      String
-      -- ^ url
-      (Maybe String)
-      -- ^ subdir
+      PackageSource
+      -- ^ source parameters
       [RevisionMeta]
       -- ^ revisions
       Bool
@@ -49,31 +66,25 @@ data SourceMeta
   deriving (Show, Eq, Generic)
   deriving anyclass (Binary, Hashable, NFData)
 
-pattern SourceMeta :: Maybe UTCTime -> String -> Maybe String -> [RevisionMeta] -> Bool -> SourceMeta
-pattern SourceMeta {sourceTimestamp, sourceUrl, sourceSubdir, sourceRevisions, sourceForceVersion} <-
-  SourceMeta' (coerce -> sourceTimestamp) sourceUrl sourceSubdir sourceRevisions sourceForceVersion
+pattern PackageMeta :: Maybe UTCTime -> PackageSource -> [RevisionMeta] -> Bool -> PackageMeta
+pattern PackageMeta {packageTimestamp, packageSource, packageRevisions, packageForceVersion} <-
+  PackageMeta' (coerce -> packageTimestamp) packageSource packageRevisions packageForceVersion
   where
-    SourceMeta timestamp url subdir revisions forceversion = SourceMeta' (coerce timestamp) url subdir revisions forceversion
+    PackageMeta timestamp source revisions forceversion = PackageMeta' (coerce timestamp) source revisions forceversion
 
-sourceMetaCodec :: TomlCodec SourceMeta
+sourceMetaCodec :: TomlCodec PackageMeta
 sourceMetaCodec =
-  SourceMeta
-    <$> Toml.dioptional (timeCodec "timestamp") .= sourceTimestamp
-    <*> Toml.string "url" .= sourceUrl
-    <*> Toml.dioptional (Toml.string "subdir") .= sourceSubdir
-    <*> Toml.list revisionMetaCodec "revisions" .= sourceRevisions
-    <*> withDefault False (Toml.bool "force-version") .= sourceForceVersion
+  PackageMeta
+    <$> Toml.dioptional (timeCodec "timestamp") .= packageTimestamp
+    <*> packageSourceCodec .= packageSource
+    <*> Toml.list revisionMetaCodec "revisions" .= packageRevisions
+    <*> withDefault False (Toml.bool "force-version") .= packageForceVersion
 
-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
+readPackageMeta :: FilePath -> IO PackageMeta
+readPackageMeta = Toml.decodeFile sourceMetaCodec
 
-readSourceMeta :: FilePath -> IO SourceMeta
-readSourceMeta = Toml.decodeFile sourceMetaCodec
-
-writeSourceMeta :: FilePath -> SourceMeta -> IO ()
-writeSourceMeta fp a = void $ Toml.encodeToFile sourceMetaCodec fp a
+writePackageMeta :: FilePath -> PackageMeta -> IO ()
+writePackageMeta fp a = void $ Toml.encodeToFile sourceMetaCodec fp a
 
 data RevisionMeta = RevisionMeta' (Maybe WrapUTCTime) Int
   deriving (Show, Eq, Generic)
@@ -91,6 +102,20 @@ revisionMetaCodec =
     <$> Toml.dioptional (timeCodec "timestamp") .= revisionTimestamp
     <*> Toml.int "number" .= revisionNumber
 
+timeCodec :: Toml.Key -> TomlCodec UTCTime
+timeCodec key = Toml.dimap (utcToZonedTime utc) zonedTimeToUTC $ Toml.zonedTime key
+
+latestRevisionNumber :: PackageMeta -> Maybe Int
+latestRevisionNumber sm =
+  if null (packageRevisions sm)
+    then Nothing
+    else Just $ maximum $ map revisionNumber (packageRevisions sm)
+
+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
+
 newtype WrapUTCTime = WrapUTCTime {unwrapUTCTime :: UTCTime}
   deriving (Show, Eq, Generic)
   deriving anyclass (Hashable, NFData)
@@ -99,12 +124,3 @@ newtype WrapUTCTime = WrapUTCTime {unwrapUTCTime :: UTCTime}
 instance Binary WrapUTCTime where
   get = iso8601ParseM =<< get
   put = put . iso8601Show
-
-timeCodec :: Toml.Key -> TomlCodec UTCTime
-timeCodec key = Toml.dimap (utcToZonedTime utc) zonedTimeToUTC $ Toml.zonedTime key
-
-latestRevisionNumber :: SourceMeta -> Maybe Int
-latestRevisionNumber sm =
-  if null (sourceRevisions sm)
-    then Nothing
-    else Just $ maximum $ map revisionNumber (sourceRevisions sm)

app/Foliage/Shake.hs

@@ -2,7 +2,7 @@ module Foliage.Shake
   ( computeFileInfoSimple',
     readFileByteStringLazy,
     readKeysAt,
-    readSourceMeta',
+    readPackageMeta',
   )
 where
 
@@ -28,7 +28,7 @@ readKeysAt base = do
     Right key <- liftIO $ readJSONSimple (base </> path)
     pure key
 
-readSourceMeta' :: FilePath -> Action SourceMeta
-readSourceMeta' fp = do
+readPackageMeta' :: FilePath -> Action PackageMeta
+readPackageMeta' fp = do
   need [fp]
-  liftIO $ readSourceMeta fp
+  liftIO $ readPackageMeta fp

app/Foliage/Shake/Oracle.hs

@@ -7,9 +7,9 @@ module Foliage.Shake.Oracle
   ( UTCTime,
     GetCurrentTime (..),
     GetExpiryTime (..),
-    GetSourceMeta (..),
+    GetPackageMeta (..),
     GetPackages (..),
-    GetSourceDir (..),
+    PreparePackageSource (..),
   )
 where
 
@@ -38,14 +38,14 @@ data GetPackages = GetPackages
 
 type instance RuleResult GetPackages = [PackageId]
 
-newtype GetSourceMeta = GetSourceMeta PackageId
+newtype GetPackageMeta = GetPackageMeta PackageId
   deriving (Show, Eq, Generic)
   deriving anyclass (Binary, Hashable, NFData)
 
-type instance RuleResult GetSourceMeta = SourceMeta
+type instance RuleResult GetPackageMeta = PackageMeta
 
-newtype GetSourceDir = GetSourceDir PackageId
+newtype PreparePackageSource = PreparePackageSource PackageId
   deriving (Show, Eq, Generic)
   deriving anyclass (Binary, Hashable, NFData)
 
-type instance RuleResult GetSourceDir = FilePath
+type instance RuleResult PreparePackageSource = FilePath

app/Foliage/Utils.hs

@@ -1,14 +0,0 @@
-module Foliage.Utils
-  ( urlToFileName,
-    fileNameToUrl,
-  )
-where
-
-import Data.Text qualified as T
-import Data.Text.Encoding.Base64.URL qualified as T
-
-urlToFileName :: String -> FilePath
-urlToFileName = T.unpack . T.encodeBase64Unpadded . T.pack
-
-fileNameToUrl :: FilePath -> String
-fileNameToUrl = T.unpack . T.decodeBase64Lenient . T.pack

foliage.cabal

@@ -18,7 +18,6 @@ executable foliage
         Foliage.Shake
         Foliage.Shake.Oracle
         Foliage.Time
-        Foliage.Utils
 
     default-language:   Haskell2010
     default-extensions: