module Hackage.Security.TUF.Layout (
RepoRoot
, RepoPath
, RepoLayout(..)
, hackageRepoLayout
, cabalLocalRepoLayout
, anchorRepoPathLocally
, anchorRepoPathRemotely
, IndexRoot
, IndexPath
, IndexLayout(..)
, hackageIndexLayout
, CacheRoot
, CachePath
, CacheLayout(..)
, cabalCacheLayout
, anchorCachePath
) where
import Distribution.Package
import Distribution.Text
import Hackage.Security.Util.Path
data RepoRoot
type RepoPath = Path (Rooted RepoRoot)
instance IsRoot RepoRoot where showRoot _ = "<repo>"
data RepoLayout = RepoLayout {
repoLayoutRoot :: RepoPath
, repoLayoutTimestamp :: RepoPath
, repoLayoutSnapshot :: RepoPath
, repoLayoutMirrors :: RepoPath
, repoLayoutIndexTarGz :: RepoPath
, repoLayoutIndexTar :: RepoPath
, repoLayoutPkgTarGz :: PackageIdentifier -> RepoPath
, repoIndexLayout :: IndexLayout
}
hackageRepoLayout :: RepoLayout
hackageRepoLayout = RepoLayout {
repoLayoutRoot = rp $ fragment' "root.json"
, repoLayoutTimestamp = rp $ fragment' "timestamp.json"
, repoLayoutSnapshot = rp $ fragment' "snapshot.json"
, repoLayoutMirrors = rp $ fragment' "mirrors.json"
, repoLayoutIndexTarGz = rp $ fragment' "01-index.tar.gz"
, repoLayoutIndexTar = rp $ fragment' "01-index.tar"
, repoLayoutPkgTarGz = \pkgId -> rp $ fragment' "package" </> pkgFile pkgId
, repoIndexLayout = hackageIndexLayout
}
where
pkgFile :: PackageIdentifier -> UnrootedPath
pkgFile pkgId = fragment' (display pkgId) <.> "tar.gz"
rp :: UnrootedPath -> RepoPath
rp = rootPath Rooted
cabalLocalRepoLayout :: RepoLayout
cabalLocalRepoLayout = hackageRepoLayout {
repoLayoutPkgTarGz = \pkgId -> rp $ pkgLoc pkgId </> pkgFile pkgId
}
where
pkgLoc :: PackageIdentifier -> UnrootedPath
pkgLoc pkgId = joinFragments [
mkFragment $ display (packageName pkgId)
, mkFragment $ display (packageVersion pkgId)
]
pkgFile :: PackageIdentifier -> UnrootedPath
pkgFile pkgId = fragment' (display pkgId) <.> "tar.gz"
rp :: UnrootedPath -> RepoPath
rp = rootPath Rooted
anchorRepoPathLocally :: IsFileSystemRoot root
=> Path (Rooted root) -> RepoPath -> Path (Rooted root)
anchorRepoPathLocally localRoot repoPath = localRoot </> unrootPath' repoPath
anchorRepoPathRemotely :: URIPath -> RepoPath -> URIPath
anchorRepoPathRemotely remoteRoot repoPath = remoteRoot </> unrootPath' repoPath
data IndexRoot
type IndexPath = Path (Rooted RepoRoot)
instance IsRoot IndexRoot where showRoot _ = "<index>"
data IndexLayout = IndexLayout {
indexLayoutPkgMetadata :: PackageIdentifier -> IndexPath
, indexLayoutPkgCabal :: PackageIdentifier -> IndexPath
}
hackageIndexLayout :: IndexLayout
hackageIndexLayout = IndexLayout {
indexLayoutPkgMetadata = \pkgId -> rp $ pkgLoc pkgId </> pkgMetadata
, indexLayoutPkgCabal = \pkgId -> rp $ pkgLoc pkgId </> pkgCabal pkgId
}
where
pkgLoc :: PackageIdentifier -> UnrootedPath
pkgLoc pkgId = joinFragments [
mkFragment $ display (packageName pkgId)
, mkFragment $ display (packageVersion pkgId)
]
pkgCabal :: PackageIdentifier -> UnrootedPath
pkgCabal pkgId = fragment' (display (packageName pkgId)) <.> "cabal"
pkgMetadata :: UnrootedPath
pkgMetadata = fragment' "package" <.> "json"
rp :: UnrootedPath -> IndexPath
rp = rootPath Rooted
data CacheRoot
type CachePath = Path (Rooted CacheRoot)
instance IsRoot CacheRoot where showRoot _ = "<cache>"
data CacheLayout = CacheLayout {
cacheLayoutRoot :: CachePath
, cacheLayoutTimestamp :: CachePath
, cacheLayoutSnapshot :: CachePath
, cacheLayoutMirrors :: CachePath
, cacheLayoutIndexTar :: CachePath
, cacheLayoutIndexIdx :: CachePath
, cacheLayoutIndexTarGz :: Maybe CachePath
}
cabalCacheLayout :: CacheLayout
cabalCacheLayout = CacheLayout {
cacheLayoutRoot = rp $ fragment' "root.json"
, cacheLayoutTimestamp = rp $ fragment' "timestamp.json"
, cacheLayoutSnapshot = rp $ fragment' "snapshot.json"
, cacheLayoutMirrors = rp $ fragment' "mirrors.json"
, cacheLayoutIndexTar = rp $ fragment' "00-index.tar"
, cacheLayoutIndexIdx = rp $ fragment' "00-index.tar.idx"
, cacheLayoutIndexTarGz = Nothing
}
where
rp :: UnrootedPath -> CachePath
rp = rootPath Rooted
anchorCachePath :: IsFileSystemRoot root
=> Path (Rooted root) -> CachePath -> Path (Rooted root)
anchorCachePath cacheRoot cachePath = cacheRoot </> unrootPath' cachePath