WIP

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

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 (
+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.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
-  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
   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
+    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
           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
+        -- 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
-      ( (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
@@ -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 ->
+    outputDir </> "foliage/packages.json"
-      allPkgSpecs >>= makeMetadataFile path
+      %> \path ->
+        getPkgSpecs >>= makeMetadataFile path
 
     --
     -- 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
-        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
+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 cacheSrcDir allPkgSpecs = do
+makeCabalEntries cabalFileForPkgId allPkgSpecs = do
-  currentTime <- askOracle CurrentTime
+  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 :: 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"
 
@@ -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 <- computeFileInfoSimple sdistPath
-  targetFileInfo <- liftIO $ 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

app/Foliage/HackageSecurity.hs

@@ -1,68 +1,183 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# 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.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.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.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)
+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 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

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
+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
 
 addCacheDirOracle :: FilePath -> Rules (Oracle CacheDir)
 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
 
@@ -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
+  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 []

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

app/Foliage/SourceDist.hs

@@ -2,13 +2,15 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module Foliage.PrepareSdist (
+module Foliage.SourceDist (
-  -- prepareSdist,
+  extractFromTarball,
-  prepareSource,
+  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 ()
+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"]
   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"
+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 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
       ]

app/Foliage/TUF.hs

@@ -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
-        }

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,

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: []