Switch to forward mode

This commit is contained in:
Andrea Bedini 2022-09-22 18:54:35 +02:00
parent 32d1345276
commit 20b55ba655
8 changed files with 389 additions and 522 deletions

View File

@ -1,4 +1,6 @@
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Foliage.CmdBuild (cmdBuild) where
@ -7,7 +9,6 @@ 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.Foldable (for_)
import Data.List (sortOn)
import Data.Maybe (fromMaybe)
import Data.Traversable (for)
@ -22,15 +23,32 @@ import Distribution.Verbosity qualified as Verbosity
import Foliage.HackageSecurity
import Foliage.Meta
import Foliage.Options
import Foliage.RemoteAsset (addBuiltinRemoteAssetRule, remoteAssetNeed)
import Foliage.PrepareSource (addPrepareSourceRule, prepareSource)
import Foliage.RemoteAsset (addFetchRemoteAssetRule)
import Foliage.Shake
import Foliage.Shake.Oracle
import Foliage.Time qualified as Time
import Foliage.UpdateCabalFile (rewritePackageVersion)
import Hackage.Security.Util.Path (castRoot, toFilePath)
import System.Directory qualified as IO
cmdBuild :: BuildOptions -> IO ()
cmdBuild
cmdBuild buildOptions = do
shake opts $
do
addFetchRemoteAssetRule cacheDir
addPrepareSourceRule (buildOptsInputDir buildOptions) cacheDir
phony "buildAction" (buildAction buildOptions)
want ["buildAction"]
where
cacheDir = "_cache"
opts =
shakeOptions
{ shakeChange = ChangeDigest,
shakeFiles = cacheDir,
shakeVerbosity = Normal
}
buildAction :: BuildOptions -> Action ()
buildAction
BuildOptions
{ buildOptsSignOpts = signOpts,
buildOptsCurrentTime = mCurrentTime,
@ -38,439 +56,261 @@ cmdBuild
buildOptsInputDir = inputDir,
buildOptsOutputDir = outputDir
} = do
case signOpts of
outputDirRoot <- liftIO $ makeAbsolute (fromFilePath outputDir)
maybeReadKeysAt <- case signOpts of
SignOptsSignWithKeys keysPath -> do
ks <- IO.doesDirectoryExist keysPath
ks <- doesDirectoryExist keysPath
unless ks $ do
putStrLn $ "You don't seem to have created a set of TUF keys. I will create one in " <> keysPath
createKeys keysPath
_ -> return ()
putWarn $ "You don't seem to have created a set of TUF keys. I will create one in " <> keysPath
liftIO $ createKeys keysPath
return $ \name -> readKeysAt (keysPath </> name)
SignOptsDon'tSign ->
return $ const $ return []
let cacheDir = "_cache"
expiryTime <-
for mExpireSignaturesOn $ \expireSignaturesOn -> do
putInfo $ "Expiry time set to " <> Time.iso8601Show expireSignaturesOn
return expireSignaturesOn
let pkgMetaDir PackageIdentifier {pkgName, pkgVersion} =
inputDir </> unPackageName pkgName </> prettyShow pkgVersion
currentTime <- case mCurrentTime of
Nothing -> do
t <- Time.truncateSeconds <$> liftIO Time.getCurrentTime
putInfo $ "Current time set to " <> Time.iso8601Show t <> ". You can set a fixed time using the --current-time option."
return t
Just t -> do
putInfo $ "Current time set to " <> Time.iso8601Show t <> "."
return t
let opts =
shakeOptions
{ shakeChange = ChangeDigest,
shakeFiles = cacheDir,
shakeVerbosity = Info
let mirrors = do
keys <- maybeReadKeysAt "mirrors"
writeSignedJSON outputDirRoot repoLayoutMirrors keys $
Mirrors
{ mirrorsVersion = FileVersion 1,
mirrorsExpires = FileExpires expiryTime,
mirrorsMirrors = []
}
let root = do
privateKeysRoot <- maybeReadKeysAt "root"
privateKeysTarget <- maybeReadKeysAt "target"
privateKeysSnapshot <- maybeReadKeysAt "snapshot"
privateKeysTimestamp <- maybeReadKeysAt "timestamp"
privateKeysMirrors <- maybeReadKeysAt "mirrors"
keys <- maybeReadKeysAt "root"
writeSignedJSON outputDirRoot repoLayoutRoot keys $
Root
{ rootVersion = FileVersion 1,
rootExpires = FileExpires expiryTime,
rootKeys =
fromKeys $
concat
[ privateKeysRoot,
privateKeysTarget,
privateKeysSnapshot,
privateKeysTimestamp,
privateKeysMirrors
],
rootRoles =
RootRoles
{ rootRolesRoot =
RoleSpec
{ roleSpecKeys = map somePublicKey privateKeysRoot,
roleSpecThreshold = KeyThreshold 2
},
rootRolesSnapshot =
RoleSpec
{ roleSpecKeys = map somePublicKey privateKeysSnapshot,
roleSpecThreshold = KeyThreshold 1
},
rootRolesTargets =
RoleSpec
{ roleSpecKeys = map somePublicKey privateKeysTarget,
roleSpecThreshold = KeyThreshold 1
},
rootRolesTimestamp =
RoleSpec
{ roleSpecKeys = map somePublicKey privateKeysTimestamp,
roleSpecThreshold = KeyThreshold 1
},
rootRolesMirrors =
RoleSpec
{ roleSpecKeys = map somePublicKey privateKeysMirrors,
roleSpecThreshold = KeyThreshold 1
}
}
}
let snapshot = do
rootInfo <- computeFileInfoSimple' (anchorPath outputDirRoot repoLayoutRoot)
mirrorsInfo <- computeFileInfoSimple' (anchorPath outputDirRoot repoLayoutMirrors)
tarInfo <- computeFileInfoSimple' (anchorPath outputDirRoot repoLayoutIndexTar)
tarGzInfo <- computeFileInfoSimple' (anchorPath outputDirRoot repoLayoutIndexTarGz)
keys <- maybeReadKeysAt "snapshot"
writeSignedJSON outputDirRoot repoLayoutSnapshot keys $
Snapshot
{ snapshotVersion = FileVersion 1,
snapshotExpires = FileExpires expiryTime,
snapshotInfoRoot = rootInfo,
snapshotInfoMirrors = mirrorsInfo,
snapshotInfoTar = Just tarInfo,
snapshotInfoTarGz = tarGzInfo
}
let timestamp = do
snapshotInfo <- computeFileInfoSimple' (anchorPath outputDirRoot repoLayoutSnapshot)
keys <- maybeReadKeysAt "timestamp"
writeSignedJSON outputDirRoot repoLayoutTimestamp keys $
Timestamp
{ timestampVersion = FileVersion 1,
timestampExpires = FileExpires expiryTime,
timestampInfoSnapshot = snapshotInfo
}
packages <- getPackages inputDir
targetKeys <- maybeReadKeysAt "target"
entries <- fmap concat $
for packages $
\(pkgId, pkgMeta) -> do
prepareEntry
inputDir
outputDirRoot
targetKeys
currentTime
expiryTime
pkgId
pkgMeta
let tarContents = Tar.write $ sortOn Tar.entryTime entries
traced "Writing" $ BSL.writeFile (anchorPath outputDirRoot repoLayoutIndexTar) tarContents
traced "Writing" $ BSL.writeFile (anchorPath outputDirRoot repoLayoutIndexTarGz) $ GZip.compress tarContents
mirrors
root
snapshot
timestamp
getPackages :: FilePath -> Action [(PackageIdentifier, PackageVersionMeta)]
getPackages inputDir = do
metaFiles <- getDirectoryFiles inputDir ["*/*/meta.toml"]
when (null metaFiles) $ do
putError $
unlines
[ "We could not find any package metadata file (i.e. _sources/<name>/<version>/meta.toml)",
"Make sure you are passing the right input directory. The default input directory is _sources"
]
fail "no package metadata found"
for metaFiles $ \metaFile -> do
let [pkgName, pkgVersion, _] = splitDirectories metaFile
let Just name = simpleParsec pkgName
let Just version = simpleParsec pkgVersion
let pkgId = PackageIdentifier name version
meta <- do
readPackageVersionMeta' (inputDir </> metaFile) >>= \case
PackageVersionMeta {packageVersionRevisions, packageVersionTimestamp = Nothing}
| not (null packageVersionRevisions) -> do
putError $
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"
fail "invalid package metadata"
PackageVersionMeta {packageVersionRevisions, packageVersionTimestamp = Just pkgTs}
| any ((< pkgTs) . revisionTimestamp) packageVersionRevisions -> do
putError $
inputDir </> metaFile <> " has a revision with timestamp earlier than the package itself. Adjust the timestamps so that all revisions come after the original package"
fail "invalid package metadata"
meta ->
return meta
return (pkgId, meta)
prepareEntry ::
FilePath ->
Path Absolute ->
[Some Key] ->
UTCTime ->
Maybe UTCTime ->
PackageId ->
PackageVersionMeta ->
Action [Tar.Entry]
prepareEntry
inputDir
outputDirRoot
keys
currentTime
expiryTime
pkgId@PackageIdentifier {pkgName, pkgVersion}
pkgMeta@PackageVersionMeta {packageVersionTimestamp, packageVersionRevisions} = do
srcDir <- prepareSource pkgId pkgMeta
let cabalFilePath = srcDir </> unPackageName pkgName <.> "cabal"
cabalFileContents <- liftIO $ BSL.readFile cabalFilePath
let packagePath = repoLayoutPkgTarGz hackageRepoLayout pkgId
sdist <- traced "cabal sdist" $ do
gpd <- readGenericPackageDescription Verbosity.normal cabalFilePath
let path = toFilePath $ anchorRepoPathLocally outputDirRoot packagePath
IO.createDirectoryIfMissing True (takeDirectory path)
packageDirToSdist Verbosity.normal gpd srcDir
>>= BSL.writeFile path
return path
-- original cabal file
let cabalEntry =
mkTarEntry
cabalFileContents
(IndexPkgCabal pkgId)
(fromMaybe currentTime packageVersionTimestamp)
-- package.json
targetFileInfo <- computeFileInfoSimple' sdist
let targets =
Targets
{ targetsVersion = FileVersion 1,
targetsExpires = FileExpires expiryTime,
targetsTargets = fromList [(TargetPathRepo packagePath, targetFileInfo)],
targetsDelegations = Nothing
}
shake opts $ do
addBuiltinRemoteAssetRule (cacheDir </> "downloads")
let packageEntry =
mkTarEntry
(renderSignedJSON keys targets)
(IndexPkgMetadata pkgId)
(fromMaybe currentTime packageVersionTimestamp)
--
-- Oracles
--
getCurrentTime <- addOracle $ \GetCurrentTime ->
case mCurrentTime of
Nothing -> do
t <- Time.truncateSeconds <$> liftIO Time.getCurrentTime
putInfo $ "Current time set to " <> Time.iso8601Show t <> ". You can set a fixed time using the --current-time option."
return t
Just t -> do
putInfo $ "Current time set to " <> Time.iso8601Show t <> "."
return t
getExpiryTime <- addOracleCache $ \GetExpiryTime -> do
alwaysRerun
for mExpireSignaturesOn $ \expireSignaturesOn -> do
putInfo $ "Expiry time set to " <> Time.iso8601Show expireSignaturesOn
return expireSignaturesOn
getSignOpts <- addOracle $ \GetSignOptions -> do
alwaysRerun
return signOpts
getPackageVersionMeta <- addOracleCache $ \(GetPackageVersionMeta pkgId) -> do
meta <- readPackageVersionMeta' $ pkgMetaDir pkgId </> "meta.toml"
-- Here we do some validation of the package metadata. We could
-- fine a better place for it.
case meta of
PackageVersionMeta {packageVersionRevisions, packageVersionTimestamp = Nothing}
| not (null packageVersionRevisions) -> do
putError $
"Package " <> prettyShow pkgId
<> " 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"
fail "invalid package metadata"
PackageVersionMeta {packageVersionRevisions, packageVersionTimestamp = Just pkgTs}
| any ((< pkgTs) . revisionTimestamp) packageVersionRevisions -> do
putError $
"Package " <> prettyShow pkgId
<> " has a revision with timestamp earlier than the package itself. Adjust the timestamps so that all revisions come after the original package"
fail "invalid package metadata"
_ ->
return meta
preparePackageSource <- addOracleCache $ \(PreparePackageSource pkgId) -> do
PackageVersionMeta {packageVersionSource, packageVersionForce} <- getPackageVersionMeta (GetPackageVersionMeta pkgId)
-- FIXME too much rework?
-- this action only depends on the tarball and the package metadata
let PackageIdentifier {pkgName, pkgVersion} = pkgId
let srcDir = cacheDir </> unPackageName pkgName </> prettyShow pkgVersion
-- delete everything inside the package source tree
-- revised cabal files
revisionEntries <-
for packageVersionRevisions $ \RevisionMeta {revisionNumber, revisionTimestamp} ->
liftIO $ do
-- FIXME this should only delete inside srcDir but apparently
-- also deletes srcDir itself
removeFiles srcDir ["//*"]
IO.createDirectoryIfMissing True srcDir
contents <- BSL.readFile (inputDir </> unPackageName pkgName </> prettyShow pkgVersion </> "revisions" </> show revisionNumber <.> "cabal")
return $
mkTarEntry
contents
(IndexPkgCabal pkgId)
revisionTimestamp
case packageVersionSource of
TarballSource url mSubdir -> do
tarballPath <- remoteAssetNeed url
return $ cabalEntry : packageEntry : revisionEntries
withTempDir $ \tmpDir -> do
cmd_ ["tar", "xzf", tarballPath, "-C", tmpDir]
mkTarEntry :: BSL.ByteString -> IndexFile dec -> UTCTime -> Tar.Entry
mkTarEntry contents indexFile timestamp =
(Tar.fileEntry tarPath contents)
{ Tar.entryTime = floor $ Time.utcTimeToPOSIXSeconds timestamp,
Tar.entryOwnership =
Tar.Ownership
{ Tar.ownerName = "foliage",
Tar.groupName = "foliage",
Tar.ownerId = 0,
Tar.groupId = 0
}
}
where
indexPath = toFilePath $ castRoot $ indexFileToPath hackageIndexLayout indexFile
Right tarPath = Tar.toTarPath False indexPath
-- 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]
applyPatches inputDir srcDir pkgId
when packageVersionForce $
forcePackageVersion srcDir pkgId
return srcDir
getPackageDescription <- addOracleCache $ \(GetPackageDescription pkgId) -> do
let PackageIdentifier {pkgName, pkgVersion} = pkgId
meta <- getPackageVersionMeta $ GetPackageVersionMeta pkgId
case latestRevisionNumber meta of
Nothing -> do
srcDir <- preparePackageSource $ PreparePackageSource pkgId
return $ srcDir </> unPackageName pkgName <.> "cabal"
Just revNum -> do
return $ inputDir </> unPackageName pkgName </> prettyShow pkgVersion </> "revisions" </> show revNum <.> "cabal"
getPackages <- addOracleCache $ \GetPackages -> do
metaFiles <- getDirectoryFiles inputDir ["*/*/meta.toml"]
when (null metaFiles) $ do
putError $
unlines
[ "We could not find any package metadata file (i.e. _sources/<name>/<version>/meta.toml)",
"Make sure you are passing the right input directory. The default input directory is _sources"
]
fail "no package metadata found"
return $
[ PackageIdentifier name version
| path <- metaFiles,
let [pkgName, pkgVersion, _] = splitDirectories path,
let Just name = simpleParsec pkgName,
let Just version = simpleParsec pkgVersion
]
--
-- utilities
--
let readKeysAt' name =
getSignOpts GetSignOptions >>= \case
SignOptsSignWithKeys keysPath -> do
readKeysAt (keysPath </> name)
SignOptsDon'tSign ->
return []
--
-- Entrypoint
--
-- This triggers the whole chain of TUF metadata
want [outputDir </> "timestamp.json"]
-- This build the current index entry for all packages
action $ do
pkgIds <- getPackages GetPackages
need
[ outputDir </> "index" </> unPackageName pkgName </> prettyShow pkgVersion </> unPackageName pkgName <.> "cabal"
| PackageIdentifier pkgName pkgVersion <- pkgIds
]
--
-- timestamp.json
--
outputDir </> "timestamp.json" %> \path -> do
snapshotInfo <- computeFileInfoSimple' (outputDir </> "snapshot.json")
expires <- getExpiryTime GetExpiryTime
let timestamp =
Timestamp
{ timestampVersion = FileVersion 1,
timestampExpires = FileExpires expires,
timestampInfoSnapshot = snapshotInfo
}
keys <- readKeysAt' "timestamp"
let timestampSigned = withSignatures hackageRepoLayout keys timestamp
traced "writing" $
liftIO $ do
p <- makeAbsolute (fromFilePath path)
writeJSON hackageRepoLayout p timestampSigned
--
-- snapshot.json
--
outputDir </> "snapshot.json" %> \path -> do
rootInfo <- computeFileInfoSimple' (outputDir </> "root.json")
mirrorsInfo <- computeFileInfoSimple' (outputDir </> "mirrors.json")
tarInfo <- computeFileInfoSimple' (outputDir </> "01-index.tar")
tarGzInfo <- computeFileInfoSimple' (outputDir </> "01-index.tar.gz")
expires <- getExpiryTime GetExpiryTime
let snapshot =
Snapshot
{ snapshotVersion = FileVersion 1,
snapshotExpires = FileExpires expires,
snapshotInfoRoot = rootInfo,
snapshotInfoMirrors = mirrorsInfo,
snapshotInfoTar = Just tarInfo,
snapshotInfoTarGz = tarGzInfo
}
keys <- readKeysAt' "snapshot"
let snapshotSigned = withSignatures hackageRepoLayout keys snapshot
traced "writing" $
liftIO $ do
p <- makeAbsolute (fromFilePath path)
writeJSON hackageRepoLayout p snapshotSigned
--
-- root.json
--
outputDir </> "root.json" %> \path -> do
expires <- getExpiryTime GetExpiryTime
privateKeysRoot <- readKeysAt' "root"
privateKeysTarget <- readKeysAt' "target"
privateKeysSnapshot <- readKeysAt' "snapshot"
privateKeysTimestamp <- readKeysAt' "timestamp"
privateKeysMirrors <- readKeysAt' "mirrors"
let root =
Root
{ rootVersion = FileVersion 1,
rootExpires = FileExpires expires,
rootKeys =
fromKeys $
concat
[ privateKeysRoot,
privateKeysTarget,
privateKeysSnapshot,
privateKeysTimestamp,
privateKeysMirrors
],
rootRoles =
RootRoles
{ rootRolesRoot =
RoleSpec
{ roleSpecKeys = map somePublicKey privateKeysRoot,
roleSpecThreshold = KeyThreshold 2
},
rootRolesSnapshot =
RoleSpec
{ roleSpecKeys = map somePublicKey privateKeysSnapshot,
roleSpecThreshold = KeyThreshold 1
},
rootRolesTargets =
RoleSpec
{ roleSpecKeys = map somePublicKey privateKeysTarget,
roleSpecThreshold = KeyThreshold 1
},
rootRolesTimestamp =
RoleSpec
{ roleSpecKeys = map somePublicKey privateKeysTimestamp,
roleSpecThreshold = KeyThreshold 1
},
rootRolesMirrors =
RoleSpec
{ roleSpecKeys = map somePublicKey privateKeysMirrors,
roleSpecThreshold = KeyThreshold 1
}
}
}
keys <- readKeysAt' "root"
let signedRoot = withSignatures hackageRepoLayout keys root
traced "writing" $
liftIO $ do
p <- makeAbsolute (fromFilePath path)
writeJSON hackageRepoLayout p signedRoot
--
-- mirrors.json
--
outputDir </> "mirrors.json" %> \path -> do
expires <- getExpiryTime GetExpiryTime
let mirrors =
Mirrors
{ mirrorsVersion = FileVersion 1,
mirrorsExpires = FileExpires expires,
mirrorsMirrors = []
}
keys <- readKeysAt' "mirrors"
let signedMirrors = withSignatures hackageRepoLayout keys mirrors
traced "writing" $
liftIO $ do
p <- makeAbsolute (fromFilePath path)
writeJSON hackageRepoLayout p signedMirrors
--
-- 01-index.tar
--
outputDir </> "01-index.tar" %> \path -> do
pkgIds <- getPackages GetPackages
entries <-
flip foldMap pkgIds $ \pkgId -> do
let PackageIdentifier {pkgName, pkgVersion} = pkgId
PackageVersionMeta {packageVersionTimestamp, packageVersionRevisions} <- getPackageVersionMeta (GetPackageVersionMeta pkgId)
let name = unPackageName pkgName
let version = prettyShow pkgVersion
srcDir <- preparePackageSource $ PreparePackageSource pkgId
now <- getCurrentTime GetCurrentTime
-- original cabal file
cabalEntry <-
mkTarEntry
(srcDir </> name <.> "cabal")
(name </> version </> name <.> "cabal")
(fromMaybe now packageVersionTimestamp)
-- package.json
packageEntry <-
mkTarEntry
(outputDir </> "index" </> name </> version </> "package.json")
(name </> version </> "package.json")
(fromMaybe now packageVersionTimestamp)
-- revised cabal files
revisionEntries <- for packageVersionRevisions $ \RevisionMeta {revisionNumber, revisionTimestamp} ->
mkTarEntry
(inputDir </> name </> version </> "revisions" </> show revisionNumber <.> "cabal")
(name </> version </> name <.> "cabal")
revisionTimestamp
return $ cabalEntry : packageEntry : revisionEntries
traced "writing" $ liftIO $ BSL.writeFile path $ Tar.write $ sortOn Tar.entryTime entries
--
-- 01-index.tar.gz
--
outputDir </> "01-index.tar.gz" %> \path -> do
tar <- readFileByteStringLazy (outputDir </> "01-index.tar")
traced "writing" $ liftIO $ BSL.writeFile path $ GZip.compress tar
--
-- index cabal files
--
-- these come either from the package source or the revision files
--
outputDir </> "index/*/*/*.cabal" %> \path -> do
let [_, _, pkgName, pkgVersion, _] = splitDirectories (drop (length outputDir) path)
let Just name = simpleParsec pkgName
let Just version = simpleParsec pkgVersion
let pkgId = PackageIdentifier name version
cabalFile <- getPackageDescription (GetPackageDescription pkgId)
copyFileChanged cabalFile path
--
-- index package files (only depends on the source distribution)
--
outputDir </> "index/*/*/package.json" %> \path -> do
let [_, _, pkgName, pkgVersion, _] = splitDirectories (drop (length outputDir) path)
let packagePath = "package" </> pkgName <> "-" <> pkgVersion <.> "tar.gz"
let targetPath = rootPath $ fromUnrootedFilePath packagePath
targetFileInfo <- computeFileInfoSimple' (outputDir </> packagePath)
expires <- getExpiryTime GetExpiryTime
let targets =
Targets
{ targetsVersion = FileVersion 1,
targetsExpires = FileExpires expires,
targetsTargets = fromList [(TargetPathRepo targetPath, targetFileInfo)],
targetsDelegations = Nothing
}
keys <- readKeysAt' "target"
let signedTargets = withSignatures hackageRepoLayout keys targets
liftIO $ do
p <- makeAbsolute (fromFilePath path)
writeJSON hackageRepoLayout p signedTargets
--
-- source distributions, including patching
--
outputDir </> "package/*.tar.gz" %> \path -> do
let [_, _, filename] = splitDirectories (drop (length outputDir) path)
let Just pkgId = stripExtension "tar.gz" filename >>= simpleParsec
cabalFile <- getPackageDescription $ GetPackageDescription pkgId
srcDir <- preparePackageSource $ PreparePackageSource pkgId
traced "cabal sdist" $ do
gpd <- readGenericPackageDescription Verbosity.normal cabalFile
packageDirToSdist Verbosity.normal gpd srcDir >>= BSL.writeFile path
putStrLn $ "All done. The repository is now available in " <> outputDir <> "."
mkTarEntry :: FilePath -> [Char] -> UTCTime -> Action Tar.Entry
mkTarEntry filePath indexPath timestamp = do
let Right tarPath = Tar.toTarPath False indexPath
contents <- readFileByteStringLazy filePath
return
(Tar.fileEntry tarPath contents)
{ Tar.entryTime = floor $ Time.utcTimeToPOSIXSeconds timestamp,
Tar.entryOwnership =
Tar.Ownership
{ Tar.ownerName = "foliage",
Tar.groupName = "foliage",
Tar.ownerId = 0,
Tar.groupId = 0
}
}
applyPatches :: [Char] -> FilePath -> PackageId -> Action ()
applyPatches inputDir srcDir PackageIdentifier {pkgName, pkgVersion} = do
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"
forcePackageVersion :: FilePath -> PackageId -> Action ()
forcePackageVersion srcDir PackageIdentifier {pkgName, pkgVersion} = do
let cabalFilePath = srcDir </> unPackageName pkgName <.> "cabal"
liftIO $ rewritePackageVersion cabalFilePath pkgVersion
anchorPath :: Path Absolute -> (RepoLayout -> RepoPath) -> FilePath
anchorPath outputDirRoot p =
toFilePath $ anchorRepoPathLocally outputDirRoot $ p hackageRepoLayout

