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:
Andrea Bedini
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.Entry qualified as Tar
|
||||
import Codec.Archive.Tar.Entry.Orphans ()
|
||||
import Codec.Compression.GZip qualified as GZip
|
||||
import Control.Monad (unless, when, (>=>))
|
||||
import Data.Aeson qualified as Aeson
|
||||
@ -24,38 +25,73 @@ import Distribution.Package
|
||||
import Distribution.Pretty (prettyShow)
|
||||
import Distribution.Version
|
||||
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.Aeson ()
|
||||
import Foliage.Options
|
||||
import Foliage.Oracles
|
||||
import Foliage.Pages
|
||||
import Foliage.TUF as TUF (
|
||||
mkMirrors,
|
||||
mkRoot,
|
||||
mkSnapshot,
|
||||
mkTimestamp,
|
||||
import Hackage.Security.Server (
|
||||
FileExpires (..),
|
||||
FileVersion (..),
|
||||
IndexFile (..),
|
||||
IndexLayout (..),
|
||||
RepoLayout (..),
|
||||
TargetPath (..),
|
||||
Targets (..),
|
||||
hackageIndexLayout,
|
||||
hackageRepoLayout,
|
||||
)
|
||||
|
||||
import Data.ByteString.Lazy qualified as BSL
|
||||
import Data.Function ((&))
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Data.Maybe (fromJust, fromMaybe, isJust, listToMaybe, mapMaybe)
|
||||
import Data.Traversable (for)
|
||||
import Development.Shake.Classes
|
||||
import Development.Shake.Config (usingConfig)
|
||||
import Distribution.Client.SrcDist (packageDirToSdist)
|
||||
import Distribution.Parsec (simpleParsec)
|
||||
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
|
||||
import Distribution.Utils.Generic (sndOf3)
|
||||
import Distribution.Verbosity qualified as Verbosity
|
||||
import Foliage.Meta (DeprecationSpec (..), PackageVersionSpec (..), RevisionSpec (..))
|
||||
import Foliage.PrepareSdist (prepareSource)
|
||||
import Foliage.SourceDist (applyPatches, fetchPackageVersion, updateCabalFileVersion)
|
||||
import Foliage.Time qualified as Time
|
||||
import Hackage.Security.TUF.FileMap qualified as FM
|
||||
import Hackage.Security.Util.Path qualified as Sec
|
||||
import System.Directory qualified as IO
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
cmdBuild :: BuildOptions -> IO ()
|
||||
cmdBuild buildOptions = do
|
||||
let inputDir = buildOptsInputDir buildOptions
|
||||
let outputDir = buildOptsOutputDir buildOptions
|
||||
let
|
||||
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
|
||||
case buildOptsSignOpts buildOptions of
|
||||
@ -67,9 +103,13 @@ cmdBuild buildOptions = do
|
||||
_otherwise -> pure ()
|
||||
|
||||
shake opts $ do
|
||||
-- FIXME: maybe?
|
||||
usingConfig $
|
||||
HM.fromList
|
||||
[ ("outputDir", buildOptsOutputDir buildOptions)
|
||||
, ("cacheDir", cacheDir)
|
||||
]
|
||||
-- FIXME: consider using configuration variables (usingConfig/getConfig) or shakeExtra
|
||||
_ <- addOutputDirOracle (buildOptsOutputDir buildOptions)
|
||||
_ <- addInputDirOracle (buildOptsInputDir buildOptions)
|
||||
_ <- addCacheDirOracle cacheDir
|
||||
_ <- addExpiryTimeOracle (buildOptsExpireSignaturesOn buildOptions)
|
||||
_ <- addCurrentTimeOracle (buildOptsCurrentTime buildOptions)
|
||||
@ -79,18 +119,64 @@ cmdBuild buildOptions = do
|
||||
|
||||
addFetchURLRule
|
||||
|
||||
let cacheSrcDir PackageIdentifier{pkgName, pkgVersion} = cacheDir </> unPackageName pkgName </> prettyShow pkgVersion
|
||||
|
||||
readPackageVersionSpec <- newCache $ \path -> do
|
||||
need [path]
|
||||
meta <- liftIO $ Meta.readPackageVersionSpec path
|
||||
validateMeta path meta
|
||||
return meta
|
||||
|
||||
allPkgSpecs <- do
|
||||
cache <- newCache $ const $ do
|
||||
metaFiles <- getDirectoryFiles inputDir ["*/*/meta.toml"]
|
||||
action $ do
|
||||
need
|
||||
[ 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
|
||||
error $
|
||||
unlines
|
||||
@ -107,82 +193,52 @@ cmdBuild buildOptions = do
|
||||
pkgSpec <- readPackageVersionSpec (inputDir </> path)
|
||||
return (inputDir </> path, pkgId, pkgSpec)
|
||||
_ -> 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
|
||||
need
|
||||
[ outputDir </> "mirrors.json"
|
||||
, outputDir </> "root.json"
|
||||
, outputDir </> "snapshot.json"
|
||||
, outputDir </> "timestamp.json"
|
||||
]
|
||||
-- allPkgSpecs >>= traverse $ \(metaFile, pkgId, pkgSpec) -> do
|
||||
-- WARN: See note on `makeCabalEntries`, the sorting here has to be stable
|
||||
return $ sortOn Tar.entryTime (cabalEntries ++ metadataEntries ++ extraEntries)
|
||||
-- Return the oracle function applied to IndexEntries ()
|
||||
return $ getIndexEntries $ IndexEntries ()
|
||||
|
||||
--
|
||||
-- Rules for core repository functionality
|
||||
--
|
||||
--
|
||||
|
||||
( (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
|
||||
coreRules outputDir cabalFileForPkgId indexEntries
|
||||
|
||||
alternatives $ do
|
||||
( (outputDir </> "package/*/revision/0.cabal") `matching` \case
|
||||
outputDir </> "package/*/revision/0.cabal"
|
||||
~?~ ( \case
|
||||
[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
|
||||
[pkgId, revNum] -> (,) <$> simpleParsec pkgId <*> return revNum
|
||||
outputDir </> "package/*/revision/*.cabal"
|
||||
~?~ ( \case
|
||||
[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"
|
||||
~?~ ( \case
|
||||
[pkgIdStr, pkgName']
|
||||
| Just pkgId <- simpleParsec pkgIdStr
|
||||
, unPackageName (pkgName pkgId) == pkgName' ->
|
||||
Just pkgId
|
||||
_ -> Nothing
|
||||
)
|
||||
~~> \path pkgId@PackageIdentifier{pkgName} ->
|
||||
copyFileChanged (cacheSrcDir pkgId </> unPackageName pkgName <.> "cabal") path
|
||||
~~> \path pkgId ->
|
||||
copyFileChanged (cabalFileForPkgId pkgId) path
|
||||
|
||||
--
|
||||
-- Foliage metadata
|
||||
@ -190,66 +246,78 @@ cmdBuild buildOptions = do
|
||||
|
||||
-- only require this when requested? the rule is always valid
|
||||
-- when (buildOptsWriteMetadata buildOptions) $
|
||||
outputDir </> "foliage/packages.json" %> \path ->
|
||||
allPkgSpecs >>= makeMetadataFile path
|
||||
outputDir </> "foliage/packages.json"
|
||||
%> \path ->
|
||||
getPkgSpecs >>= makeMetadataFile path
|
||||
|
||||
--
|
||||
-- Pages
|
||||
--
|
||||
|
||||
outputDir </> "index.html" %> makeIndexPage
|
||||
outputDir </> "index.html"
|
||||
%> makeIndexPage
|
||||
|
||||
outputDir </> "all-packages/index.html" %> \path ->
|
||||
allPkgSpecs >>= makeAllPackagesPage path
|
||||
outputDir </> "all-packages/index.html"
|
||||
%> \path ->
|
||||
getPkgSpecs >>= makeAllPackagesPage path
|
||||
|
||||
outputDir </> "all-package-versions/index.html" %> \path ->
|
||||
allPkgSpecs >>= makeAllPackageVersionsPage path
|
||||
outputDir </> "all-package-versions/index.html"
|
||||
%> \path ->
|
||||
getPkgSpecs >>= makeAllPackageVersionsPage path
|
||||
|
||||
( (outputDir </> "package/*/index.html") `matching` \case
|
||||
outputDir </> "package/*/index.html"
|
||||
~?~ ( \case
|
||||
[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
|
||||
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
|
||||
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
|
||||
matching pattern parser = filePattern pattern >=> parser
|
||||
coreRules :: FilePath -> (PackageIdentifier -> FilePath) -> Action [Tar.Entry] -> Rules ()
|
||||
coreRules outputDir cabalFileForPkgId indexEntries = do
|
||||
outputDir ~/~ repoLayoutMirrors
|
||||
%> mkMirrors
|
||||
|
||||
cacheDir = "_cache"
|
||||
opts =
|
||||
shakeOptions
|
||||
{ shakeFiles = cacheDir
|
||||
, shakeChange = ChangeModtimeAndDigest
|
||||
, shakeColor = True
|
||||
, shakeLint = Just LintBasic
|
||||
, shakeReport = ["report.html", "report.json"]
|
||||
, shakeThreads = buildOptsNumThreads buildOptions
|
||||
, shakeVerbosity = buildOptsVerbosity buildOptions
|
||||
}
|
||||
outputDir ~/~ repoLayoutRoot
|
||||
%> mkRoot
|
||||
|
||||
makeIndexEntries :: (PackageId -> FilePath) -> [(FilePath, PackageId, PackageVersionSpec)] -> Action [Tar.Entry]
|
||||
makeIndexEntries cacheSrcDir allPkgSpecs = do
|
||||
cabalEntries <- makeCabalEntries cacheSrcDir allPkgSpecs
|
||||
metadataEntries <- makeMetadataEntries allPkgSpecs
|
||||
let extraEntries = makeExtraEntries allPkgSpecs
|
||||
outputDir ~/~ repoLayoutSnapshot
|
||||
%> mkSnapshot outputDir
|
||||
|
||||
-- WARN: See note on `makeCabalEntries`, the sorting here has to be stable
|
||||
return $ sortOn Tar.entryTime (cabalEntries ++ metadataEntries ++ extraEntries)
|
||||
outputDir ~/~ repoLayoutTimestamp
|
||||
%> 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 cacheSrcDir allPkgSpecs = do
|
||||
currentTime <- askOracle CurrentTime
|
||||
makeCabalEntries cabalFileForPkgId allPkgSpecs = do
|
||||
currentTime <- askOracle $ CurrentTime ()
|
||||
allPkgSpecs
|
||||
& foldMap
|
||||
( \(metaFile, pkgId, pkgSpec) -> do
|
||||
let pkgCabalFile = cacheSrcDir pkgId </> unPackageName (pkgName pkgId) <.> "cabal"
|
||||
let pkgCabalFile = cabalFileForPkgId pkgId
|
||||
pkgTimestamp = fromMaybe currentTime (packageVersionTimestamp pkgSpec)
|
||||
|
||||
uploadEntry <- makeIndexPkgCabal pkgId pkgTimestamp pkgCabalFile
|
||||
@ -264,11 +332,10 @@ makeCabalEntries cacheSrcDir allPkgSpecs = do
|
||||
return $ uploadEntry : revisionEntries
|
||||
)
|
||||
|
||||
makeMetadataEntries :: [(FilePath, PackageId, PackageVersionSpec)] -> Action [Tar.Entry]
|
||||
makeMetadataEntries allPkgSpecs = do
|
||||
currentTime <- askOracle CurrentTime
|
||||
expiryTime <- askOracle ExpiryTime
|
||||
outputDir <- askOracle OutputDir
|
||||
makeMetadataEntries :: FilePath -> [(FilePath, PackageId, PackageVersionSpec)] -> Action [Tar.Entry]
|
||||
makeMetadataEntries outputDir allPkgSpecs = do
|
||||
currentTime <- askOracle $ CurrentTime ()
|
||||
expiryTime <- askOracle $ ExpiryTime ()
|
||||
|
||||
targetKeys <- readKeys "target"
|
||||
|
||||
@ -355,23 +422,16 @@ makeIndexPkgCabal pkgId timestamp filePath = do
|
||||
|
||||
makeIndexPkgMetadata :: Maybe Meta.UTCTime -> PackageId -> FilePath -> Action Targets
|
||||
makeIndexPkgMetadata expiryTime pkgId sdistPath = do
|
||||
need [sdistPath]
|
||||
targetFileInfo <- liftIO $ computeFileInfoSimple' sdistPath
|
||||
targetFileInfo <- computeFileInfoSimple sdistPath
|
||||
let packagePath = repoLayoutPkgTarGz hackageRepoLayout pkgId
|
||||
return
|
||||
Targets
|
||||
{ targetsVersion = FileVersion 1
|
||||
, targetsExpires = FileExpires expiryTime
|
||||
, targetsTargets = fromList [(TargetPathRepo packagePath, targetFileInfo)]
|
||||
, targetsTargets = FM.fromList [(TargetPathRepo packagePath, targetFileInfo)]
|
||||
, 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
|
||||
validateMeta :: (MonadFail m) => FilePath -> PackageVersionSpec -> m ()
|
||||
validateMeta metaFile PackageVersionSpec{..} = do
|
||||
@ -430,6 +490,12 @@ validateMeta metaFile PackageVersionSpec{..} = do
|
||||
]
|
||||
_otherwise ->
|
||||
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
|
||||
:: BL.ByteString
|
||||
@ -453,3 +519,17 @@ mkTarEntry contents indexFile timestamp =
|
||||
Right tp -> tp
|
||||
|
||||
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 GADTs #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Foliage.HackageSecurity (
|
||||
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
|
||||
module Foliage.HackageSecurity where
|
||||
|
||||
import Control.Monad (replicateM)
|
||||
import Control.Monad.IO.Class (MonadIO (..))
|
||||
import Crypto.Sign.Ed25519 (unPublicKey)
|
||||
import Data.ByteString.Base16 (encodeBase16)
|
||||
import Data.ByteString.Char8 qualified as BS
|
||||
import Data.ByteString.Lazy qualified as BSL
|
||||
import Data.Foldable (for_)
|
||||
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.Server
|
||||
import Hackage.Security.TUF.FileMap
|
||||
import Hackage.Security.Server (
|
||||
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.Some
|
||||
import Hackage.Security.Util.Some (Some (..))
|
||||
import System.Directory (createDirectoryIfMissing)
|
||||
import System.FilePath
|
||||
import System.FilePath ((<.>), (</>))
|
||||
|
||||
readJSONSimple :: (FromJSON ReadJSON_NoKeys_NoLayout a) => FilePath -> IO (Either DeserializationError a)
|
||||
readJSONSimple fp = do
|
||||
p <- Sec.makeAbsolute (Sec.fromFilePath fp)
|
||||
readJSON_NoKeys_NoLayout p
|
||||
mkMirrors :: FilePath -> Action ()
|
||||
mkMirrors path = do
|
||||
expiryTime <- askOracle $ ExpiryTime ()
|
||||
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 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 k = T.unpack $ encodeBase16 $ exportSomePublicKey $ somePublicKey k
|
||||
|
||||
@ -81,12 +196,71 @@ writeKey fp key = do
|
||||
p <- Sec.makeAbsolute (Sec.fromFilePath fp)
|
||||
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 keys thing =
|
||||
renderJSON
|
||||
hackageRepoLayout
|
||||
(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
|
||||
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 #-}
|
||||
|
||||
module Foliage.Oracles where
|
||||
|
||||
import Data.Foldable (for_)
|
||||
import Data.Traversable (for)
|
||||
import Development.Shake
|
||||
import Development.Shake.Classes
|
||||
import Foliage.HackageSecurity (Key, Some, readJSONSimple)
|
||||
import Foliage.Options (SignOptions (..))
|
||||
import Foliage.Time qualified as Time
|
||||
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
|
||||
|
||||
-- | Just a shortcut to write types
|
||||
type Oracle q = q -> Action (RuleResult q)
|
||||
|
||||
data InputRoot
|
||||
|
||||
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)
|
||||
newtype CacheDir = CacheDir ()
|
||||
deriving (Eq, Show, Generic, Hashable, Binary, NFData)
|
||||
|
||||
type instance RuleResult CacheDir = FilePath
|
||||
|
||||
addCacheDirOracle :: FilePath -> Rules (Oracle CacheDir)
|
||||
addCacheDirOracle inputDir =
|
||||
addOracle $ \CacheDir -> return inputDir
|
||||
addOracle $ \CacheDir{} -> return inputDir
|
||||
|
||||
data OutputDir = OutputDir
|
||||
deriving stock (Show, Generic, Typeable, Eq)
|
||||
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)
|
||||
newtype CurrentTime = CurrentTime ()
|
||||
deriving (Eq, Show, Generic, Hashable, Binary, NFData)
|
||||
|
||||
type instance RuleResult CurrentTime = Time.UTCTime
|
||||
|
||||
@ -100,40 +36,4 @@ addCurrentTimeOracle mCurrentTime = do
|
||||
Just t -> do
|
||||
liftIO $ putStrLn $ "Current time set to " <> Time.iso8601Show t <> "."
|
||||
return t
|
||||
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 []
|
||||
addOracle $ \CurrentTime{} -> return currentTime
|
||||
|
||||
@ -58,7 +58,7 @@ data AllPackagesPageEntry = AllPackagesPageEntry
|
||||
|
||||
makeAllPackagesPage :: FilePath -> [(FilePath, PackageId, PackageVersionSpec)] -> Action ()
|
||||
makeAllPackagesPage path allPkgSpecs = do
|
||||
currentTime <- askOracle CurrentTime
|
||||
currentTime <- askOracle $ CurrentTime ()
|
||||
|
||||
let packages :: [AllPackagesPageEntry]
|
||||
packages =
|
||||
@ -109,7 +109,7 @@ data AllPackageVersionsPageEntry
|
||||
|
||||
makeAllPackageVersionsPage :: FilePath -> [(FilePath, PackageId, PackageVersionSpec)] -> Action ()
|
||||
makeAllPackageVersionsPage path allPkgSpecs = do
|
||||
currentTime <- askOracle CurrentTime
|
||||
currentTime <- askOracle $ CurrentTime ()
|
||||
|
||||
let entries =
|
||||
allPkgSpecs
|
||||
|
||||
@ -2,13 +2,15 @@
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Foliage.PrepareSdist (
|
||||
-- prepareSdist,
|
||||
prepareSource,
|
||||
module Foliage.SourceDist (
|
||||
extractFromTarball,
|
||||
cachePathForURL,
|
||||
fetchPackageVersion,
|
||||
applyPatches,
|
||||
updateCabalFileVersion,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Data.Char (isAlpha)
|
||||
import Data.Foldable (for_)
|
||||
import Data.List (dropWhileEnd)
|
||||
@ -21,56 +23,52 @@ import Distribution.Simple.PackageDescription (readGenericPackageDescription)
|
||||
import Distribution.Types.Lens qualified as L
|
||||
import Distribution.Verbosity qualified as Verbosity
|
||||
import Foliage.FetchURL (fetchURL)
|
||||
import Foliage.Meta (PackageVersionSource (..), PackageVersionSpec (..))
|
||||
import Foliage.Meta (PackageVersionSource (..))
|
||||
import Foliage.Oracles (CacheDir (..))
|
||||
import Foliage.Utils.GitHub (githubRepoTarballUrl)
|
||||
import Network.URI (URI (..), URIAuth (..))
|
||||
import System.Directory qualified as IO
|
||||
|
||||
prepareSource :: FilePath -> PackageIdentifier -> PackageVersionSpec -> FilePath -> Action ()
|
||||
prepareSource metaFile pkgId pkgSpec cacheDir = 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
|
||||
|
||||
applyPatches :: FilePath -> FilePath -> Action ()
|
||||
applyPatches metaFile pkgDir = do
|
||||
patchfiles <- getDirectoryFiles (takeDirectory metaFile) ["patches/*.patch"]
|
||||
for_ patchfiles $ \patchfile -> do
|
||||
-- _sources/name/version/meta.toml -> _sources/name/version/patches/some.patch
|
||||
let patch = replaceBaseName metaFile patchfile
|
||||
-- FileStdin is relative to the current working directory of this process
|
||||
-- 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"
|
||||
when packageVersionForce $ do
|
||||
pkgDesc <- liftIO $ readGenericPackageDescription Verbosity.normal cabalFilePath
|
||||
fetchPackageVersion :: PackageVersionSource -> FilePath -> Action ()
|
||||
fetchPackageVersion (URISource (URI{uriScheme, uriPath}) mSubdir) pkgDir | uriScheme == "file:" = do
|
||||
tarballPath <- liftIO $ IO.makeAbsolute uriPath
|
||||
extractFromTarball tarballPath mSubdir pkgDir
|
||||
fetchPackageVersion (URISource uri mSubdir) pkgDir = do
|
||||
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
|
||||
|
||||
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" ++ cabalFilePath
|
||||
liftIO $ writeGenericPackageDescription cabalFilePath pkgDesc'
|
||||
putInfo $ "Updating version in cabal file" ++ path
|
||||
liftIO $ writeGenericPackageDescription path pkgDesc'
|
||||
|
||||
-- liftIO $ packageDirToSdist Verbosity.normal pkgDesc (takeDirectory cabalFilePath) >>= BSL.writeFile path
|
||||
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 tarballPath mSubdir outDir = do
|
||||
extractFromTarball tarballPath mSubdir destDir = do
|
||||
withTempDir $ \tmpDir -> do
|
||||
cmd_
|
||||
[ "tar"
|
||||
@ -111,5 +109,5 @@ extractFromTarball tarballPath mSubdir outDir = do
|
||||
, -- SOURCE
|
||||
srcDir
|
||||
, -- 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
|
||||
hs-source-dirs: app
|
||||
other-modules:
|
||||
Codec.Archive.Tar.Entry.Orphans
|
||||
Distribution.Aeson
|
||||
Distribution.Types.Orphans
|
||||
Foliage.CmdBuild
|
||||
@ -30,12 +31,11 @@ executable foliage
|
||||
Foliage.HackageSecurity
|
||||
Foliage.Meta
|
||||
Foliage.Meta.Aeson
|
||||
Foliage.Oracles
|
||||
Foliage.Options
|
||||
Foliage.Oracles
|
||||
Foliage.Pages
|
||||
Foliage.PrepareSdist
|
||||
Foliage.SourceDist
|
||||
Foliage.Time
|
||||
Foliage.TUF
|
||||
Foliage.Utils.Aeson
|
||||
Foliage.Utils.GitHub
|
||||
Network.URI.Orphans
|
||||
@ -55,6 +55,7 @@ executable foliage
|
||||
ed25519 >=0.0.5.0 && <0.1,
|
||||
filepath >=1.4.2.1 && <1.5,
|
||||
hackage-security >=0.6.2.1 && <0.7,
|
||||
hashable,
|
||||
network-uri >=2.6.4.1 && <2.7,
|
||||
optparse-applicative >=0.17.0.0 && <0.18,
|
||||
shake >=0.19.6 && <0.20,
|
||||
@ -64,6 +65,7 @@ executable foliage
|
||||
time >=1.9.3 && <1.13,
|
||||
time-compat >=1.9.6.1 && <1.10,
|
||||
tomland >=1.3.3.1 && <1.4,
|
||||
unordered-containers,
|
||||
vector >=0.13.0.0 && <0.14,
|
||||
with-utf8 >=1.0.2.3 && <1.1,
|
||||
zlib >=0.6.2.3 && <0.7,
|
||||
|
||||
@ -44,7 +44,12 @@ unicode: never
|
||||
respectful: true
|
||||
|
||||
# Fixity information for operators
|
||||
fixities: []
|
||||
fixities:
|
||||
- infixr 4 ~/~
|
||||
- infixr 3 ~~>
|
||||
- infixr 4 ~?~
|
||||
# from Shake
|
||||
- infix 1 %>
|
||||
|
||||
# Module reexports Fourmolu should know about
|
||||
reexports: []
|
||||
|
||||
Loading…
Reference in New Issue
Block a user