From 095b3cf76e50878e818f6fc93cf6c0e28fd930e7 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 14 Nov 2023 14:32:08 +0800 Subject: [PATCH] WIP --- app/Codec/Archive/Tar/Entry/Orphans.hs | 30 ++ app/Foliage/CmdBuild.hs | 356 +++++++++++------- app/Foliage/HackageSecurity.hs | 268 ++++++++++--- app/Foliage/Oracles.hs | 112 +----- app/Foliage/Pages.hs | 4 +- .../{PrepareSdist.hs => SourceDist.hs} | 78 ++-- app/Foliage/TUF.hs | 131 ------- foliage.cabal | 8 +- fourmolu.yaml | 7 +- 9 files changed, 526 insertions(+), 468 deletions(-) create mode 100644 app/Codec/Archive/Tar/Entry/Orphans.hs rename app/Foliage/{PrepareSdist.hs => SourceDist.hs} (55%) delete mode 100644 app/Foliage/TUF.hs diff --git a/app/Codec/Archive/Tar/Entry/Orphans.hs b/app/Codec/Archive/Tar/Entry/Orphans.hs new file mode 100644 index 0000000..a61b623 --- /dev/null +++ b/app/Codec/Archive/Tar/Entry/Orphans.hs @@ -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 diff --git a/app/Foliage/CmdBuild.hs b/app/Foliage/CmdBuild.hs index 4dcfd93..8067dd7 100644 --- a/app/Foliage/CmdBuild.hs +++ b/app/Foliage/CmdBuild.hs @@ -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 - [pkgId] -> simpleParsec pkgId - _ -> Nothing - ) - ~~> \path pkgId@PackageIdentifier{pkgName} -> - copyFileChanged (cacheSrcDir pkgId <.> unPackageName pkgName <.> "cabal") path + outputDir "package/*/revision/0.cabal" + ~?~ ( \case + [pkgId] -> simpleParsec pkgId + _ -> Nothing + ) + ~~> \path pkgId -> + copyFileChanged (cabalFileForPkgId pkgId) path - ( (outputDir "package/*/revision/*.cabal") `matching` \case - [pkgId, revNum] -> (,) <$> simpleParsec pkgId <*> return revNum - _ -> Nothing - ) - ~~> \path (PackageIdentifier{pkgName, pkgVersion}, revNum) -> - copyFileChanged (inputDir unPackageName pkgName prettyShow pkgVersion "revision" revNum <.> "cabal") path + outputDir "package/*/revision/*.cabal" + ~?~ ( \case + [pkgId, revNum] -> (,) <$> simpleParsec pkgId <*> readMaybe revNum + _ -> Nothing + ) + ~~> \path (pkgId, revNum) -> + copyFileChanged (cabalFileRevisionForPkgId pkgId revNum) path - ( (outputDir "package/*/*.cabal") `matching` \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 + outputDir "package/*/*.cabal" + ~?~ ( \case + [pkgIdStr, pkgName'] + | Just pkgId <- simpleParsec pkgIdStr + , unPackageName (pkgName pkgId) == pkgName' -> + Just pkgId + _ -> Nothing + ) + ~~> \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 - [pkgId] -> simpleParsec pkgId - _ -> Nothing - ) - ~~> \path pkgId@PackageIdentifier{pkgName, pkgVersion} -> do - let metaFile = inputDir unPackageName pkgName prettyShow pkgVersion "meta.toml" + outputDir "package/*/index.html" + ~?~ ( \case + [pkgId] -> simpleParsec pkgId + _ -> Nothing + ) + ~~> \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 diff --git a/app/Foliage/HackageSecurity.hs b/app/Foliage/HackageSecurity.hs index 2f98309..cb230f7 100644 --- a/app/Foliage/HackageSecurity.hs +++ b/app/Foliage/HackageSecurity.hs @@ -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 diff --git a/app/Foliage/Oracles.hs b/app/Foliage/Oracles.hs index 4c7abf0..7258720 100644 --- a/app/Foliage/Oracles.hs +++ b/app/Foliage/Oracles.hs @@ -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) = "/" ++ 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 diff --git a/app/Foliage/Pages.hs b/app/Foliage/Pages.hs index b3c27ac..76c8c1d 100644 --- a/app/Foliage/Pages.hs +++ b/app/Foliage/Pages.hs @@ -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 diff --git a/app/Foliage/PrepareSdist.hs b/app/Foliage/SourceDist.hs similarity index 55% rename from app/Foliage/PrepareSdist.hs rename to app/Foliage/SourceDist.hs index 1f20569..07a559e 100644 --- a/app/Foliage/PrepareSdist.hs +++ b/app/Foliage/SourceDist.hs @@ -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 - let pkgDesc' = set (L.packageDescription . L.package . L.pkgVersion) pkgVersion pkgDesc - putInfo $ "Updating version in cabal file" ++ cabalFilePath - liftIO $ writeGenericPackageDescription cabalFilePath pkgDesc' +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 --- 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 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 ] diff --git a/app/Foliage/TUF.hs b/app/Foliage/TUF.hs deleted file mode 100644 index e2aa721..0000000 --- a/app/Foliage/TUF.hs +++ /dev/null @@ -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 - } diff --git a/foliage.cabal b/foliage.cabal index bd96505..ee2088d 100644 --- a/foliage.cabal +++ b/foliage.cabal @@ -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, diff --git a/fourmolu.yaml b/fourmolu.yaml index d95c753..6654d7d 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -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: []