View File

@ -11,11 +11,11 @@ module Foliage.HackageSecurity
where
import Control.Monad (replicateM_)
import Data.Functor.Identity
import Data.ByteString.Lazy qualified as BSL
import Hackage.Security.Key.Env (fromKeys)
import Hackage.Security.Server
import Hackage.Security.TUF.FileMap
import Hackage.Security.Util.Path (fromFilePath, fromUnrootedFilePath, makeAbsolute, rootPath)
import Hackage.Security.Util.Path (Absolute, Path, fromFilePath, fromUnrootedFilePath, makeAbsolute, rootPath, writeLazyByteString)
import Hackage.Security.Util.Some
import System.Directory (createDirectoryIfMissing)
import System.FilePath
@ -25,11 +25,6 @@ readJSONSimple fp = do
p <- makeAbsolute (fromFilePath fp)
readJSON_NoKeys_NoLayout p
writeJSONSimple :: ToJSON Identity a => FilePath -> a -> IO ()
writeJSONSimple fp a = do
p <- makeAbsolute (fromFilePath fp)
writeJSON_NoLayout p a
computeFileInfoSimple :: FilePath -> IO FileInfo
computeFileInfoSimple fp = do
p <- makeAbsolute (fromFilePath fp)
@ -56,3 +51,9 @@ writeKey :: FilePath -> Some Key -> IO ()
writeKey fp key = do
p <- makeAbsolute (fromFilePath fp)
writeJSON_NoLayout p key
renderSignedJSON :: ToJSON WriteJSON a => [Some Key] -> a -> BSL.ByteString
renderSignedJSON keys thing =
renderJSON
hackageRepoLayout
(withSignatures hackageRepoLayout keys thing)

