mirror of
https://github.com/input-output-hk/foliage.git
synced 2024-11-30 01:16:54 +03:00
122 lines
5.0 KiB
Haskell
122 lines
5.0 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 Data.Text qualified as T
|
|
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 GHC.Generics
|
|
import Network.URI (URI (..), URIAuth (..), nullURI, nullURIAuth)
|
|
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 =
|
|
nullURI
|
|
{ uriScheme = "https:",
|
|
uriAuthority = Just nullURIAuth {uriRegName = "github.com"},
|
|
uriPath = "/" </> T.unpack (unGitHubRepo repo) </> "tarball" </> T.unpack (unGitHubRev 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
|