mirror of
https://github.com/input-output-hk/foliage.git
synced 2024-11-30 01:16:54 +03:00
2631bf6067
Implement a new flag "--write-metadata" which will create, in the output
directory, a file "foliage/packages.json" with metadata about the
package provenance.
The file package.json file looks like this
```
{
"Win32-network-0.1.0.0": {
"source": {
"url": "github:input-output-hk/Win32-network/3825d3abf75f83f406c1f7161883c438dac7277d"
},
"timestamp": "2022-10-17T00:00:00Z"
},
"Win32-network-0.1.1.0": {
...
```
The idea is that tools fetching the repo can also fetch this file to
obtain information about the package provenance.
116 lines
4.7 KiB
Haskell
116 lines
4.7 KiB
Haskell
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
module Foliage.PrepareSource where
|
|
|
|
import Control.Monad (when)
|
|
import Data.ByteString qualified as BS
|
|
import Data.Foldable (for_)
|
|
import Development.Shake
|
|
import Development.Shake.Classes
|
|
import Development.Shake.Rule
|
|
import Distribution.Pretty (prettyShow)
|
|
import Distribution.Types.PackageId
|
|
import Distribution.Types.PackageName (unPackageName)
|
|
import Foliage.Meta
|
|
import Foliage.RemoteAsset (fetchRemoteAsset)
|
|
import Foliage.UpdateCabalFile (rewritePackageVersion)
|
|
import Foliage.Utils.GitHub (githubRepoTarballUrl)
|
|
import GHC.Generics
|
|
import System.Directory qualified as IO
|
|
import System.FilePath ((<.>), (</>))
|
|
|
|
data PrepareSourceRule = PrepareSourceRule PackageId PackageVersionSpec
|
|
deriving (Show, Eq, Generic)
|
|
deriving (Hashable, Binary, NFData)
|
|
|
|
type instance RuleResult PrepareSourceRule = FilePath
|
|
|
|
prepareSource :: PackageId -> PackageVersionSpec -> Action FilePath
|
|
prepareSource pkgId pkgMeta = apply1 $ PrepareSourceRule pkgId pkgMeta
|
|
|
|
addPrepareSourceRule :: FilePath -> FilePath -> Rules ()
|
|
addPrepareSourceRule inputDir cacheDir = addBuiltinRule noLint noIdentity run
|
|
where
|
|
run :: PrepareSourceRule -> Maybe BS.ByteString -> RunMode -> Action (RunResult FilePath)
|
|
run (PrepareSourceRule pkgId pkgMeta) _old mode = do
|
|
let PackageIdentifier {pkgName, pkgVersion} = pkgId
|
|
let PackageVersionSpec {packageVersionSource, packageVersionForce} = pkgMeta
|
|
let srcDir = cacheDir </> unPackageName pkgName </> prettyShow pkgVersion
|
|
|
|
case mode of
|
|
RunDependenciesSame ->
|
|
return $ RunResult ChangedNothing BS.empty srcDir
|
|
RunDependenciesChanged -> do
|
|
-- 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 packageVersionSource of
|
|
TarballSource url mSubdir -> do
|
|
tarballPath <- fetchRemoteAsset 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]
|
|
--
|
|
-- This is almost identical to the above but we get to keep the
|
|
-- metadata.
|
|
--
|
|
GitHubSource repo rev mSubdir -> do
|
|
let url = githubRepoTarballUrl repo rev
|
|
|
|
tarballPath <- fetchRemoteAsset 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]
|
|
|
|
let patchesDir = inputDir </> unPackageName pkgName </> prettyShow pkgVersion </> "patches"
|
|
hasPatches <- doesDirectoryExist patchesDir
|
|
|
|
when hasPatches $ do
|
|
patchfiles <- getDirectoryFiles patchesDir ["*.patch"]
|
|
for_ patchfiles $ \patchfile -> do
|
|
let patch = patchesDir </> patchfile
|
|
cmd_ Shell (Cwd srcDir) (FileStdin patch) "patch -p1"
|
|
|
|
when packageVersionForce $ do
|
|
let cabalFilePath = srcDir </> unPackageName pkgName <.> "cabal"
|
|
putInfo $ "Updating version in cabal file" ++ cabalFilePath
|
|
liftIO $ rewritePackageVersion cabalFilePath pkgVersion
|
|
|
|
return $ RunResult ChangedRecomputeDiff BS.empty srcDir
|