View File

@ -0,0 +1,90 @@
{-# 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 GHC.Generics
import System.Directory qualified as IO
import System.FilePath ((<.>), (</>))
data PrepareSource = PrepareSource PackageId PackageVersionMeta
deriving (Show, Eq, Generic)
deriving (Hashable, Binary, NFData)
type instance RuleResult PrepareSource = FilePath
prepareSource :: PackageId -> PackageVersionMeta -> Action FilePath
prepareSource pkgId pkgMeta = apply1 $ PrepareSource pkgId pkgMeta
addPrepareSourceRule :: FilePath -> FilePath -> Rules ()
addPrepareSourceRule inputDir cacheDir = addBuiltinRule noLint noIdentity run
where
run :: BuiltinRun PrepareSource FilePath
run (PrepareSource pkgId pkgMeta) _old mode = do
let PackageIdentifier {pkgName, pkgVersion} = pkgId
let PackageVersionMeta {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]
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

View File

@ -2,9 +2,8 @@
{-# LANGUAGE TypeFamilies #-}
module Foliage.RemoteAsset
( remoteAssetNeed,
remoteAssetRule,
addBuiltinRemoteAssetRule,
( fetchRemoteAsset,
addFetchRemoteAssetRule,
)
where
@ -27,16 +26,11 @@ newtype RemoteAsset = RemoteAsset Url
type instance RuleResult RemoteAsset = FilePath
data RemoteAssetRule = RemoteAssetRule RemoteAsset (Action FilePath)
fetchRemoteAsset :: Url -> Action FilePath
fetchRemoteAsset = apply1 . RemoteAsset
remoteAssetRule :: Url -> Action FilePath -> Rules ()
remoteAssetRule url act = addUserRule $ RemoteAssetRule (RemoteAsset url) act
remoteAssetNeed :: Url -> Action FilePath
remoteAssetNeed = apply1 . RemoteAsset
addBuiltinRemoteAssetRule :: FilePath -> Rules ()
addBuiltinRemoteAssetRule cacheDir = addBuiltinRule noLint noIdentity run
addFetchRemoteAssetRule :: FilePath -> Rules ()
addFetchRemoteAssetRule cacheDir = addBuiltinRule noLint noIdentity run
where
run :: BuiltinRun RemoteAsset FilePath
run (RemoteAsset url) old _mode = do

View File

@ -1,12 +1,13 @@
{-# LANGUAGE FlexibleContexts #-}
module Foliage.Shake
( computeFileInfoSimple',
readFileByteStringLazy,
readKeysAt,
readPackageVersionMeta',
writeSignedJSON,
)
where
import Data.ByteString.Lazy qualified as BSL
import Data.Traversable (for)
import Development.Shake
import Development.Shake.FilePath
@ -18,9 +19,6 @@ computeFileInfoSimple' fp = do
need [fp]
liftIO $ computeFileInfoSimple fp
readFileByteStringLazy :: FilePath -> Action BSL.ByteString
readFileByteStringLazy x = need [x] >> liftIO (BSL.readFile x)
readKeysAt :: FilePath -> Action [Some Key]
readKeysAt base = do
paths <- getDirectoryFiles base ["*.json"]
@ -33,3 +31,10 @@ readPackageVersionMeta' :: FilePath -> Action PackageVersionMeta
readPackageVersionMeta' fp = do
need [fp]
liftIO $ readPackageVersionMeta fp
writeSignedJSON :: ToJSON WriteJSON a => Path Absolute -> (RepoLayout -> RepoPath) -> [Some Key] -> a -> Action ()
writeSignedJSON outputDirRoot repoPath keys thing = do
putInfo $ "Writing " ++ show (repoPath hackageRepoLayout)
liftIO $ writeLazyByteString fp $ renderSignedJSON keys thing
where
fp = anchorRepoPathLocally outputDirRoot $ repoPath hackageRepoLayout

View File

@ -1,66 +0,0 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TypeFamilies #-}
module Foliage.Shake.Oracle
( UTCTime,
GetCurrentTime (..),
GetExpiryTime (..),
GetPackageDescription (..),
GetPackages (..),
GetPackageVersionMeta (..),
GetSignOptions (..),
PreparePackageSource (..),
)
where
import Data.Time.Compat ()
import Development.Shake (RuleResult)
import Development.Shake.Classes (Binary, Hashable, NFData)
import Distribution.Types.PackageId (PackageId)
import Foliage.Meta
import Foliage.Options (SignOptions)
import GHC.Generics (Generic)
data GetCurrentTime = GetCurrentTime
deriving (Show, Eq, Generic)
deriving anyclass (Binary, Hashable, NFData)
type instance RuleResult GetCurrentTime = UTCTime
data GetExpiryTime = GetExpiryTime
deriving (Show, Eq, Generic)
deriving anyclass (Binary, Hashable, NFData)
type instance RuleResult GetExpiryTime = Maybe UTCTime
data GetSignOptions = GetSignOptions
deriving (Show, Eq, Generic)
deriving anyclass (Binary, Hashable, NFData)
type instance RuleResult GetSignOptions = SignOptions
data GetPackages = GetPackages
deriving (Show, Eq, Generic)
deriving anyclass (Binary, Hashable, NFData)
type instance RuleResult GetPackages = [PackageId]
newtype GetPackageVersionMeta = GetPackageVersionMeta PackageId
deriving (Show, Eq, Generic)
deriving anyclass (Binary, Hashable, NFData)
type instance RuleResult GetPackageVersionMeta = PackageVersionMeta
newtype PreparePackageSource = PreparePackageSource PackageId
deriving (Show, Eq, Generic)
deriving anyclass (Binary, Hashable, NFData)
type instance RuleResult PreparePackageSource = FilePath
newtype GetPackageDescription = GetPackageDescription PackageId
deriving (Show, Eq, Generic)
deriving anyclass (Binary, Hashable, NFData)
type instance RuleResult GetPackageDescription = FilePath

View File

@ -21,6 +21,7 @@
};
shell.buildInputs = with pkgs; [
nixpkgs-fmt
fsatrace
];
modules = [{
packages.foliage.components.exes.foliage.dontStrip = false;
@ -28,9 +29,11 @@
};
in {
packages.default = project.foliage.components.exes.foliage;
devShell = pkgs.mkShell {
name = "foliage-dev-shell";
buildInputs = with pkgs; [
fsatrace
];
};
});

View File

@ -22,9 +22,9 @@ executable foliage
Foliage.HackageSecurity
Foliage.Meta
Foliage.Options
Foliage.PrepareSource
Foliage.RemoteAsset
Foliage.Shake
Foliage.Shake.Oracle
Foliage.Time
Foliage.UpdateCabalFile