mirror of
https://github.com/input-output-hk/foliage.git
synced 2024-10-27 05:10:36 +03:00
WIP
This commit is contained in:
parent
3b322622cb
commit
095b3cf76e
30
app/Codec/Archive/Tar/Entry/Orphans.hs
Normal file
30
app/Codec/Archive/Tar/Entry/Orphans.hs
Normal file
@ -0,0 +1,30 @@
|
|||||||
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||||
|
|
||||||
|
module Codec.Archive.Tar.Entry.Orphans where
|
||||||
|
|
||||||
|
import Codec.Archive.Tar.Entry
|
||||||
|
import Data.Hashable (hashUsing)
|
||||||
|
import Development.Shake.Classes
|
||||||
|
import GHC.Generics (Generic)
|
||||||
|
import System.Posix.Types (CMode)
|
||||||
|
|
||||||
|
instance Hashable CMode where
|
||||||
|
hashWithSalt = hashUsing fromEnum
|
||||||
|
|
||||||
|
deriving instance Generic Entry
|
||||||
|
instance Hashable Entry
|
||||||
|
|
||||||
|
deriving instance Generic EntryContent
|
||||||
|
instance Hashable EntryContent
|
||||||
|
|
||||||
|
deriving instance Generic Format
|
||||||
|
instance Hashable Format
|
||||||
|
|
||||||
|
deriving instance Generic Ownership
|
||||||
|
instance Hashable Ownership
|
||||||
|
|
||||||
|
instance Hashable LinkTarget where
|
||||||
|
hashWithSalt = hashUsing fromLinkTarget
|
||||||
|
|
||||||
|
instance Hashable TarPath where
|
||||||
|
hashWithSalt = hashUsing fromTarPath
|
@ -10,6 +10,7 @@ module Foliage.CmdBuild (cmdBuild) where
|
|||||||
|
|
||||||
import Codec.Archive.Tar qualified as Tar
|
import Codec.Archive.Tar qualified as Tar
|
||||||
import Codec.Archive.Tar.Entry qualified as Tar
|
import Codec.Archive.Tar.Entry qualified as Tar
|
||||||
|
import Codec.Archive.Tar.Entry.Orphans ()
|
||||||
import Codec.Compression.GZip qualified as GZip
|
import Codec.Compression.GZip qualified as GZip
|
||||||
import Control.Monad (unless, when, (>=>))
|
import Control.Monad (unless, when, (>=>))
|
||||||
import Data.Aeson qualified as Aeson
|
import Data.Aeson qualified as Aeson
|
||||||
@ -24,38 +25,73 @@ import Distribution.Package
|
|||||||
import Distribution.Pretty (prettyShow)
|
import Distribution.Pretty (prettyShow)
|
||||||
import Distribution.Version
|
import Distribution.Version
|
||||||
import Foliage.FetchURL (addFetchURLRule)
|
import Foliage.FetchURL (addFetchURLRule)
|
||||||
import Foliage.HackageSecurity hiding (ToJSON, toJSON)
|
import Foliage.HackageSecurity (
|
||||||
|
ExpiryTime (..),
|
||||||
|
addExpiryTimeOracle,
|
||||||
|
addSigninigKeysOracle,
|
||||||
|
computeFileInfoSimple,
|
||||||
|
createKeys,
|
||||||
|
mkMirrors,
|
||||||
|
mkRoot,
|
||||||
|
mkSnapshot,
|
||||||
|
mkTimestamp,
|
||||||
|
readKeys,
|
||||||
|
renderSignedJSON,
|
||||||
|
(~/~),
|
||||||
|
)
|
||||||
import Foliage.Meta qualified as Meta
|
import Foliage.Meta qualified as Meta
|
||||||
import Foliage.Meta.Aeson ()
|
import Foliage.Meta.Aeson ()
|
||||||
import Foliage.Options
|
import Foliage.Options
|
||||||
import Foliage.Oracles
|
import Foliage.Oracles
|
||||||
import Foliage.Pages
|
import Foliage.Pages
|
||||||
import Foliage.TUF as TUF (
|
import Hackage.Security.Server (
|
||||||
mkMirrors,
|
FileExpires (..),
|
||||||
mkRoot,
|
FileVersion (..),
|
||||||
mkSnapshot,
|
IndexFile (..),
|
||||||
mkTimestamp,
|
IndexLayout (..),
|
||||||
|
RepoLayout (..),
|
||||||
|
TargetPath (..),
|
||||||
|
Targets (..),
|
||||||
|
hackageIndexLayout,
|
||||||
|
hackageRepoLayout,
|
||||||
)
|
)
|
||||||
|
|
||||||
import Data.ByteString.Lazy qualified as BSL
|
import Data.ByteString.Lazy qualified as BSL
|
||||||
import Data.Function ((&))
|
import Data.Function ((&))
|
||||||
|
import Data.HashMap.Strict qualified as HM
|
||||||
import Data.Maybe (fromJust, fromMaybe, isJust, listToMaybe, mapMaybe)
|
import Data.Maybe (fromJust, fromMaybe, isJust, listToMaybe, mapMaybe)
|
||||||
import Data.Traversable (for)
|
import Data.Traversable (for)
|
||||||
|
import Development.Shake.Classes
|
||||||
|
import Development.Shake.Config (usingConfig)
|
||||||
import Distribution.Client.SrcDist (packageDirToSdist)
|
import Distribution.Client.SrcDist (packageDirToSdist)
|
||||||
import Distribution.Parsec (simpleParsec)
|
import Distribution.Parsec (simpleParsec)
|
||||||
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
|
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
|
||||||
import Distribution.Utils.Generic (sndOf3)
|
import Distribution.Utils.Generic (sndOf3)
|
||||||
import Distribution.Verbosity qualified as Verbosity
|
import Distribution.Verbosity qualified as Verbosity
|
||||||
import Foliage.Meta (DeprecationSpec (..), PackageVersionSpec (..), RevisionSpec (..))
|
import Foliage.Meta (DeprecationSpec (..), PackageVersionSpec (..), RevisionSpec (..))
|
||||||
import Foliage.PrepareSdist (prepareSource)
|
import Foliage.SourceDist (applyPatches, fetchPackageVersion, updateCabalFileVersion)
|
||||||
import Foliage.Time qualified as Time
|
import Foliage.Time qualified as Time
|
||||||
|
import Hackage.Security.TUF.FileMap qualified as FM
|
||||||
import Hackage.Security.Util.Path qualified as Sec
|
import Hackage.Security.Util.Path qualified as Sec
|
||||||
import System.Directory qualified as IO
|
import System.Directory qualified as IO
|
||||||
|
import Text.Read (readMaybe)
|
||||||
|
|
||||||
cmdBuild :: BuildOptions -> IO ()
|
cmdBuild :: BuildOptions -> IO ()
|
||||||
cmdBuild buildOptions = do
|
cmdBuild buildOptions = do
|
||||||
let inputDir = buildOptsInputDir buildOptions
|
let
|
||||||
let outputDir = buildOptsOutputDir buildOptions
|
inputDir = buildOptsInputDir buildOptions
|
||||||
|
outputDir = buildOptsOutputDir buildOptions
|
||||||
|
cacheDir = "_cache"
|
||||||
|
opts =
|
||||||
|
shakeOptions
|
||||||
|
{ shakeFiles = cacheDir
|
||||||
|
, shakeChange = ChangeModtimeAndDigest
|
||||||
|
, shakeColor = True
|
||||||
|
, shakeLint = Just LintBasic
|
||||||
|
, shakeReport = ["report.html", "report.json"]
|
||||||
|
, shakeThreads = buildOptsNumThreads buildOptions
|
||||||
|
, shakeVerbosity = buildOptsVerbosity buildOptions
|
||||||
|
}
|
||||||
|
|
||||||
-- Create keys if needed
|
-- Create keys if needed
|
||||||
case buildOptsSignOpts buildOptions of
|
case buildOptsSignOpts buildOptions of
|
||||||
@ -67,9 +103,13 @@ cmdBuild buildOptions = do
|
|||||||
_otherwise -> pure ()
|
_otherwise -> pure ()
|
||||||
|
|
||||||
shake opts $ do
|
shake opts $ do
|
||||||
|
-- FIXME: maybe?
|
||||||
|
usingConfig $
|
||||||
|
HM.fromList
|
||||||
|
[ ("outputDir", buildOptsOutputDir buildOptions)
|
||||||
|
, ("cacheDir", cacheDir)
|
||||||
|
]
|
||||||
-- FIXME: consider using configuration variables (usingConfig/getConfig) or shakeExtra
|
-- FIXME: consider using configuration variables (usingConfig/getConfig) or shakeExtra
|
||||||
_ <- addOutputDirOracle (buildOptsOutputDir buildOptions)
|
|
||||||
_ <- addInputDirOracle (buildOptsInputDir buildOptions)
|
|
||||||
_ <- addCacheDirOracle cacheDir
|
_ <- addCacheDirOracle cacheDir
|
||||||
_ <- addExpiryTimeOracle (buildOptsExpireSignaturesOn buildOptions)
|
_ <- addExpiryTimeOracle (buildOptsExpireSignaturesOn buildOptions)
|
||||||
_ <- addCurrentTimeOracle (buildOptsCurrentTime buildOptions)
|
_ <- addCurrentTimeOracle (buildOptsCurrentTime buildOptions)
|
||||||
@ -79,18 +119,64 @@ cmdBuild buildOptions = do
|
|||||||
|
|
||||||
addFetchURLRule
|
addFetchURLRule
|
||||||
|
|
||||||
let cacheSrcDir PackageIdentifier{pkgName, pkgVersion} = cacheDir </> unPackageName pkgName </> prettyShow pkgVersion
|
|
||||||
|
|
||||||
readPackageVersionSpec <- newCache $ \path -> do
|
readPackageVersionSpec <- newCache $ \path -> do
|
||||||
need [path]
|
need [path]
|
||||||
meta <- liftIO $ Meta.readPackageVersionSpec path
|
meta <- liftIO $ Meta.readPackageVersionSpec path
|
||||||
validateMeta path meta
|
validateMeta path meta
|
||||||
return meta
|
return meta
|
||||||
|
|
||||||
allPkgSpecs <- do
|
action $ do
|
||||||
cache <- newCache $ const $ do
|
need
|
||||||
metaFiles <- getDirectoryFiles inputDir ["*/*/meta.toml"]
|
[ outputDir </> "mirrors.json"
|
||||||
|
, outputDir </> "root.json"
|
||||||
|
, outputDir </> "snapshot.json"
|
||||||
|
, outputDir </> "timestamp.json"
|
||||||
|
]
|
||||||
|
|
||||||
|
let metaFileForPkgId :: PackageIdentifier -> FilePath
|
||||||
|
metaFileForPkgId PackageIdentifier{pkgName, pkgVersion} =
|
||||||
|
inputDir </> unPackageName pkgName </> prettyShow pkgVersion </> "meta.toml"
|
||||||
|
|
||||||
|
let cabalFileForPkgId :: PackageIdentifier -> FilePath
|
||||||
|
cabalFileForPkgId PackageIdentifier{pkgName, pkgVersion} =
|
||||||
|
cacheDir </> unPackageName pkgName </> prettyShow pkgVersion </> unPackageName pkgName <.> "cabal"
|
||||||
|
|
||||||
|
let cabalFileRevisionForPkgId :: PackageIdentifier -> Int -> FilePath
|
||||||
|
cabalFileRevisionForPkgId pkgId revNum =
|
||||||
|
metaFileForPkgId pkgId `replaceBaseName` "revisions" </> show revNum <.> "cabal"
|
||||||
|
|
||||||
|
--
|
||||||
|
--
|
||||||
|
--
|
||||||
|
|
||||||
|
cacheDir </> "*/*/*.cabal"
|
||||||
|
~?~ ( \case
|
||||||
|
[name, version, name']
|
||||||
|
| Just pkgName <- simpleParsec name
|
||||||
|
, Just pkgVersion <- simpleParsec version
|
||||||
|
, name == name' ->
|
||||||
|
Just $ PackageIdentifier pkgName pkgVersion
|
||||||
|
_ -> Nothing
|
||||||
|
)
|
||||||
|
~~> \cabalFilePath pkgId -> do
|
||||||
|
let metaFile = metaFileForPkgId pkgId
|
||||||
|
pkgSpec <- readPackageVersionSpec metaFile
|
||||||
|
let PackageIdentifier{pkgVersion} = pkgId
|
||||||
|
PackageVersionSpec{packageVersionSource, packageVersionForce} = pkgSpec
|
||||||
|
|
||||||
|
fetchPackageVersion packageVersionSource (takeDirectory cabalFilePath)
|
||||||
|
|
||||||
|
applyPatches metaFile (takeDirectory cabalFilePath)
|
||||||
|
|
||||||
|
when packageVersionForce $ do
|
||||||
|
updateCabalFileVersion cabalFilePath pkgVersion
|
||||||
|
--
|
||||||
|
-- Index creation
|
||||||
|
--
|
||||||
|
|
||||||
|
getPkgSpecs <- do
|
||||||
|
getPkgSpecs' <- addOracleCache $ \PkgSpecs{} -> do
|
||||||
|
metaFiles <- getDirectoryFiles inputDir ["*/*/meta.toml"]
|
||||||
when (null metaFiles) $ do
|
when (null metaFiles) $ do
|
||||||
error $
|
error $
|
||||||
unlines
|
unlines
|
||||||
@ -107,82 +193,52 @@ cmdBuild buildOptions = do
|
|||||||
pkgSpec <- readPackageVersionSpec (inputDir </> path)
|
pkgSpec <- readPackageVersionSpec (inputDir </> path)
|
||||||
return (inputDir </> path, pkgId, pkgSpec)
|
return (inputDir </> path, pkgId, pkgSpec)
|
||||||
_ -> error "the impossible happened"
|
_ -> error "the impossible happened"
|
||||||
|
return $ getPkgSpecs' $ PkgSpecs ()
|
||||||
|
|
||||||
return $ cache ()
|
indexEntries <- do
|
||||||
|
getIndexEntries <- newCache $ \IndexEntries{} -> do
|
||||||
|
pkgSpecs <- getPkgSpecs
|
||||||
|
cabalEntries <- makeCabalEntries cabalFileForPkgId pkgSpecs
|
||||||
|
metadataEntries <- makeMetadataEntries outputDir pkgSpecs
|
||||||
|
let extraEntries = makeExtraEntries pkgSpecs
|
||||||
|
|
||||||
action $ do
|
-- WARN: See note on `makeCabalEntries`, the sorting here has to be stable
|
||||||
need
|
return $ sortOn Tar.entryTime (cabalEntries ++ metadataEntries ++ extraEntries)
|
||||||
[ outputDir </> "mirrors.json"
|
-- Return the oracle function applied to IndexEntries ()
|
||||||
, outputDir </> "root.json"
|
return $ getIndexEntries $ IndexEntries ()
|
||||||
, outputDir </> "snapshot.json"
|
|
||||||
, outputDir </> "timestamp.json"
|
|
||||||
]
|
|
||||||
-- allPkgSpecs >>= traverse $ \(metaFile, pkgId, pkgSpec) -> do
|
|
||||||
|
|
||||||
--
|
--
|
||||||
|
-- Rules for core repository functionality
|
||||||
--
|
--
|
||||||
--
|
coreRules outputDir cabalFileForPkgId indexEntries
|
||||||
|
|
||||||
( (cacheDir </> "*/*/*.cabal") `matching` \case
|
|
||||||
[name, version, name']
|
|
||||||
| Just pkgName <- simpleParsec name
|
|
||||||
, Just pkgVersion <- simpleParsec version
|
|
||||||
, name == name' ->
|
|
||||||
Just $ PackageIdentifier pkgName pkgVersion
|
|
||||||
_ -> Nothing
|
|
||||||
)
|
|
||||||
~~> \path pkgId@PackageIdentifier{pkgName, pkgVersion} -> do
|
|
||||||
let metaFile = inputDir </> unPackageName pkgName </> prettyShow pkgVersion </> "meta.toml"
|
|
||||||
pkgSpec <- readPackageVersionSpec metaFile
|
|
||||||
prepareSource metaFile pkgId pkgSpec (takeDirectory path)
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Core
|
|
||||||
--
|
|
||||||
|
|
||||||
outputDir </> "mirrors.json" %> TUF.mkMirrors
|
|
||||||
outputDir </> "root.json" %> TUF.mkRoot
|
|
||||||
outputDir </> "snapshot.json" %> TUF.mkSnapshot
|
|
||||||
outputDir </> "timestamp.json" %> TUF.mkTimestamp
|
|
||||||
outputDir </> "01-index.tar" %> \path ->
|
|
||||||
allPkgSpecs >>= makeIndexEntries cacheSrcDir >>= liftIO . BL.writeFile path . Tar.write
|
|
||||||
outputDir </> "01-index.tar.gz" %> \path ->
|
|
||||||
allPkgSpecs >>= makeIndexEntries cacheSrcDir >>= liftIO . BL.writeFile path . GZip.compress . Tar.write
|
|
||||||
|
|
||||||
( (outputDir </> "package/*.tar.gz") `matching` \case
|
|
||||||
[pkgId] -> simpleParsec pkgId
|
|
||||||
_ -> Nothing
|
|
||||||
)
|
|
||||||
~~> \path pkgId@PackageIdentifier{pkgName} -> do
|
|
||||||
let srcDir = cacheSrcDir pkgId
|
|
||||||
need [srcDir </> unPackageName pkgName <.> "cabal"]
|
|
||||||
pkgDesc <- liftIO $ readGenericPackageDescription Verbosity.silent (srcDir </> unPackageName pkgName <.> "cabal")
|
|
||||||
liftIO $ packageDirToSdist Verbosity.normal pkgDesc srcDir >>= BSL.writeFile path
|
|
||||||
|
|
||||||
alternatives $ do
|
alternatives $ do
|
||||||
( (outputDir </> "package/*/revision/0.cabal") `matching` \case
|
outputDir </> "package/*/revision/0.cabal"
|
||||||
[pkgId] -> simpleParsec pkgId
|
~?~ ( \case
|
||||||
_ -> Nothing
|
[pkgId] -> simpleParsec pkgId
|
||||||
)
|
_ -> Nothing
|
||||||
~~> \path pkgId@PackageIdentifier{pkgName} ->
|
)
|
||||||
copyFileChanged (cacheSrcDir pkgId <.> unPackageName pkgName <.> "cabal") path
|
~~> \path pkgId ->
|
||||||
|
copyFileChanged (cabalFileForPkgId pkgId) path
|
||||||
|
|
||||||
( (outputDir </> "package/*/revision/*.cabal") `matching` \case
|
outputDir </> "package/*/revision/*.cabal"
|
||||||
[pkgId, revNum] -> (,) <$> simpleParsec pkgId <*> return revNum
|
~?~ ( \case
|
||||||
_ -> Nothing
|
[pkgId, revNum] -> (,) <$> simpleParsec pkgId <*> readMaybe revNum
|
||||||
)
|
_ -> Nothing
|
||||||
~~> \path (PackageIdentifier{pkgName, pkgVersion}, revNum) ->
|
)
|
||||||
copyFileChanged (inputDir </> unPackageName pkgName </> prettyShow pkgVersion </> "revision" </> revNum <.> "cabal") path
|
~~> \path (pkgId, revNum) ->
|
||||||
|
copyFileChanged (cabalFileRevisionForPkgId pkgId revNum) path
|
||||||
|
|
||||||
( (outputDir </> "package/*/*.cabal") `matching` \case
|
outputDir </> "package/*/*.cabal"
|
||||||
[pkgIdStr, pkgName']
|
~?~ ( \case
|
||||||
| Just pkgId <- simpleParsec pkgIdStr
|
[pkgIdStr, pkgName']
|
||||||
, unPackageName (pkgName pkgId) == pkgName' ->
|
| Just pkgId <- simpleParsec pkgIdStr
|
||||||
Just pkgId
|
, unPackageName (pkgName pkgId) == pkgName' ->
|
||||||
_ -> Nothing
|
Just pkgId
|
||||||
)
|
_ -> Nothing
|
||||||
~~> \path pkgId@PackageIdentifier{pkgName} ->
|
)
|
||||||
copyFileChanged (cacheSrcDir pkgId </> unPackageName pkgName <.> "cabal") path
|
~~> \path pkgId ->
|
||||||
|
copyFileChanged (cabalFileForPkgId pkgId) path
|
||||||
|
|
||||||
--
|
--
|
||||||
-- Foliage metadata
|
-- Foliage metadata
|
||||||
@ -190,66 +246,78 @@ cmdBuild buildOptions = do
|
|||||||
|
|
||||||
-- only require this when requested? the rule is always valid
|
-- only require this when requested? the rule is always valid
|
||||||
-- when (buildOptsWriteMetadata buildOptions) $
|
-- when (buildOptsWriteMetadata buildOptions) $
|
||||||
outputDir </> "foliage/packages.json" %> \path ->
|
outputDir </> "foliage/packages.json"
|
||||||
allPkgSpecs >>= makeMetadataFile path
|
%> \path ->
|
||||||
|
getPkgSpecs >>= makeMetadataFile path
|
||||||
|
|
||||||
--
|
--
|
||||||
-- Pages
|
-- Pages
|
||||||
--
|
--
|
||||||
|
|
||||||
outputDir </> "index.html" %> makeIndexPage
|
outputDir </> "index.html"
|
||||||
|
%> makeIndexPage
|
||||||
|
|
||||||
outputDir </> "all-packages/index.html" %> \path ->
|
outputDir </> "all-packages/index.html"
|
||||||
allPkgSpecs >>= makeAllPackagesPage path
|
%> \path ->
|
||||||
|
getPkgSpecs >>= makeAllPackagesPage path
|
||||||
|
|
||||||
outputDir </> "all-package-versions/index.html" %> \path ->
|
outputDir </> "all-package-versions/index.html"
|
||||||
allPkgSpecs >>= makeAllPackageVersionsPage path
|
%> \path ->
|
||||||
|
getPkgSpecs >>= makeAllPackageVersionsPage path
|
||||||
|
|
||||||
( (outputDir </> "package/*/index.html") `matching` \case
|
outputDir </> "package/*/index.html"
|
||||||
[pkgId] -> simpleParsec pkgId
|
~?~ ( \case
|
||||||
_ -> Nothing
|
[pkgId] -> simpleParsec pkgId
|
||||||
)
|
_ -> Nothing
|
||||||
~~> \path pkgId@PackageIdentifier{pkgName, pkgVersion} -> do
|
)
|
||||||
let metaFile = inputDir </> unPackageName pkgName </> prettyShow pkgVersion </> "meta.toml"
|
~~> \path pkgId -> do
|
||||||
|
let metaFile = metaFileForPkgId pkgId
|
||||||
pkgSpec <- readPackageVersionSpec metaFile
|
pkgSpec <- readPackageVersionSpec metaFile
|
||||||
pkgDesc <- liftIO $ readGenericPackageDescription Verbosity.silent (cacheSrcDir pkgId </> unPackageName pkgName <.> "cabal")
|
let cabalFile = cabalFileForPkgId pkgId
|
||||||
|
need [cabalFile]
|
||||||
|
pkgDesc <- liftIO $ readGenericPackageDescription Verbosity.silent cabalFile
|
||||||
makePackageVersionPage path pkgDesc pkgSpec
|
makePackageVersionPage path pkgDesc pkgSpec
|
||||||
where
|
|
||||||
infixr 3 ~~>
|
|
||||||
(~~>) :: (FilePath -> Maybe a) -> (FilePath -> a -> Action ()) -> Rules ()
|
|
||||||
parser ~~> act = isJust . parser ?> \path -> act path $ fromJust $ parser path
|
|
||||||
|
|
||||||
matching :: FilePattern -> ([String] -> Maybe a) -> FilePath -> Maybe a
|
coreRules :: FilePath -> (PackageIdentifier -> FilePath) -> Action [Tar.Entry] -> Rules ()
|
||||||
matching pattern parser = filePattern pattern >=> parser
|
coreRules outputDir cabalFileForPkgId indexEntries = do
|
||||||
|
outputDir ~/~ repoLayoutMirrors
|
||||||
|
%> mkMirrors
|
||||||
|
|
||||||
cacheDir = "_cache"
|
outputDir ~/~ repoLayoutRoot
|
||||||
opts =
|
%> mkRoot
|
||||||
shakeOptions
|
|
||||||
{ shakeFiles = cacheDir
|
|
||||||
, shakeChange = ChangeModtimeAndDigest
|
|
||||||
, shakeColor = True
|
|
||||||
, shakeLint = Just LintBasic
|
|
||||||
, shakeReport = ["report.html", "report.json"]
|
|
||||||
, shakeThreads = buildOptsNumThreads buildOptions
|
|
||||||
, shakeVerbosity = buildOptsVerbosity buildOptions
|
|
||||||
}
|
|
||||||
|
|
||||||
makeIndexEntries :: (PackageId -> FilePath) -> [(FilePath, PackageId, PackageVersionSpec)] -> Action [Tar.Entry]
|
outputDir ~/~ repoLayoutSnapshot
|
||||||
makeIndexEntries cacheSrcDir allPkgSpecs = do
|
%> mkSnapshot outputDir
|
||||||
cabalEntries <- makeCabalEntries cacheSrcDir allPkgSpecs
|
|
||||||
metadataEntries <- makeMetadataEntries allPkgSpecs
|
|
||||||
let extraEntries = makeExtraEntries allPkgSpecs
|
|
||||||
|
|
||||||
-- WARN: See note on `makeCabalEntries`, the sorting here has to be stable
|
outputDir ~/~ repoLayoutTimestamp
|
||||||
return $ sortOn Tar.entryTime (cabalEntries ++ metadataEntries ++ extraEntries)
|
%> mkTimestamp outputDir
|
||||||
|
|
||||||
|
outputDir ~/~ repoLayoutIndexTar
|
||||||
|
%> \path ->
|
||||||
|
indexEntries >>= liftIO . BL.writeFile path . Tar.write
|
||||||
|
|
||||||
|
outputDir ~/~ repoLayoutIndexTarGz
|
||||||
|
%> \path ->
|
||||||
|
indexEntries >>= liftIO . BL.writeFile path . GZip.compress . Tar.write
|
||||||
|
|
||||||
|
outputDir </> "package/*.tar.gz"
|
||||||
|
~?~ ( \case
|
||||||
|
[pkgId] -> simpleParsec pkgId
|
||||||
|
_ -> Nothing
|
||||||
|
)
|
||||||
|
~~> \path pkgId -> do
|
||||||
|
let cabalFilePath = cabalFileForPkgId pkgId
|
||||||
|
need [cabalFilePath]
|
||||||
|
pkgDesc <- liftIO $ readGenericPackageDescription Verbosity.silent cabalFilePath
|
||||||
|
liftIO $ packageDirToSdist Verbosity.normal pkgDesc (takeDirectory cabalFilePath) >>= BSL.writeFile path
|
||||||
|
|
||||||
makeCabalEntries :: (PackageId -> FilePath) -> [(FilePath, PackageId, PackageVersionSpec)] -> Action [Tar.Entry]
|
makeCabalEntries :: (PackageId -> FilePath) -> [(FilePath, PackageId, PackageVersionSpec)] -> Action [Tar.Entry]
|
||||||
makeCabalEntries cacheSrcDir allPkgSpecs = do
|
makeCabalEntries cabalFileForPkgId allPkgSpecs = do
|
||||||
currentTime <- askOracle CurrentTime
|
currentTime <- askOracle $ CurrentTime ()
|
||||||
allPkgSpecs
|
allPkgSpecs
|
||||||
& foldMap
|
& foldMap
|
||||||
( \(metaFile, pkgId, pkgSpec) -> do
|
( \(metaFile, pkgId, pkgSpec) -> do
|
||||||
let pkgCabalFile = cacheSrcDir pkgId </> unPackageName (pkgName pkgId) <.> "cabal"
|
let pkgCabalFile = cabalFileForPkgId pkgId
|
||||||
pkgTimestamp = fromMaybe currentTime (packageVersionTimestamp pkgSpec)
|
pkgTimestamp = fromMaybe currentTime (packageVersionTimestamp pkgSpec)
|
||||||
|
|
||||||
uploadEntry <- makeIndexPkgCabal pkgId pkgTimestamp pkgCabalFile
|
uploadEntry <- makeIndexPkgCabal pkgId pkgTimestamp pkgCabalFile
|
||||||
@ -264,11 +332,10 @@ makeCabalEntries cacheSrcDir allPkgSpecs = do
|
|||||||
return $ uploadEntry : revisionEntries
|
return $ uploadEntry : revisionEntries
|
||||||
)
|
)
|
||||||
|
|
||||||
makeMetadataEntries :: [(FilePath, PackageId, PackageVersionSpec)] -> Action [Tar.Entry]
|
makeMetadataEntries :: FilePath -> [(FilePath, PackageId, PackageVersionSpec)] -> Action [Tar.Entry]
|
||||||
makeMetadataEntries allPkgSpecs = do
|
makeMetadataEntries outputDir allPkgSpecs = do
|
||||||
currentTime <- askOracle CurrentTime
|
currentTime <- askOracle $ CurrentTime ()
|
||||||
expiryTime <- askOracle ExpiryTime
|
expiryTime <- askOracle $ ExpiryTime ()
|
||||||
outputDir <- askOracle OutputDir
|
|
||||||
|
|
||||||
targetKeys <- readKeys "target"
|
targetKeys <- readKeys "target"
|
||||||
|
|
||||||
@ -355,23 +422,16 @@ makeIndexPkgCabal pkgId timestamp filePath = do
|
|||||||
|
|
||||||
makeIndexPkgMetadata :: Maybe Meta.UTCTime -> PackageId -> FilePath -> Action Targets
|
makeIndexPkgMetadata :: Maybe Meta.UTCTime -> PackageId -> FilePath -> Action Targets
|
||||||
makeIndexPkgMetadata expiryTime pkgId sdistPath = do
|
makeIndexPkgMetadata expiryTime pkgId sdistPath = do
|
||||||
need [sdistPath]
|
targetFileInfo <- computeFileInfoSimple sdistPath
|
||||||
targetFileInfo <- liftIO $ computeFileInfoSimple' sdistPath
|
|
||||||
let packagePath = repoLayoutPkgTarGz hackageRepoLayout pkgId
|
let packagePath = repoLayoutPkgTarGz hackageRepoLayout pkgId
|
||||||
return
|
return
|
||||||
Targets
|
Targets
|
||||||
{ targetsVersion = FileVersion 1
|
{ targetsVersion = FileVersion 1
|
||||||
, targetsExpires = FileExpires expiryTime
|
, targetsExpires = FileExpires expiryTime
|
||||||
, targetsTargets = fromList [(TargetPathRepo packagePath, targetFileInfo)]
|
, targetsTargets = FM.fromList [(TargetPathRepo packagePath, targetFileInfo)]
|
||||||
, targetsDelegations = Nothing
|
, targetsDelegations = Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
duplicates :: (Ord a) => NE.NonEmpty a -> [a]
|
|
||||||
duplicates = mapMaybe (listToMaybe . NE.tail) . NE.group
|
|
||||||
|
|
||||||
doubleDeprecations :: NE.NonEmpty DeprecationSpec -> [NE.NonEmpty DeprecationSpec]
|
|
||||||
doubleDeprecations = filter ((> 1) . length) . NE.groupWith deprecationIsDeprecated
|
|
||||||
|
|
||||||
-- | TEMP
|
-- | TEMP
|
||||||
validateMeta :: (MonadFail m) => FilePath -> PackageVersionSpec -> m ()
|
validateMeta :: (MonadFail m) => FilePath -> PackageVersionSpec -> m ()
|
||||||
validateMeta metaFile PackageVersionSpec{..} = do
|
validateMeta metaFile PackageVersionSpec{..} = do
|
||||||
@ -430,6 +490,12 @@ validateMeta metaFile PackageVersionSpec{..} = do
|
|||||||
]
|
]
|
||||||
_otherwise ->
|
_otherwise ->
|
||||||
return ()
|
return ()
|
||||||
|
where
|
||||||
|
duplicates :: (Ord a) => NE.NonEmpty a -> [a]
|
||||||
|
duplicates = mapMaybe (listToMaybe . NE.tail) . NE.group
|
||||||
|
|
||||||
|
doubleDeprecations :: NE.NonEmpty DeprecationSpec -> [NE.NonEmpty DeprecationSpec]
|
||||||
|
doubleDeprecations = filter ((> 1) . length) . NE.groupWith deprecationIsDeprecated
|
||||||
|
|
||||||
mkTarEntry
|
mkTarEntry
|
||||||
:: BL.ByteString
|
:: BL.ByteString
|
||||||
@ -453,3 +519,17 @@ mkTarEntry contents indexFile timestamp =
|
|||||||
Right tp -> tp
|
Right tp -> tp
|
||||||
|
|
||||||
indexPath = Sec.toFilePath $ Sec.castRoot $ indexFileToPath hackageIndexLayout indexFile
|
indexPath = Sec.toFilePath $ Sec.castRoot $ indexFileToPath hackageIndexLayout indexFile
|
||||||
|
|
||||||
|
newtype IndexEntries = IndexEntries () deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
|
||||||
|
type instance RuleResult IndexEntries = [Tar.Entry]
|
||||||
|
|
||||||
|
newtype PkgSpecs = PkgSpecs () deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
|
||||||
|
type instance RuleResult PkgSpecs = [(FilePath, PackageId, PackageVersionSpec)]
|
||||||
|
|
||||||
|
infixr 4 ~?~
|
||||||
|
(~?~) :: FilePattern -> ([String] -> Maybe c) -> FilePath -> Maybe c
|
||||||
|
pat ~?~ parser = filePattern pat >=> parser
|
||||||
|
|
||||||
|
infixr 3 ~~>
|
||||||
|
(~~>) :: (FilePath -> Maybe a) -> (FilePath -> a -> Action ()) -> Rules ()
|
||||||
|
parser ~~> act = isJust . parser ?> \path -> act path $ fromJust $ parser path
|
||||||
|
@ -1,68 +1,183 @@
|
|||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE ImportQualifiedPost #-}
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
module Foliage.HackageSecurity (
|
module Foliage.HackageSecurity where
|
||||||
module Foliage.HackageSecurity,
|
|
||||||
module Hackage.Security.Server,
|
|
||||||
module Hackage.Security.TUF.FileMap,
|
|
||||||
module Hackage.Security.Key.Env,
|
|
||||||
-- module Hackage.Security.Util.Path,
|
|
||||||
module Hackage.Security.Util.Some,
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import Control.Monad (replicateM)
|
import Control.Monad (replicateM)
|
||||||
import Control.Monad.IO.Class (MonadIO (..))
|
|
||||||
import Crypto.Sign.Ed25519 (unPublicKey)
|
import Crypto.Sign.Ed25519 (unPublicKey)
|
||||||
import Data.ByteString.Base16 (encodeBase16)
|
import Data.ByteString.Base16 (encodeBase16)
|
||||||
import Data.ByteString.Char8 qualified as BS
|
import Data.ByteString.Char8 qualified as BS
|
||||||
import Data.ByteString.Lazy qualified as BSL
|
import Data.ByteString.Lazy qualified as BSL
|
||||||
import Data.Foldable (for_)
|
import Data.Foldable (for_)
|
||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import Development.Shake (Action, need)
|
import Data.Traversable (for)
|
||||||
|
import Development.Shake (
|
||||||
|
Action,
|
||||||
|
RuleResult,
|
||||||
|
Rules,
|
||||||
|
addOracle,
|
||||||
|
askOracle,
|
||||||
|
getDirectoryFiles,
|
||||||
|
liftIO,
|
||||||
|
need,
|
||||||
|
trackWrite,
|
||||||
|
)
|
||||||
|
import Development.Shake.Classes (Binary, Hashable, NFData)
|
||||||
|
import Foliage.Options (SignOptions (..))
|
||||||
|
import Foliage.Time (UTCTime, iso8601Show)
|
||||||
|
import GHC.Generics (Generic)
|
||||||
import Hackage.Security.Key.Env (fromKeys)
|
import Hackage.Security.Key.Env (fromKeys)
|
||||||
import Hackage.Security.Server
|
import Hackage.Security.Server (
|
||||||
import Hackage.Security.TUF.FileMap
|
FileExpires (..),
|
||||||
|
FileInfo (..),
|
||||||
|
FileVersion (..),
|
||||||
|
Key,
|
||||||
|
KeyId (..),
|
||||||
|
KeyThreshold (..),
|
||||||
|
KeyType (..),
|
||||||
|
Mirrors (..),
|
||||||
|
PublicKey (..),
|
||||||
|
RepoLayout (..),
|
||||||
|
RepoPath,
|
||||||
|
RoleSpec (..),
|
||||||
|
Root (..),
|
||||||
|
RootRoles (..),
|
||||||
|
Snapshot (..),
|
||||||
|
Timestamp (..),
|
||||||
|
ToJSON,
|
||||||
|
WriteJSON,
|
||||||
|
anchorRepoPathLocally,
|
||||||
|
computeFileInfo,
|
||||||
|
createKey',
|
||||||
|
hackageRepoLayout,
|
||||||
|
readJSON_NoKeys_NoLayout,
|
||||||
|
renderJSON,
|
||||||
|
someKeyId,
|
||||||
|
somePublicKey,
|
||||||
|
withSignatures,
|
||||||
|
writeJSON_NoLayout,
|
||||||
|
)
|
||||||
import Hackage.Security.Util.Path qualified as Sec
|
import Hackage.Security.Util.Path qualified as Sec
|
||||||
import Hackage.Security.Util.Some
|
import Hackage.Security.Util.Some (Some (..))
|
||||||
import System.Directory (createDirectoryIfMissing)
|
import System.Directory (createDirectoryIfMissing)
|
||||||
import System.FilePath
|
import System.FilePath ((<.>), (</>))
|
||||||
|
|
||||||
readJSONSimple :: (FromJSON ReadJSON_NoKeys_NoLayout a) => FilePath -> IO (Either DeserializationError a)
|
mkMirrors :: FilePath -> Action ()
|
||||||
readJSONSimple fp = do
|
mkMirrors path = do
|
||||||
p <- Sec.makeAbsolute (Sec.fromFilePath fp)
|
expiryTime <- askOracle $ ExpiryTime ()
|
||||||
readJSON_NoKeys_NoLayout p
|
privateKeysMirrors <- readKeys "mirrors"
|
||||||
|
trackWrite [path]
|
||||||
|
liftIO $
|
||||||
|
writeSignedJSON path privateKeysMirrors $
|
||||||
|
Mirrors
|
||||||
|
{ mirrorsVersion = FileVersion 1
|
||||||
|
, mirrorsExpires = FileExpires expiryTime
|
||||||
|
, mirrorsMirrors = []
|
||||||
|
}
|
||||||
|
|
||||||
|
mkRoot :: FilePath -> Action ()
|
||||||
|
mkRoot path = do
|
||||||
|
expiryTime <- askOracle $ ExpiryTime ()
|
||||||
|
|
||||||
|
privateKeysRoot <- readKeys "root"
|
||||||
|
privateKeysTarget <- readKeys "target"
|
||||||
|
privateKeysSnapshot <- readKeys "snapshot"
|
||||||
|
privateKeysTimestamp <- readKeys "timestamp"
|
||||||
|
privateKeysMirrors <- readKeys "mirrors"
|
||||||
|
|
||||||
|
trackWrite [path]
|
||||||
|
liftIO $
|
||||||
|
writeSignedJSON path privateKeysRoot $
|
||||||
|
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
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
mkSnapshot :: FilePath -> FilePath -> Action ()
|
||||||
|
mkSnapshot outputDir path = do
|
||||||
|
expiryTime <- askOracle $ ExpiryTime ()
|
||||||
|
privateKeysSnapshot <- readKeys "snapshot"
|
||||||
|
|
||||||
|
rootInfo <- computeFileInfoSimple (outputDir ~/~ repoLayoutRoot)
|
||||||
|
mirrorsInfo <- computeFileInfoSimple (outputDir ~/~ repoLayoutMirrors)
|
||||||
|
tarInfo <- computeFileInfoSimple (outputDir ~/~ repoLayoutIndexTar)
|
||||||
|
tarGzInfo <- computeFileInfoSimple (outputDir ~/~ repoLayoutIndexTarGz)
|
||||||
|
|
||||||
|
liftIO $
|
||||||
|
writeSignedJSON path privateKeysSnapshot $
|
||||||
|
Snapshot
|
||||||
|
{ snapshotVersion = FileVersion 1
|
||||||
|
, snapshotExpires = FileExpires expiryTime
|
||||||
|
, snapshotInfoRoot = rootInfo
|
||||||
|
, snapshotInfoMirrors = mirrorsInfo
|
||||||
|
, snapshotInfoTar = Just tarInfo
|
||||||
|
, snapshotInfoTarGz = tarGzInfo
|
||||||
|
}
|
||||||
|
|
||||||
|
mkTimestamp :: FilePath -> FilePath -> Action ()
|
||||||
|
mkTimestamp outputDir path = do
|
||||||
|
expiryTime <- askOracle $ ExpiryTime ()
|
||||||
|
privateKeysTimestamp <- readKeys "timestamp"
|
||||||
|
|
||||||
|
snapshotInfo <- computeFileInfoSimple (outputDir ~/~ repoLayoutSnapshot)
|
||||||
|
|
||||||
|
liftIO $
|
||||||
|
writeSignedJSON path privateKeysTimestamp $
|
||||||
|
Timestamp
|
||||||
|
{ timestampVersion = FileVersion 1
|
||||||
|
, timestampExpires = FileExpires expiryTime
|
||||||
|
, timestampInfoSnapshot = snapshotInfo
|
||||||
|
}
|
||||||
|
|
||||||
|
computeFileInfoSimple :: FilePath -> Action FileInfo
|
||||||
|
computeFileInfoSimple path = do
|
||||||
|
need [path]
|
||||||
|
fi <- liftIO $ computeFileInfo (asRelativePath path)
|
||||||
|
return $! forceFileInfo fi `seq` fi
|
||||||
|
|
||||||
forceFileInfo :: FileInfo -> ()
|
forceFileInfo :: FileInfo -> ()
|
||||||
forceFileInfo (FileInfo a b) = a `seq` b `seq` ()
|
forceFileInfo (FileInfo a b) = a `seq` b `seq` ()
|
||||||
|
|
||||||
computeFileInfoSimple :: Sec.Path Sec.Relative -> Action FileInfo
|
|
||||||
computeFileInfoSimple (Sec.Path fp) = do
|
|
||||||
need [fp]
|
|
||||||
liftIO $ computeFileInfoSimple' fp
|
|
||||||
|
|
||||||
computeFileInfoSimple' :: FilePath -> IO FileInfo
|
|
||||||
computeFileInfoSimple' path = do
|
|
||||||
fi <- computeFileInfo (Sec.Path path :: Sec.Path Sec.Relative)
|
|
||||||
return $! forceFileInfo fi `seq` fi
|
|
||||||
|
|
||||||
createKeys :: FilePath -> IO ()
|
|
||||||
createKeys base = do
|
|
||||||
putStrLn "root keys:"
|
|
||||||
createKeyGroup "root" >>= showKeys
|
|
||||||
for_ ["target", "timestamp", "snapshot", "mirrors"] createKeyGroup
|
|
||||||
where
|
|
||||||
createKeyGroup group = do
|
|
||||||
createDirectoryIfMissing True (base </> group)
|
|
||||||
keys <- replicateM 3 $ createKey' KeyTypeEd25519
|
|
||||||
for_ keys $ writeKeyWithId (base </> group)
|
|
||||||
pure keys
|
|
||||||
|
|
||||||
showKeys keys =
|
|
||||||
for_ keys $ \key ->
|
|
||||||
putStrLn $ " " ++ showKey key
|
|
||||||
|
|
||||||
showKey :: Some Key -> [Char]
|
showKey :: Some Key -> [Char]
|
||||||
showKey k = T.unpack $ encodeBase16 $ exportSomePublicKey $ somePublicKey k
|
showKey k = T.unpack $ encodeBase16 $ exportSomePublicKey $ somePublicKey k
|
||||||
|
|
||||||
@ -81,12 +196,71 @@ writeKey fp key = do
|
|||||||
p <- Sec.makeAbsolute (Sec.fromFilePath fp)
|
p <- Sec.makeAbsolute (Sec.fromFilePath fp)
|
||||||
writeJSON_NoLayout p key
|
writeJSON_NoLayout p key
|
||||||
|
|
||||||
|
createKeys :: FilePath -> IO ()
|
||||||
|
createKeys base = do
|
||||||
|
putStrLn "root keys:"
|
||||||
|
createKeyGroup "root" >>= showKeys
|
||||||
|
for_ ["target", "timestamp", "snapshot", "mirrors"] createKeyGroup
|
||||||
|
where
|
||||||
|
createKeyGroup group = do
|
||||||
|
createDirectoryIfMissing True (base </> group)
|
||||||
|
keys <- replicateM 3 $ createKey' KeyTypeEd25519
|
||||||
|
for_ keys $ writeKeyWithId (base </> group)
|
||||||
|
pure keys
|
||||||
|
|
||||||
|
showKeys keys =
|
||||||
|
for_ keys $ \key ->
|
||||||
|
putStrLn $ " " ++ showKey key
|
||||||
|
|
||||||
|
readKeys :: FilePath -> Action [Some Key]
|
||||||
|
readKeys base = do
|
||||||
|
askOracle (SignOptionsOracle ()) >>= \case
|
||||||
|
SignOptsSignWithKeys keysPath -> do
|
||||||
|
paths <- getDirectoryFiles (keysPath </> base) ["*.json"]
|
||||||
|
need $ map (\fn -> keysPath </> base </> fn) paths
|
||||||
|
for paths $ \path -> do
|
||||||
|
mKey <- liftIO $ readJSON_NoKeys_NoLayout (asRelativePath $ keysPath </> base </> path)
|
||||||
|
case mKey of
|
||||||
|
Left err -> fail $ show err
|
||||||
|
Right key -> pure key
|
||||||
|
SignOptsDon'tSign ->
|
||||||
|
return []
|
||||||
|
|
||||||
|
newtype SignOptionsOracle = SignOptionsOracle ()
|
||||||
|
deriving (Eq, Show, Generic, Hashable, Binary, NFData)
|
||||||
|
|
||||||
|
type instance RuleResult SignOptionsOracle = SignOptions
|
||||||
|
|
||||||
|
addSigninigKeysOracle :: SignOptions -> Rules (SignOptionsOracle -> Action SignOptions)
|
||||||
|
addSigninigKeysOracle signOpts =
|
||||||
|
addOracle $ \SignOptionsOracle{} -> return signOpts
|
||||||
|
|
||||||
renderSignedJSON :: (ToJSON WriteJSON a) => [Some Key] -> a -> BSL.ByteString
|
renderSignedJSON :: (ToJSON WriteJSON a) => [Some Key] -> a -> BSL.ByteString
|
||||||
renderSignedJSON keys thing =
|
renderSignedJSON keys thing =
|
||||||
renderJSON
|
renderJSON
|
||||||
hackageRepoLayout
|
hackageRepoLayout
|
||||||
(withSignatures hackageRepoLayout keys thing)
|
(withSignatures hackageRepoLayout keys thing)
|
||||||
|
|
||||||
writeSignedJSON :: (Sec.FsRoot root, ToJSON WriteJSON a) => Sec.Path root -> [Some Key] -> a -> IO ()
|
writeSignedJSON :: (ToJSON WriteJSON a) => FilePath -> [Some Key] -> a -> IO ()
|
||||||
writeSignedJSON path keys thing = do
|
writeSignedJSON path keys thing = do
|
||||||
Sec.writeLazyByteString path $ renderSignedJSON keys thing
|
BSL.writeFile path $ renderSignedJSON keys thing
|
||||||
|
|
||||||
|
newtype ExpiryTime = ExpiryTime ()
|
||||||
|
deriving (Eq, Show, Generic, Hashable, Binary, NFData)
|
||||||
|
|
||||||
|
type instance RuleResult ExpiryTime = Maybe UTCTime
|
||||||
|
|
||||||
|
addExpiryTimeOracle :: Maybe UTCTime -> Rules (ExpiryTime -> Action (Maybe UTCTime))
|
||||||
|
addExpiryTimeOracle mExpireSignaturesOn = do
|
||||||
|
liftIO $ for_ mExpireSignaturesOn $ \expireSignaturesOn ->
|
||||||
|
putStrLn $ "Expiry time set to " <> iso8601Show expireSignaturesOn
|
||||||
|
addOracle $ \ExpiryTime{} -> return mExpireSignaturesOn
|
||||||
|
|
||||||
|
asRelativePath :: FilePath -> Sec.Path Sec.Relative
|
||||||
|
asRelativePath = Sec.rootPath @Sec.Relative . Sec.fromUnrootedFilePath
|
||||||
|
|
||||||
|
infixr 4 ~/~
|
||||||
|
(~/~) :: FilePath -> (RepoLayout -> RepoPath) -> FilePath
|
||||||
|
(~/~) outputDir p =
|
||||||
|
let Sec.Path fp = anchorRepoPathLocally (asRelativePath outputDir) (p hackageRepoLayout)
|
||||||
|
in fp
|
||||||
|
@ -1,92 +1,28 @@
|
|||||||
{-# LANGUAGE DeriveAnyClass #-}
|
|
||||||
{-# LANGUAGE DerivingStrategies #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
module Foliage.Oracles where
|
module Foliage.Oracles where
|
||||||
|
|
||||||
import Data.Foldable (for_)
|
|
||||||
import Data.Traversable (for)
|
|
||||||
import Development.Shake
|
import Development.Shake
|
||||||
import Development.Shake.Classes
|
import Development.Shake.Classes
|
||||||
import Foliage.HackageSecurity (Key, Some, readJSONSimple)
|
|
||||||
import Foliage.Options (SignOptions (..))
|
|
||||||
import Foliage.Time qualified as Time
|
import Foliage.Time qualified as Time
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Hackage.Security.Client (
|
|
||||||
RepoLayout,
|
|
||||||
RepoPath,
|
|
||||||
anchorRepoPathLocally,
|
|
||||||
hackageRepoLayout,
|
|
||||||
)
|
|
||||||
import Hackage.Security.Util.Path qualified as Sec
|
|
||||||
import Hackage.Security.Util.Pretty qualified as Sec
|
|
||||||
import System.FilePath ((</>))
|
|
||||||
|
|
||||||
-- FIXME: consider using configuration variables (usingConfig/getConfig) or shakeExtra
|
-- FIXME: consider using configuration variables (usingConfig/getConfig) or shakeExtra
|
||||||
|
|
||||||
-- | Just a shortcut to write types
|
-- | Just a shortcut to write types
|
||||||
type Oracle q = q -> Action (RuleResult q)
|
type Oracle q = q -> Action (RuleResult q)
|
||||||
|
|
||||||
data InputRoot
|
newtype CacheDir = CacheDir ()
|
||||||
|
deriving (Eq, Show, Generic, Hashable, Binary, NFData)
|
||||||
type InputPath = Sec.Path InputRoot
|
|
||||||
|
|
||||||
instance Sec.Pretty InputPath where
|
|
||||||
pretty (Sec.Path fp) = "<input>/" ++ fp
|
|
||||||
|
|
||||||
data InputDir = InputDir
|
|
||||||
deriving stock (Show, Generic, Typeable, Eq)
|
|
||||||
deriving anyclass (Hashable, Binary, NFData)
|
|
||||||
|
|
||||||
type instance RuleResult InputDir = FilePath
|
|
||||||
|
|
||||||
addInputDirOracle :: FilePath -> Rules (Oracle InputDir)
|
|
||||||
addInputDirOracle inputDir =
|
|
||||||
addOracle $ \InputDir -> return inputDir
|
|
||||||
|
|
||||||
anchorInputPath :: InputPath -> Action (Sec.Path Sec.Absolute)
|
|
||||||
anchorInputPath ip = do
|
|
||||||
inputDir <- askOracle InputDir
|
|
||||||
inputDirRoot <- liftIO $ Sec.makeAbsolute (Sec.fromFilePath inputDir)
|
|
||||||
return $ inputDirRoot Sec.</> Sec.unrootPath ip
|
|
||||||
|
|
||||||
data CacheDir = CacheDir
|
|
||||||
deriving stock (Show, Generic, Typeable, Eq)
|
|
||||||
deriving anyclass (Hashable, Binary, NFData)
|
|
||||||
|
|
||||||
type instance RuleResult CacheDir = FilePath
|
type instance RuleResult CacheDir = FilePath
|
||||||
|
|
||||||
addCacheDirOracle :: FilePath -> Rules (Oracle CacheDir)
|
addCacheDirOracle :: FilePath -> Rules (Oracle CacheDir)
|
||||||
addCacheDirOracle inputDir =
|
addCacheDirOracle inputDir =
|
||||||
addOracle $ \CacheDir -> return inputDir
|
addOracle $ \CacheDir{} -> return inputDir
|
||||||
|
|
||||||
data OutputDir = OutputDir
|
newtype CurrentTime = CurrentTime ()
|
||||||
deriving stock (Show, Generic, Typeable, Eq)
|
deriving (Eq, Show, Generic, Hashable, Binary, NFData)
|
||||||
deriving anyclass (Hashable, Binary, NFData)
|
|
||||||
|
|
||||||
type instance RuleResult OutputDir = FilePath
|
|
||||||
|
|
||||||
getOutputDir :: Action (Sec.Path Sec.Relative)
|
|
||||||
getOutputDir = do
|
|
||||||
outputDirRoot <- askOracle OutputDir
|
|
||||||
return $ Sec.Path outputDirRoot
|
|
||||||
|
|
||||||
anchorRepoPath :: RepoPath -> Action (Sec.Path Sec.Relative)
|
|
||||||
anchorRepoPath rp = do
|
|
||||||
outputDir <- getOutputDir
|
|
||||||
return $ anchorRepoPathLocally outputDir rp
|
|
||||||
|
|
||||||
anchorRepoPath' :: (RepoLayout -> RepoPath) -> Action (Sec.Path Sec.Relative)
|
|
||||||
anchorRepoPath' p = anchorRepoPath $ p hackageRepoLayout
|
|
||||||
|
|
||||||
addOutputDirOracle :: FilePath -> Rules (Oracle OutputDir)
|
|
||||||
addOutputDirOracle outputDir =
|
|
||||||
addOracle $ \OutputDir -> return outputDir
|
|
||||||
|
|
||||||
data CurrentTime = CurrentTime
|
|
||||||
deriving stock (Show, Generic, Typeable, Eq)
|
|
||||||
deriving anyclass (Hashable, Binary, NFData)
|
|
||||||
|
|
||||||
type instance RuleResult CurrentTime = Time.UTCTime
|
type instance RuleResult CurrentTime = Time.UTCTime
|
||||||
|
|
||||||
@ -100,40 +36,4 @@ addCurrentTimeOracle mCurrentTime = do
|
|||||||
Just t -> do
|
Just t -> do
|
||||||
liftIO $ putStrLn $ "Current time set to " <> Time.iso8601Show t <> "."
|
liftIO $ putStrLn $ "Current time set to " <> Time.iso8601Show t <> "."
|
||||||
return t
|
return t
|
||||||
addOracle $ \CurrentTime -> return currentTime
|
addOracle $ \CurrentTime{} -> return currentTime
|
||||||
|
|
||||||
data ExpiryTime = ExpiryTime
|
|
||||||
deriving stock (Show, Generic, Typeable, Eq)
|
|
||||||
deriving anyclass (Hashable, Binary, NFData)
|
|
||||||
|
|
||||||
type instance RuleResult ExpiryTime = Maybe Time.UTCTime
|
|
||||||
|
|
||||||
addExpiryTimeOracle :: Maybe Time.UTCTime -> Rules (Oracle ExpiryTime)
|
|
||||||
addExpiryTimeOracle mExpireSignaturesOn = do
|
|
||||||
liftIO $ for_ mExpireSignaturesOn $ \expireSignaturesOn ->
|
|
||||||
putStrLn $ "Expiry time set to " <> Time.iso8601Show expireSignaturesOn
|
|
||||||
addOracle $ \ExpiryTime -> return mExpireSignaturesOn
|
|
||||||
|
|
||||||
data SignOptionsOracle = SignOptionsOracle
|
|
||||||
deriving stock (Show, Generic, Typeable, Eq)
|
|
||||||
deriving anyclass (Hashable, Binary, NFData)
|
|
||||||
|
|
||||||
type instance RuleResult SignOptionsOracle = SignOptions
|
|
||||||
|
|
||||||
addSigninigKeysOracle :: SignOptions -> Rules (Oracle SignOptionsOracle)
|
|
||||||
addSigninigKeysOracle signOpts =
|
|
||||||
addOracle $ \SignOptionsOracle -> return signOpts
|
|
||||||
|
|
||||||
readKeys :: FilePath -> Action [Some Key]
|
|
||||||
readKeys base = do
|
|
||||||
askOracle SignOptionsOracle >>= \case
|
|
||||||
SignOptsSignWithKeys keysPath -> do
|
|
||||||
paths <- getDirectoryFiles (keysPath </> base) ["*.json"]
|
|
||||||
need $ map (\fn -> keysPath </> base </> fn) paths
|
|
||||||
for paths $ \path -> do
|
|
||||||
mKey <- liftIO $ readJSONSimple (keysPath </> base </> path)
|
|
||||||
case mKey of
|
|
||||||
Left err -> fail $ show err
|
|
||||||
Right key -> pure key
|
|
||||||
SignOptsDon'tSign ->
|
|
||||||
return []
|
|
||||||
|
@ -58,7 +58,7 @@ data AllPackagesPageEntry = AllPackagesPageEntry
|
|||||||
|
|
||||||
makeAllPackagesPage :: FilePath -> [(FilePath, PackageId, PackageVersionSpec)] -> Action ()
|
makeAllPackagesPage :: FilePath -> [(FilePath, PackageId, PackageVersionSpec)] -> Action ()
|
||||||
makeAllPackagesPage path allPkgSpecs = do
|
makeAllPackagesPage path allPkgSpecs = do
|
||||||
currentTime <- askOracle CurrentTime
|
currentTime <- askOracle $ CurrentTime ()
|
||||||
|
|
||||||
let packages :: [AllPackagesPageEntry]
|
let packages :: [AllPackagesPageEntry]
|
||||||
packages =
|
packages =
|
||||||
@ -109,7 +109,7 @@ data AllPackageVersionsPageEntry
|
|||||||
|
|
||||||
makeAllPackageVersionsPage :: FilePath -> [(FilePath, PackageId, PackageVersionSpec)] -> Action ()
|
makeAllPackageVersionsPage :: FilePath -> [(FilePath, PackageId, PackageVersionSpec)] -> Action ()
|
||||||
makeAllPackageVersionsPage path allPkgSpecs = do
|
makeAllPackageVersionsPage path allPkgSpecs = do
|
||||||
currentTime <- askOracle CurrentTime
|
currentTime <- askOracle $ CurrentTime ()
|
||||||
|
|
||||||
let entries =
|
let entries =
|
||||||
allPkgSpecs
|
allPkgSpecs
|
||||||
|
@ -2,13 +2,15 @@
|
|||||||
{-# LANGUAGE DerivingStrategies #-}
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
module Foliage.PrepareSdist (
|
module Foliage.SourceDist (
|
||||||
-- prepareSdist,
|
extractFromTarball,
|
||||||
prepareSource,
|
cachePathForURL,
|
||||||
|
fetchPackageVersion,
|
||||||
|
applyPatches,
|
||||||
|
updateCabalFileVersion,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad (when)
|
|
||||||
import Data.Char (isAlpha)
|
import Data.Char (isAlpha)
|
||||||
import Data.Foldable (for_)
|
import Data.Foldable (for_)
|
||||||
import Data.List (dropWhileEnd)
|
import Data.List (dropWhileEnd)
|
||||||
@ -21,56 +23,52 @@ import Distribution.Simple.PackageDescription (readGenericPackageDescription)
|
|||||||
import Distribution.Types.Lens qualified as L
|
import Distribution.Types.Lens qualified as L
|
||||||
import Distribution.Verbosity qualified as Verbosity
|
import Distribution.Verbosity qualified as Verbosity
|
||||||
import Foliage.FetchURL (fetchURL)
|
import Foliage.FetchURL (fetchURL)
|
||||||
import Foliage.Meta (PackageVersionSource (..), PackageVersionSpec (..))
|
import Foliage.Meta (PackageVersionSource (..))
|
||||||
import Foliage.Oracles (CacheDir (..))
|
import Foliage.Oracles (CacheDir (..))
|
||||||
import Foliage.Utils.GitHub (githubRepoTarballUrl)
|
import Foliage.Utils.GitHub (githubRepoTarballUrl)
|
||||||
import Network.URI (URI (..), URIAuth (..))
|
import Network.URI (URI (..), URIAuth (..))
|
||||||
import System.Directory qualified as IO
|
import System.Directory qualified as IO
|
||||||
|
|
||||||
prepareSource :: FilePath -> PackageIdentifier -> PackageVersionSpec -> FilePath -> Action ()
|
applyPatches :: FilePath -> FilePath -> Action ()
|
||||||
prepareSource metaFile pkgId pkgSpec cacheDir = do
|
applyPatches metaFile pkgDir = do
|
||||||
let PackageIdentifier{pkgName, pkgVersion} = pkgId
|
|
||||||
PackageVersionSpec{packageVersionSource, packageVersionForce} = pkgSpec
|
|
||||||
|
|
||||||
cacheRoot <- askOracle CacheDir
|
|
||||||
let cachePathForURL uri =
|
|
||||||
let scheme = dropWhileEnd (not . isAlpha) $ uriScheme uri
|
|
||||||
host = maybe (error $ "invalid uri " ++ show uri) uriRegName (uriAuthority uri)
|
|
||||||
in cacheRoot </> scheme </> host <//> uriPath uri
|
|
||||||
|
|
||||||
case packageVersionSource of
|
|
||||||
URISource (URI{uriScheme, uriPath}) mSubdir | uriScheme == "file:" -> do
|
|
||||||
tarballPath <- liftIO $ IO.makeAbsolute uriPath
|
|
||||||
extractFromTarball tarballPath mSubdir cacheDir
|
|
||||||
URISource uri mSubdir -> do
|
|
||||||
let tarballPath = cachePathForURL uri
|
|
||||||
fetchURL uri tarballPath
|
|
||||||
extractFromTarball tarballPath mSubdir cacheDir
|
|
||||||
GitHubSource repo rev mSubdir -> do
|
|
||||||
let uri = githubRepoTarballUrl repo rev
|
|
||||||
tarballPath = cachePathForURL uri
|
|
||||||
fetchURL uri tarballPath
|
|
||||||
extractFromTarball tarballPath mSubdir cacheDir
|
|
||||||
|
|
||||||
patchfiles <- getDirectoryFiles (takeDirectory metaFile) ["patches/*.patch"]
|
patchfiles <- getDirectoryFiles (takeDirectory metaFile) ["patches/*.patch"]
|
||||||
for_ patchfiles $ \patchfile -> do
|
for_ patchfiles $ \patchfile -> do
|
||||||
-- _sources/name/version/meta.toml -> _sources/name/version/patches/some.patch
|
-- _sources/name/version/meta.toml -> _sources/name/version/patches/some.patch
|
||||||
let patch = replaceBaseName metaFile patchfile
|
let patch = replaceBaseName metaFile patchfile
|
||||||
-- FileStdin is relative to the current working directory of this process
|
-- FileStdin is relative to the current working directory of this process
|
||||||
-- but patch needs to be run in srcDir
|
-- but patch needs to be run in srcDir
|
||||||
cmd_ Shell (Cwd cacheDir) (FileStdin patch) "patch -p1"
|
cmd_ Shell (Cwd pkgDir) (FileStdin patch) "patch -p1"
|
||||||
|
|
||||||
let cabalFilePath = cacheDir </> unPackageName pkgName <.> "cabal"
|
fetchPackageVersion :: PackageVersionSource -> FilePath -> Action ()
|
||||||
when packageVersionForce $ do
|
fetchPackageVersion (URISource (URI{uriScheme, uriPath}) mSubdir) pkgDir | uriScheme == "file:" = do
|
||||||
pkgDesc <- liftIO $ readGenericPackageDescription Verbosity.normal cabalFilePath
|
tarballPath <- liftIO $ IO.makeAbsolute uriPath
|
||||||
let pkgDesc' = set (L.packageDescription . L.package . L.pkgVersion) pkgVersion pkgDesc
|
extractFromTarball tarballPath mSubdir pkgDir
|
||||||
putInfo $ "Updating version in cabal file" ++ cabalFilePath
|
fetchPackageVersion (URISource uri mSubdir) pkgDir = do
|
||||||
liftIO $ writeGenericPackageDescription cabalFilePath pkgDesc'
|
tarballPath <- cachePathForURL uri
|
||||||
|
fetchURL uri tarballPath
|
||||||
|
extractFromTarball tarballPath mSubdir pkgDir
|
||||||
|
fetchPackageVersion (GitHubSource repo rev mSubdir) pkgDir = do
|
||||||
|
let uri = githubRepoTarballUrl repo rev
|
||||||
|
tarballPath <- cachePathForURL uri
|
||||||
|
fetchURL uri tarballPath
|
||||||
|
extractFromTarball tarballPath mSubdir pkgDir
|
||||||
|
|
||||||
-- liftIO $ packageDirToSdist Verbosity.normal pkgDesc (takeDirectory cabalFilePath) >>= BSL.writeFile path
|
updateCabalFileVersion :: FilePath -> Version -> Action ()
|
||||||
|
updateCabalFileVersion path pkgVersion = do
|
||||||
|
pkgDesc <- liftIO $ readGenericPackageDescription Verbosity.normal path
|
||||||
|
let pkgDesc' = set (L.packageDescription . L.package . L.pkgVersion) pkgVersion pkgDesc
|
||||||
|
putInfo $ "Updating version in cabal file" ++ path
|
||||||
|
liftIO $ writeGenericPackageDescription path pkgDesc'
|
||||||
|
|
||||||
|
cachePathForURL :: URI -> Action FilePath
|
||||||
|
cachePathForURL uri = do
|
||||||
|
cacheRoot <- askOracle $ CacheDir ()
|
||||||
|
let scheme = dropWhileEnd (not . isAlpha) $ uriScheme uri
|
||||||
|
host = maybe (error $ "invalid uri " ++ show uri) uriRegName (uriAuthority uri)
|
||||||
|
return $ cacheRoot </> scheme </> host <//> uriPath uri
|
||||||
|
|
||||||
extractFromTarball :: FilePath -> Maybe FilePath -> FilePath -> Action ()
|
extractFromTarball :: FilePath -> Maybe FilePath -> FilePath -> Action ()
|
||||||
extractFromTarball tarballPath mSubdir outDir = do
|
extractFromTarball tarballPath mSubdir destDir = do
|
||||||
withTempDir $ \tmpDir -> do
|
withTempDir $ \tmpDir -> do
|
||||||
cmd_
|
cmd_
|
||||||
[ "tar"
|
[ "tar"
|
||||||
@ -111,5 +109,5 @@ extractFromTarball tarballPath mSubdir outDir = do
|
|||||||
, -- SOURCE
|
, -- SOURCE
|
||||||
srcDir
|
srcDir
|
||||||
, -- DEST
|
, -- DEST
|
||||||
outDir
|
destDir
|
||||||
]
|
]
|
@ -1,131 +0,0 @@
|
|||||||
module Foliage.TUF where
|
|
||||||
|
|
||||||
import Development.Shake
|
|
||||||
import Foliage.HackageSecurity (
|
|
||||||
computeFileInfoSimple,
|
|
||||||
writeSignedJSON,
|
|
||||||
)
|
|
||||||
import Foliage.Oracles (
|
|
||||||
ExpiryTime (..),
|
|
||||||
anchorRepoPath',
|
|
||||||
readKeys,
|
|
||||||
)
|
|
||||||
import Hackage.Security.Key.Env (
|
|
||||||
fromKeys,
|
|
||||||
)
|
|
||||||
import Hackage.Security.Server (
|
|
||||||
FileExpires (..),
|
|
||||||
FileVersion (..),
|
|
||||||
KeyThreshold (..),
|
|
||||||
Mirrors (..),
|
|
||||||
RepoLayout (..),
|
|
||||||
RoleSpec (..),
|
|
||||||
Root (..),
|
|
||||||
RootRoles (..),
|
|
||||||
Snapshot (..),
|
|
||||||
Timestamp (..),
|
|
||||||
somePublicKey,
|
|
||||||
)
|
|
||||||
import Hackage.Security.Util.Path qualified as Sec
|
|
||||||
|
|
||||||
mkMirrors :: FilePath -> Action ()
|
|
||||||
mkMirrors path = do
|
|
||||||
expiryTime <- askOracle ExpiryTime
|
|
||||||
privateKeysMirrors <- readKeys "mirrors"
|
|
||||||
liftIO $
|
|
||||||
writeSignedJSON (Sec.Path path :: Sec.Path Sec.Relative) privateKeysMirrors $
|
|
||||||
Mirrors
|
|
||||||
{ mirrorsVersion = FileVersion 1
|
|
||||||
, mirrorsExpires = FileExpires expiryTime
|
|
||||||
, mirrorsMirrors = []
|
|
||||||
}
|
|
||||||
|
|
||||||
mkRoot :: FilePath -> Action ()
|
|
||||||
mkRoot path = do
|
|
||||||
expiryTime <- askOracle ExpiryTime
|
|
||||||
|
|
||||||
privateKeysRoot <- readKeys "root"
|
|
||||||
privateKeysTarget <- readKeys "target"
|
|
||||||
privateKeysSnapshot <- readKeys "snapshot"
|
|
||||||
privateKeysTimestamp <- readKeys "timestamp"
|
|
||||||
privateKeysMirrors <- readKeys "mirrors"
|
|
||||||
|
|
||||||
liftIO $
|
|
||||||
writeSignedJSON (Sec.Path path :: Sec.Path Sec.Relative) privateKeysRoot $
|
|
||||||
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
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
mkSnapshot :: FilePath -> Action ()
|
|
||||||
mkSnapshot path = do
|
|
||||||
expiryTime <- askOracle ExpiryTime
|
|
||||||
privateKeysSnapshot <- readKeys "snapshot"
|
|
||||||
|
|
||||||
rootInfo <- anchorRepoPath' repoLayoutRoot >>= computeFileInfoSimple
|
|
||||||
mirrorsInfo <- anchorRepoPath' repoLayoutMirrors >>= computeFileInfoSimple
|
|
||||||
tarInfo <- anchorRepoPath' repoLayoutIndexTar >>= computeFileInfoSimple
|
|
||||||
tarGzInfo <- anchorRepoPath' repoLayoutIndexTarGz >>= computeFileInfoSimple
|
|
||||||
|
|
||||||
liftIO $
|
|
||||||
writeSignedJSON (Sec.Path path :: Sec.Path Sec.Relative) privateKeysSnapshot $
|
|
||||||
Snapshot
|
|
||||||
{ snapshotVersion = FileVersion 1
|
|
||||||
, snapshotExpires = FileExpires expiryTime
|
|
||||||
, snapshotInfoRoot = rootInfo
|
|
||||||
, snapshotInfoMirrors = mirrorsInfo
|
|
||||||
, snapshotInfoTar = Just tarInfo
|
|
||||||
, snapshotInfoTarGz = tarGzInfo
|
|
||||||
}
|
|
||||||
|
|
||||||
mkTimestamp :: FilePath -> Action ()
|
|
||||||
mkTimestamp path = do
|
|
||||||
expiryTime <- askOracle ExpiryTime
|
|
||||||
privateKeysTimestamp <- readKeys "timestamp"
|
|
||||||
|
|
||||||
snapshotInfo <- anchorRepoPath' repoLayoutSnapshot >>= computeFileInfoSimple
|
|
||||||
|
|
||||||
liftIO $
|
|
||||||
writeSignedJSON (Sec.Path path :: Sec.Path Sec.Relative) privateKeysTimestamp $
|
|
||||||
Timestamp
|
|
||||||
{ timestampVersion = FileVersion 1
|
|
||||||
, timestampExpires = FileExpires expiryTime
|
|
||||||
, timestampInfoSnapshot = snapshotInfo
|
|
||||||
}
|
|
@ -21,6 +21,7 @@ executable foliage
|
|||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
hs-source-dirs: app
|
hs-source-dirs: app
|
||||||
other-modules:
|
other-modules:
|
||||||
|
Codec.Archive.Tar.Entry.Orphans
|
||||||
Distribution.Aeson
|
Distribution.Aeson
|
||||||
Distribution.Types.Orphans
|
Distribution.Types.Orphans
|
||||||
Foliage.CmdBuild
|
Foliage.CmdBuild
|
||||||
@ -30,12 +31,11 @@ executable foliage
|
|||||||
Foliage.HackageSecurity
|
Foliage.HackageSecurity
|
||||||
Foliage.Meta
|
Foliage.Meta
|
||||||
Foliage.Meta.Aeson
|
Foliage.Meta.Aeson
|
||||||
Foliage.Oracles
|
|
||||||
Foliage.Options
|
Foliage.Options
|
||||||
|
Foliage.Oracles
|
||||||
Foliage.Pages
|
Foliage.Pages
|
||||||
Foliage.PrepareSdist
|
Foliage.SourceDist
|
||||||
Foliage.Time
|
Foliage.Time
|
||||||
Foliage.TUF
|
|
||||||
Foliage.Utils.Aeson
|
Foliage.Utils.Aeson
|
||||||
Foliage.Utils.GitHub
|
Foliage.Utils.GitHub
|
||||||
Network.URI.Orphans
|
Network.URI.Orphans
|
||||||
@ -55,6 +55,7 @@ executable foliage
|
|||||||
ed25519 >=0.0.5.0 && <0.1,
|
ed25519 >=0.0.5.0 && <0.1,
|
||||||
filepath >=1.4.2.1 && <1.5,
|
filepath >=1.4.2.1 && <1.5,
|
||||||
hackage-security >=0.6.2.1 && <0.7,
|
hackage-security >=0.6.2.1 && <0.7,
|
||||||
|
hashable,
|
||||||
network-uri >=2.6.4.1 && <2.7,
|
network-uri >=2.6.4.1 && <2.7,
|
||||||
optparse-applicative >=0.17.0.0 && <0.18,
|
optparse-applicative >=0.17.0.0 && <0.18,
|
||||||
shake >=0.19.6 && <0.20,
|
shake >=0.19.6 && <0.20,
|
||||||
@ -64,6 +65,7 @@ executable foliage
|
|||||||
time >=1.9.3 && <1.13,
|
time >=1.9.3 && <1.13,
|
||||||
time-compat >=1.9.6.1 && <1.10,
|
time-compat >=1.9.6.1 && <1.10,
|
||||||
tomland >=1.3.3.1 && <1.4,
|
tomland >=1.3.3.1 && <1.4,
|
||||||
|
unordered-containers,
|
||||||
vector >=0.13.0.0 && <0.14,
|
vector >=0.13.0.0 && <0.14,
|
||||||
with-utf8 >=1.0.2.3 && <1.1,
|
with-utf8 >=1.0.2.3 && <1.1,
|
||||||
zlib >=0.6.2.3 && <0.7,
|
zlib >=0.6.2.3 && <0.7,
|
||||||
|
@ -44,7 +44,12 @@ unicode: never
|
|||||||
respectful: true
|
respectful: true
|
||||||
|
|
||||||
# Fixity information for operators
|
# Fixity information for operators
|
||||||
fixities: []
|
fixities:
|
||||||
|
- infixr 4 ~/~
|
||||||
|
- infixr 3 ~~>
|
||||||
|
- infixr 4 ~?~
|
||||||
|
# from Shake
|
||||||
|
- infix 1 %>
|
||||||
|
|
||||||
# Module reexports Fourmolu should know about
|
# Module reexports Fourmolu should know about
|
||||||
reexports: []
|
reexports: []
|
||||||
|
Loading…
Reference in New Issue
Block a user