mirror of
https://github.com/input-output-hk/foliage.git
synced 2024-09-11 20:27:09 +03:00
I have no idea what I am doing
This commit is contained in:
parent
e5c01022fe
commit
6971a8cf82
@ -25,6 +25,7 @@ import Development.Shake (
|
||||
action,
|
||||
addOracleCache,
|
||||
addShakeExtra,
|
||||
askOracle,
|
||||
filePattern,
|
||||
forP,
|
||||
getDirectoryFiles,
|
||||
@ -56,6 +57,8 @@ import Distribution.Parsec (simpleParsec)
|
||||
import Distribution.Pretty (prettyShow)
|
||||
import Hackage.Security.Server (FileExpires (..))
|
||||
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.Map.Strict qualified as M
|
||||
import Distribution.Types.Orphans ()
|
||||
import Foliage.FetchURL (addFetchURLRule)
|
||||
import Foliage.HackageSecurity (createKeys)
|
||||
@ -65,6 +68,7 @@ import Foliage.Options
|
||||
import Foliage.Rules.Core
|
||||
import Foliage.Rules.HackageExtra
|
||||
import Foliage.Rules.Pages
|
||||
import Foliage.Rules.Utils (PkgSpecs (..))
|
||||
import Foliage.SourceDist
|
||||
import Foliage.Time
|
||||
|
||||
@ -189,32 +193,31 @@ cmdBuild buildOptions = do
|
||||
-- Index creation
|
||||
--
|
||||
|
||||
getPkgSpecs <- do
|
||||
getPkgSpecs' <- addOracleCache $ \PkgSpecs{} -> do
|
||||
metaFiles <- getDirectoryFiles inputDir ["*/*/meta.toml"]
|
||||
when (null metaFiles) $ do
|
||||
error $
|
||||
unlines
|
||||
[ "We could not find any package metadata file (i.e. _sources/<name>/<version>/meta.toml)"
|
||||
, "Make sure you are passing the right input directory. The default input directory is _sources"
|
||||
]
|
||||
getPkgSpecs <- addOracleCache $ \PkgSpecs -> do
|
||||
metaFiles <- getDirectoryFiles inputDir ["*/*/meta.toml"]
|
||||
when (null metaFiles) $ do
|
||||
error $
|
||||
unlines
|
||||
[ "We could not find any package metadata file (i.e. _sources/<name>/<version>/meta.toml)"
|
||||
, "Make sure you are passing the right input directory. The default input directory is _sources"
|
||||
]
|
||||
|
||||
forP metaFiles $ \path ->
|
||||
case filePattern "*/*/meta.toml" path of
|
||||
Just [name, version] -> do
|
||||
let pkgName = fromMaybe (error $ "invalid package name: " ++ name) $ simpleParsec name
|
||||
let pkgVersion = fromMaybe (error $ "invalid package version: " ++ version) $ simpleParsec version
|
||||
let pkgId = PackageIdentifier pkgName pkgVersion
|
||||
pkgSpec <- packageVersionSpec (inputDir </> path)
|
||||
return (inputDir </> path, pkgId, pkgSpec)
|
||||
_ -> error "the impossible happened"
|
||||
entries <- forP metaFiles $ \path ->
|
||||
case filePattern "*/*/meta.toml" path of
|
||||
Just [name, version] -> do
|
||||
let pkgName = fromMaybe (error $ "invalid package name: " ++ name) $ simpleParsec name
|
||||
let pkgVersion = fromMaybe (error $ "invalid package version: " ++ version) $ simpleParsec version
|
||||
let pkgId = PackageIdentifier pkgName pkgVersion
|
||||
pkgSpec <- packageVersionSpec (inputDir </> path)
|
||||
return (pkgId, (inputDir </> path, pkgSpec))
|
||||
_ -> error "the impossible happened"
|
||||
|
||||
return $ getPkgSpecs' $ PkgSpecs ()
|
||||
return $ M.fromList entries
|
||||
|
||||
--
|
||||
-- Rules for core repository functionality
|
||||
--
|
||||
coreRules outputDir cabalFileForPkgId sdistPathForPkgId currentTime getPkgSpecs
|
||||
coreRules outputDir cabalFileForPkgId sdistPathForPkgId currentTime
|
||||
|
||||
--
|
||||
-- Rules for Hackage-like paths, e.g.
|
||||
@ -222,7 +225,7 @@ cmdBuild buildOptions = do
|
||||
-- package/pkg-id/revision/rev-num.cabal
|
||||
-- package/pkg-id/pkg-name.cabal
|
||||
|
||||
hackageExtraRules outputDir cabalFileForPkgId cabalFileRevisionForPkgId getPkgSpecs
|
||||
hackageExtraRules outputDir cabalFileForPkgId cabalFileRevisionForPkgId pkgSpecForPkgId
|
||||
|
||||
--
|
||||
-- Foliage metadata
|
||||
@ -233,7 +236,7 @@ cmdBuild buildOptions = do
|
||||
need [outputDir </> "foliage/packages.json"]
|
||||
|
||||
outputDir </> "foliage/packages.json" %> \path ->
|
||||
getPkgSpecs >>= \pkgSpecs ->
|
||||
askOracle PkgSpecs >>= \pkgSpecs ->
|
||||
liftIO $
|
||||
Aeson.encodeFile
|
||||
path
|
||||
@ -244,14 +247,14 @@ cmdBuild buildOptions = do
|
||||
]
|
||||
++ ["forced-version" Aeson..= True | packageVersionForce pkgSpec]
|
||||
++ (case packageVersionTimestamp pkgSpec of Nothing -> []; Just t -> ["timestamp" Aeson..= t])
|
||||
| (_, pkgId, pkgSpec) <- pkgSpecs
|
||||
| (pkgId, (_, pkgSpec)) <- M.toList pkgSpecs
|
||||
]
|
||||
|
||||
--
|
||||
-- Website pages
|
||||
--
|
||||
|
||||
websitePagesRules outputDir currentTime getPkgSpecs pkgSpecForPkgId cabalFileForPkgId
|
||||
websitePagesRules outputDir currentTime pkgSpecForPkgId cabalFileForPkgId getPkgSpecs
|
||||
|
||||
validateMeta :: (MonadFail m) => FilePath -> PackageVersionSpec -> m ()
|
||||
validateMeta metaFile PackageVersionSpec{..} = do
|
||||
@ -316,6 +319,3 @@ validateMeta metaFile PackageVersionSpec{..} = do
|
||||
|
||||
doubleDeprecations :: NE.NonEmpty DeprecationSpec -> [NE.NonEmpty DeprecationSpec]
|
||||
doubleDeprecations = filter ((> 1) . length) . NE.groupWith deprecationIsDeprecated
|
||||
|
||||
newtype PkgSpecs = PkgSpecs () deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
|
||||
type instance RuleResult PkgSpecs = [(FilePath, PackageId, PackageVersionSpec)]
|
||||
|
@ -201,13 +201,13 @@ deprecationMetaCodec =
|
||||
timeCodec :: Toml.Key -> TomlCodec UTCTime
|
||||
timeCodec key = Toml.dimap (utcToZonedTime utc) zonedTimeToUTC $ Toml.zonedTime key
|
||||
|
||||
withDefault :: (Eq a) => a -> TomlCodec a -> TomlCodec a
|
||||
withDefault d c = (fromMaybe d <$> Toml.dioptional c) .= f
|
||||
where
|
||||
f a = if a == d then Nothing else Just a
|
||||
|
||||
latestRevisionNumber :: PackageVersionSpec -> Maybe Int
|
||||
latestRevisionNumber sm =
|
||||
case sortOn (Down . revisionNumber) (packageVersionRevisions sm) of
|
||||
[] -> Nothing
|
||||
rev : _ -> Just (revisionNumber rev)
|
||||
|
||||
withDefault :: (Eq a) => a -> TomlCodec a -> TomlCodec a
|
||||
withDefault d c = (fromMaybe d <$> Toml.dioptional c) .= f
|
||||
where
|
||||
f a = if a == d then Nothing else Just a
|
||||
|
@ -15,6 +15,8 @@ import Codec.Compression.GZip qualified as GZip
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Lazy qualified as BSL
|
||||
import Data.ByteString.Lazy.Char8 qualified as C8L
|
||||
import Data.Map (Map)
|
||||
import Data.Map.Strict qualified as M
|
||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
|
||||
import Data.Traversable (for)
|
||||
import Development.Shake
|
||||
@ -25,7 +27,6 @@ import Distribution.Parsec (simpleParsec)
|
||||
import Distribution.Pretty (prettyShow)
|
||||
import Distribution.Simple
|
||||
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
|
||||
import Distribution.Utils.Generic (sndOf3)
|
||||
import Distribution.Verbosity qualified as Verbosity
|
||||
import Hackage.Security.Key.Env (fromKeys)
|
||||
import Hackage.Security.Server (
|
||||
@ -52,15 +53,15 @@ import Hackage.Security.Util.Path qualified as Sec
|
||||
|
||||
import Foliage.HackageSecurity
|
||||
import Foliage.Meta
|
||||
import Foliage.Rules.Utils
|
||||
|
||||
coreRules
|
||||
:: FilePath
|
||||
-> (PackageIdentifier -> FilePath)
|
||||
-> (PackageId -> FilePath)
|
||||
-> UTCTime
|
||||
-> Action [(FilePath, PackageId, PackageVersionSpec)]
|
||||
-> Rules ()
|
||||
coreRules outputDir cabalFileForPkgId sdistPathForPkgId currentTime getPkgSpecs = do
|
||||
coreRules outputDir cabalFileForPkgId sdistPathForPkgId currentTime = do
|
||||
action $ do
|
||||
-- This is all that is necessary since the single source distributions
|
||||
-- are required to build 01-index.tar.
|
||||
@ -75,7 +76,7 @@ coreRules outputDir cabalFileForPkgId sdistPathForPkgId currentTime getPkgSpecs
|
||||
|
||||
getIndexEntries <- do
|
||||
getIndexEntries <- newCache $ \IndexEntries{} -> do
|
||||
pkgSpecs <- getPkgSpecs
|
||||
pkgSpecs <- askOracle PkgSpecs
|
||||
cabalEntries <- makeCabalEntries currentTime cabalFileForPkgId pkgSpecs
|
||||
metadataEntries <- makeMetadataEntries currentTime sdistPathForPkgId pkgSpecs
|
||||
let extraEntries = makeExtraEntries pkgSpecs
|
||||
@ -108,9 +109,9 @@ coreRules outputDir cabalFileForPkgId sdistPathForPkgId currentTime getPkgSpecs
|
||||
liftIO $ packageDirToSdist Verbosity.normal pkgDesc (takeDirectory cabalFilePath) >>= BSL.writeFile path
|
||||
_ -> error $ "The path " ++ path ++ " does not correspond to a valid package"
|
||||
|
||||
makeCabalEntries :: UTCTime -> (PackageId -> FilePath) -> [(FilePath, PackageId, PackageVersionSpec)] -> Action [Tar.Entry]
|
||||
makeCabalEntries :: UTCTime -> (PackageId -> FilePath) -> Map PackageId (FilePath, PackageVersionSpec) -> Action [Tar.Entry]
|
||||
makeCabalEntries currentTime cabalFileForPkgId allPkgSpecs = do
|
||||
fmap concat $ forP allPkgSpecs $ \(metaFile, pkgId, pkgSpec) -> do
|
||||
flip M.foldMapWithKey allPkgSpecs $ \pkgId (metaFile, pkgSpec) -> do
|
||||
let pkgCabalFile = cabalFileForPkgId pkgId
|
||||
pkgTimestamp = fromMaybe currentTime (packageVersionTimestamp pkgSpec)
|
||||
|
||||
@ -125,69 +126,66 @@ makeCabalEntries currentTime cabalFileForPkgId allPkgSpecs = do
|
||||
-- AND 2) Data.List.sortOn is stable. The revised cabal file will always be after the original one.
|
||||
return $ uploadEntry : revisionEntries
|
||||
|
||||
makeMetadataEntries :: UTCTime -> (PackageId -> FilePath) -> [(FilePath, PackageId, PackageVersionSpec)] -> Action [Tar.Entry]
|
||||
makeMetadataEntries :: UTCTime -> (PackageId -> FilePath) -> Map PackageId (FilePath, PackageVersionSpec) -> Action [Tar.Entry]
|
||||
makeMetadataEntries currentTime sdistPathForPkgId allPkgSpecs = do
|
||||
Just expiryTime <- getShakeExtra
|
||||
|
||||
targetKeys <- readKeys "target"
|
||||
|
||||
forP allPkgSpecs $ \(_metaFile, pkgId, pkgSpec) -> do
|
||||
flip M.foldMapWithKey allPkgSpecs $ \pkgId (_metaFile, pkgSpec) -> do
|
||||
let sdistPath = sdistPathForPkgId pkgId
|
||||
pkgTimestamp = fromMaybe currentTime (packageVersionTimestamp pkgSpec)
|
||||
targets <- makeIndexPkgMetadata expiryTime pkgId sdistPath
|
||||
return $ mkTarEntry (renderSignedJSON targetKeys targets) (IndexPkgMetadata pkgId) pkgTimestamp
|
||||
return [mkTarEntry (renderSignedJSON targetKeys targets) (IndexPkgMetadata pkgId) pkgTimestamp]
|
||||
|
||||
-- Currently `extraEntries` are only used for encoding `prefered-versions`.
|
||||
makeExtraEntries :: [(FilePath, PackageId, PackageVersionSpec)] -> [Tar.Entry]
|
||||
makeExtraEntries allPkgSpecs =
|
||||
let
|
||||
-- Group all (package) versions by package (name)
|
||||
groupedPackageVersions :: [NE.NonEmpty (FilePath, PackageId, PackageVersionSpec)]
|
||||
groupedPackageVersions = NE.groupWith sndOf3 allPkgSpecs
|
||||
makeExtraEntries :: Map PackageId (FilePath, PackageVersionSpec) -> [Tar.Entry]
|
||||
makeExtraEntries = M.foldMapWithKey generateEntriesForGroup . groupByPackageName
|
||||
|
||||
-- All versions of a given package together form a list of entries
|
||||
-- The list of entries might be empty (in case no version has been deprecated)
|
||||
generateEntriesForGroup :: NE.NonEmpty (FilePath, PackageId, PackageVersionSpec) -> [Tar.Entry]
|
||||
generateEntriesForGroup packageGroup = map createTarEntry effectiveRanges
|
||||
where
|
||||
-- Get the package name of the current group.
|
||||
pn :: PackageName
|
||||
pn = packageName $ sndOf3 $ NE.head packageGroup
|
||||
-- Collect and sort the deprecation changes for the package group, turning them into a action on VersionRange
|
||||
deprecationChanges :: [(UTCTime, VersionRange -> VersionRange)]
|
||||
deprecationChanges =
|
||||
packageGroup
|
||||
& foldMap
|
||||
( \(_metaFile, pkgId, pkgSpec) ->
|
||||
[ (deprecationTimestamp, rangeAct)
|
||||
| DeprecationSpec{deprecationTimestamp, deprecationIsDeprecated} <- packageVersionDeprecations pkgSpec
|
||||
, let rangeAct =
|
||||
if deprecationIsDeprecated
|
||||
then intersectVersionRanges (notThisVersion (pkgVersion pkgId))
|
||||
else unionVersionRanges (thisVersion (pkgVersion pkgId))
|
||||
]
|
||||
)
|
||||
-- All versions of a given package together form a list of entries
|
||||
-- The list of entries might be empty (in case no version has been deprecated)
|
||||
generateEntriesForGroup :: PackageName -> NE.NonEmpty (Version, PackageVersionSpec) -> [Tar.Entry]
|
||||
generateEntriesForGroup pkgName packageGroup =
|
||||
map createTarEntry effectiveRanges
|
||||
where
|
||||
-- Collect and sort the deprecation changes for the package group, turning them into a action on VersionRange
|
||||
deprecationChanges :: [(UTCTime, VersionRange -> VersionRange)]
|
||||
deprecationChanges =
|
||||
packageGroup
|
||||
& foldMap
|
||||
( \(pkgVersion, pkgSpec) ->
|
||||
[ (deprecationTimestamp, rangeAct)
|
||||
| DeprecationSpec{deprecationTimestamp, deprecationIsDeprecated} <- packageVersionDeprecations pkgSpec
|
||||
, let rangeAct =
|
||||
if deprecationIsDeprecated
|
||||
then intersectVersionRanges (notThisVersion pkgVersion)
|
||||
else unionVersionRanges (thisVersion pkgVersion)
|
||||
]
|
||||
)
|
||||
|
||||
-- Calculate (by applying them chronologically) the effective `VersionRange` for the package group.
|
||||
effectiveRanges :: [(UTCTime, VersionRange)]
|
||||
effectiveRanges = NE.tail $ NE.scanl applyChangeToRange (posixSecondsToUTCTime 0, anyVersion) (sortOn fst deprecationChanges)
|
||||
-- Calculate (by applying them chronologically) the effective `VersionRange` for the package group.
|
||||
effectiveRanges :: [(UTCTime, VersionRange)]
|
||||
effectiveRanges =
|
||||
NE.tail $
|
||||
NE.scanl
|
||||
applyChangeToRange
|
||||
(posixSecondsToUTCTime 0, anyVersion)
|
||||
(sortOn fst deprecationChanges)
|
||||
|
||||
-- Apply a given change (`VersionRange -> VersionRange`) to a `VersionRange` and
|
||||
-- return the simplified the result with a new timestamp.
|
||||
applyChangeToRange
|
||||
:: (UTCTime, VersionRange)
|
||||
-> (UTCTime, VersionRange -> VersionRange)
|
||||
-> (UTCTime, VersionRange)
|
||||
applyChangeToRange (_, range) (ts, change) = (ts, simplifyVersionRange $ change range)
|
||||
-- Apply a given change (`VersionRange -> VersionRange`) to a `VersionRange` and
|
||||
-- return the simplified the result with a new timestamp.
|
||||
applyChangeToRange
|
||||
:: (UTCTime, VersionRange)
|
||||
-> (UTCTime, VersionRange -> VersionRange)
|
||||
-> (UTCTime, VersionRange)
|
||||
applyChangeToRange (_, range) (ts, change) = (ts, simplifyVersionRange $ change range)
|
||||
|
||||
-- Create a `Tar.Entry` for the package group, its computed `VersionRange` and a timestamp.
|
||||
createTarEntry (ts, effectiveRange) = mkTarEntry (C8L.pack $ prettyShow dep) (IndexPkgPrefs pn) ts
|
||||
where
|
||||
-- Cabal uses `Dependency` to represent preferred versions, cf.
|
||||
-- `parsePreferredVersions`. The (sub)libraries part is ignored.
|
||||
dep = mkDependency pn effectiveRange mainLibSet
|
||||
in
|
||||
foldMap generateEntriesForGroup groupedPackageVersions
|
||||
-- Create a `Tar.Entry` for the package group, its computed `VersionRange` and a timestamp.
|
||||
createTarEntry (ts, effectiveRange) = mkTarEntry (C8L.pack $ prettyShow dep) (IndexPkgPrefs pkgName) ts
|
||||
where
|
||||
-- Cabal uses `Dependency` to represent preferred versions, cf.
|
||||
-- `parsePreferredVersions`. The (sub)libraries part is ignored.
|
||||
dep = mkDependency pkgName effectiveRange mainLibSet
|
||||
|
||||
makeIndexPkgCabal :: PackageId -> UTCTime -> FilePath -> Action Tar.Entry
|
||||
makeIndexPkgCabal pkgId timestamp filePath = do
|
||||
|
@ -2,27 +2,25 @@ module Foliage.Rules.HackageExtra (
|
||||
hackageExtraRules,
|
||||
) where
|
||||
|
||||
import Development.Shake (Action, Rules, action, copyFileChanged, filePattern, need, (%>))
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
import Data.Map.Strict qualified as M
|
||||
import Development.Shake (Action, Rules, action, askOracle, copyFileChanged, filePattern, need, (%>))
|
||||
import Development.Shake.FilePath
|
||||
import Distribution.Parsec (simpleParsec)
|
||||
import Distribution.Pretty (prettyShow)
|
||||
import Distribution.Simple (PackageIdentifier (..), unPackageName)
|
||||
import Foliage.Meta (PackageVersionSpec (packageVersionRevisions), RevisionSpec (RevisionSpec, revisionNumber), latestRevisionNumber)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
hackageExtraRules
|
||||
:: FilePath
|
||||
-> (PackageIdentifier -> FilePath)
|
||||
-> (PackageIdentifier -> Int -> FilePath)
|
||||
-> (PackageIdentifier -> Action PackageVersionSpec)
|
||||
-> Action [(FilePath, PackageIdentifier, PackageVersionSpec)]
|
||||
-> Rules ()
|
||||
hackageExtraRules outputDir cabalFileForPkgId cabalFileRevisionForPkgId pkgSpecForPkgId getPkgSpecs = do
|
||||
action $ do
|
||||
getPkgSpecs
|
||||
import Foliage.Meta (PackageVersionSpec (..), RevisionSpec (..), latestRevisionNumber)
|
||||
import Foliage.Rules.Utils
|
||||
|
||||
hackageExtraRules :: FilePath -> Rules ()
|
||||
hackageExtraRules outputDir = do
|
||||
action $
|
||||
askOracle PkgSpecs
|
||||
>>= need
|
||||
. concatMap
|
||||
( \(_, pkgId@PackageIdentifier{pkgName}, pkgSpec) ->
|
||||
. M.foldMapWithKey
|
||||
( \pkgId@PackageIdentifier{pkgName} (_, pkgSpec) ->
|
||||
let baseDir = outputDir </> "package" </> prettyShow pkgId
|
||||
in (baseDir </> unPackageName pkgName <.> "cabal")
|
||||
: (baseDir </> "revision" </> "0.cabal")
|
||||
|
@ -7,17 +7,16 @@ module Foliage.Rules.Pages (
|
||||
websitePagesRules,
|
||||
) where
|
||||
|
||||
import Data.Foldable1 (minimumBy)
|
||||
import Data.Function (on, (&))
|
||||
import Data.Foldable1 qualified as F1
|
||||
import Data.List (sortOn)
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
import Data.Ord (Down (Down), comparing)
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
import Data.Aeson (KeyValue ((.=)), ToJSON, object)
|
||||
import Data.Map qualified as M
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.Text.Lazy.IO.Utf8 qualified as TL
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
|
||||
import Development.Shake
|
||||
import Development.Shake.FilePath
|
||||
@ -27,54 +26,47 @@ import Distribution.Parsec (simpleParsec)
|
||||
import Distribution.Pretty (prettyShow)
|
||||
import Distribution.Simple (PackageId, PackageIdentifier (..))
|
||||
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
|
||||
import Distribution.Utils.Generic (sndOf3)
|
||||
import Distribution.Verbosity qualified as Verbosity
|
||||
import Text.Mustache (Template)
|
||||
import Text.Mustache.Compile.TH (compileMustacheDir)
|
||||
import Text.Mustache.Render (renderMustache)
|
||||
|
||||
import Foliage.Meta (
|
||||
PackageVersionSource,
|
||||
PackageVersionSpec (..),
|
||||
RevisionSpec (..),
|
||||
packageVersionIsDeprecated,
|
||||
)
|
||||
import Foliage.Meta
|
||||
import Foliage.Meta.Aeson ()
|
||||
import Foliage.Utils.Aeson (MyAesonEncoding (..))
|
||||
import Foliage.Rules.Utils
|
||||
import Foliage.Utils.Aeson
|
||||
|
||||
websitePagesRules
|
||||
:: FilePath
|
||||
-> UTCTime
|
||||
-> Action [(FilePath, PackageId, PackageVersionSpec)]
|
||||
-> (PackageId -> Action PackageVersionSpec)
|
||||
-> (PackageId -> FilePath)
|
||||
-> Rules ()
|
||||
websitePagesRules outputDir currentTime getPkgSpecs pkgSpecForPkgId cabalFileForPkgId = do
|
||||
websitePagesRules outputDir currentTime cabalFileForPkgId = do
|
||||
action $ do
|
||||
need
|
||||
[ outputDir </> "index.html"
|
||||
, outputDir </> "all-packages/index.html"
|
||||
, outputDir </> "all-package-versions/index.html"
|
||||
]
|
||||
getPkgSpecs >>= \pkgSpecs ->
|
||||
askOracle PkgSpecs >>= \pkgSpecs ->
|
||||
need
|
||||
[ outputDir </> "package" </> prettyShow pkgId </> "index.html"
|
||||
| (_, pkgId, _) <- pkgSpecs
|
||||
| pkgId <- M.keys pkgSpecs
|
||||
]
|
||||
|
||||
outputDir </> "index.html"
|
||||
%> makeIndexPage
|
||||
|
||||
outputDir </> "all-packages/index.html" %> \path ->
|
||||
getPkgSpecs >>= makeAllPackagesPage currentTime path
|
||||
askOracle PkgSpecs >>= makeAllPackagesPage currentTime path
|
||||
|
||||
outputDir </> "all-package-versions/index.html" %> \path ->
|
||||
getPkgSpecs >>= makeAllPackageVersionsPage currentTime path
|
||||
askOracle PkgSpecs >>= makeAllPackageVersionsPage currentTime path
|
||||
|
||||
outputDir </> "package/*/index.html" %> \path ->
|
||||
case filePattern (outputDir </> "package/*/index.html") path of
|
||||
Just [pkgIdStr] | Just pkgId <- simpleParsec pkgIdStr -> do
|
||||
pkgSpec <- pkgSpecForPkgId pkgId
|
||||
pkgSpec <- askOracle (PkgSpecFor pkgId)
|
||||
let cabalFile = cabalFileForPkgId pkgId
|
||||
need [cabalFile]
|
||||
pkgDesc <- liftIO $ readGenericPackageDescription Verbosity.silent cabalFile
|
||||
@ -98,36 +90,28 @@ data AllPackagesPageEntry = AllPackagesPageEntry
|
||||
deriving stock (Generic)
|
||||
deriving (ToJSON) via MyAesonEncoding AllPackagesPageEntry
|
||||
|
||||
makeAllPackagesPage :: UTCTime -> FilePath -> [(FilePath, PackageId, PackageVersionSpec)] -> Action ()
|
||||
makeAllPackagesPage currentTime path allPkgSpecs = do
|
||||
let packages :: [AllPackagesPageEntry]
|
||||
packages =
|
||||
allPkgSpecs
|
||||
-- group package versions by package name
|
||||
& NE.groupBy ((==) `on` sndOf3)
|
||||
-- for each package name pick the most recent version
|
||||
& map
|
||||
( \group ->
|
||||
-- pick the most recent version
|
||||
minimumBy (comparing $ Down . pkgVersion . sndOf3) group
|
||||
-- turn it into the template data
|
||||
& ( \(_metaFile, pkgId, PackageVersionSpec{packageVersionTimestamp, packageVersionRevisions, packageVersionSource}) ->
|
||||
AllPackagesPageEntry
|
||||
{ allPackagesPageEntryPkgId = pkgId
|
||||
, allPackagesPageEntryTimestamp = fromMaybe currentTime packageVersionTimestamp
|
||||
, allPackagesPageEntryTimestampPosix = utcTimeToPOSIXSeconds (fromMaybe currentTime packageVersionTimestamp)
|
||||
, allPackagesPageEntrySource = packageVersionSource
|
||||
, allPackagesPageEntryLatestRevisionTimestamp = revisionTimestamp <$> listToMaybe packageVersionRevisions
|
||||
}
|
||||
)
|
||||
)
|
||||
-- sort packages by pkgId
|
||||
& sortOn allPackagesPageEntryPkgId
|
||||
|
||||
makeAllPackagesPage :: UTCTime -> FilePath -> Map PackageId (FilePath, PackageVersionSpec) -> Action ()
|
||||
makeAllPackagesPage currentTime path pkgSpecs =
|
||||
liftIO $
|
||||
TL.writeFile path $
|
||||
renderMustache allPackagesPageTemplate $
|
||||
object ["packages" .= packages]
|
||||
where
|
||||
packages =
|
||||
sortOn
|
||||
allPackagesPageEntryPkgId
|
||||
[ AllPackagesPageEntry
|
||||
{ allPackagesPageEntryPkgId = pkgId
|
||||
, allPackagesPageEntryTimestamp = fromMaybe currentTime packageVersionTimestamp
|
||||
, allPackagesPageEntryTimestampPosix = utcTimeToPOSIXSeconds (fromMaybe currentTime packageVersionTimestamp)
|
||||
, allPackagesPageEntrySource = packageVersionSource
|
||||
, allPackagesPageEntryLatestRevisionTimestamp = revisionTimestamp <$> listToMaybe packageVersionRevisions
|
||||
}
|
||||
| (pkgName, pvs) <- M.toList (groupByPackageName pkgSpecs)
|
||||
, let (pkgVersion, pkgSpec) = F1.minimumBy (comparing $ Down . fst) pvs
|
||||
, let PackageVersionSpec{packageVersionTimestamp, packageVersionRevisions, packageVersionSource} = pkgSpec
|
||||
, let pkgId = PackageIdentifier pkgName pkgVersion
|
||||
]
|
||||
|
||||
-- FIXME: refactor this
|
||||
data AllPackageVersionsPageEntry
|
||||
@ -147,55 +131,51 @@ data AllPackageVersionsPageEntry
|
||||
deriving stock (Generic)
|
||||
deriving (ToJSON) via MyAesonEncoding AllPackageVersionsPageEntry
|
||||
|
||||
makeAllPackageVersionsPage :: UTCTime -> FilePath -> [(FilePath, PackageId, PackageVersionSpec)] -> Action ()
|
||||
makeAllPackageVersionsPage currentTime path allPkgSpecs = do
|
||||
let entries =
|
||||
allPkgSpecs
|
||||
-- collect all cabal file revisions including the original cabal file
|
||||
& foldMap
|
||||
( \(_metaFile, pkgId, pkgSpec@PackageVersionSpec{packageVersionSource, packageVersionTimestamp, packageVersionRevisions}) ->
|
||||
-- original cabal file
|
||||
AllPackageVersionsPageEntryPackage
|
||||
{ allPackageVersionsPageEntryPkgId = pkgId
|
||||
, allPackageVersionsPageEntryTimestamp = fromMaybe currentTime packageVersionTimestamp
|
||||
, allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds (fromMaybe currentTime packageVersionTimestamp)
|
||||
, allPackageVersionsPageEntrySource = packageVersionSource
|
||||
, allPackageVersionsPageEntryDeprecated = packageVersionIsDeprecated pkgSpec
|
||||
}
|
||||
-- list of revisions
|
||||
: [ AllPackageVersionsPageEntryRevision
|
||||
{ allPackageVersionsPageEntryPkgId = pkgId
|
||||
, allPackageVersionsPageEntryTimestamp = revisionTimestamp
|
||||
, allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds revisionTimestamp
|
||||
, allPackageVersionsPageEntryDeprecated = packageVersionIsDeprecated pkgSpec
|
||||
}
|
||||
| RevisionSpec{revisionTimestamp} <- packageVersionRevisions
|
||||
]
|
||||
)
|
||||
-- sort them by timestamp
|
||||
& sortOn (Down . allPackageVersionsPageEntryTimestamp)
|
||||
|
||||
makeAllPackageVersionsPage :: UTCTime -> FilePath -> Map PackageId (FilePath, PackageVersionSpec) -> Action ()
|
||||
makeAllPackageVersionsPage currentTime path pkgSpecs =
|
||||
liftIO $
|
||||
TL.writeFile path $
|
||||
renderMustache allPackageVersionsPageTemplate $
|
||||
object ["entries" .= entries]
|
||||
where
|
||||
entries =
|
||||
sortOn (Down . allPackageVersionsPageEntryTimestamp)
|
||||
-- collect all cabal file revisions including the original cabal file
|
||||
. M.foldMapWithKey
|
||||
( \pkgId (_, pkgSpec) ->
|
||||
-- original cabal file
|
||||
AllPackageVersionsPageEntryPackage
|
||||
{ allPackageVersionsPageEntryPkgId = pkgId
|
||||
, allPackageVersionsPageEntryTimestamp = fromMaybe currentTime $ packageVersionTimestamp pkgSpec
|
||||
, allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds $ fromMaybe currentTime $ packageVersionTimestamp pkgSpec
|
||||
, allPackageVersionsPageEntrySource = packageVersionSource pkgSpec
|
||||
, allPackageVersionsPageEntryDeprecated = packageVersionIsDeprecated pkgSpec
|
||||
--
|
||||
}
|
||||
-- list of revisions
|
||||
: [ AllPackageVersionsPageEntryRevision
|
||||
{ allPackageVersionsPageEntryPkgId = pkgId
|
||||
, allPackageVersionsPageEntryTimestamp = revisionTimestamp
|
||||
, allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds revisionTimestamp
|
||||
, allPackageVersionsPageEntryDeprecated = packageVersionIsDeprecated pkgSpec
|
||||
}
|
||||
| RevisionSpec{revisionTimestamp} <- packageVersionRevisions pkgSpec
|
||||
]
|
||||
)
|
||||
$ pkgSpecs
|
||||
|
||||
makePackageVersionPage :: FilePath -> GenericPackageDescription -> PackageVersionSpec -> Action ()
|
||||
makePackageVersionPage
|
||||
path
|
||||
pkgDesc
|
||||
pkgSpec@PackageVersionSpec{packageVersionSource, packageVersionRevisions, packageVersionTimestamp} =
|
||||
let
|
||||
in liftIO $
|
||||
TL.writeFile path $
|
||||
renderMustache packageVersionPageTemplate $
|
||||
object
|
||||
[ "pkgVersionSource" .= packageVersionSource
|
||||
, "cabalFileRevisions" .= map revisionTimestamp packageVersionRevisions
|
||||
, "pkgDesc" .= jsonGenericPackageDescription pkgDesc
|
||||
, "pkgTimestamp" .= packageVersionTimestamp
|
||||
, "pkgVersionDeprecated" .= packageVersionIsDeprecated pkgSpec
|
||||
]
|
||||
makePackageVersionPage path pkgDesc pkgSpec =
|
||||
liftIO $
|
||||
TL.writeFile path $
|
||||
renderMustache packageVersionPageTemplate $
|
||||
object
|
||||
[ "pkgVersionSource" .= packageVersionSource pkgSpec
|
||||
, "cabalFileRevisions" .= map revisionTimestamp (packageVersionRevisions pkgSpec)
|
||||
, "pkgDesc" .= jsonGenericPackageDescription pkgDesc
|
||||
, "pkgTimestamp" .= packageVersionTimestamp pkgSpec
|
||||
, "pkgVersionDeprecated" .= packageVersionIsDeprecated pkgSpec
|
||||
]
|
||||
|
||||
indexPageTemplate :: Template
|
||||
indexPageTemplate = $(compileMustacheDir "index" "templates")
|
||||
|
36
app/Foliage/Rules/Utils.hs
Normal file
36
app/Foliage/Rules/Utils.hs
Normal file
@ -0,0 +1,36 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Foliage.Rules.Utils where
|
||||
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Map
|
||||
import Data.Map.Strict qualified as M
|
||||
import Development.Shake
|
||||
import Development.Shake.Classes
|
||||
import Distribution.Package (PackageId)
|
||||
import Distribution.PackageDescription (PackageIdentifier (..), PackageName)
|
||||
import Distribution.Version (Version)
|
||||
import Foliage.Meta
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
groupByPackageName :: Map PackageId (FilePath, PackageVersionSpec) -> Map PackageName (NE.NonEmpty (Version, PackageVersionSpec))
|
||||
groupByPackageName pkgSpecs =
|
||||
M.fromListWith
|
||||
(<>)
|
||||
[ (pkgName pkgId, NE.singleton (pkgVersion pkgId, pkgSpec))
|
||||
| (pkgId, (_metaFile, pkgSpec)) <- M.toList pkgSpecs
|
||||
]
|
||||
|
||||
newtype PkgSpecFor = PkgSpecFor PackageId
|
||||
deriving stock (Show, Eq, Generic)
|
||||
deriving anyclass (Hashable, Binary, NFData)
|
||||
|
||||
type instance RuleResult PkgSpecFor = PackageVersionSpec
|
||||
|
||||
data PkgSpecs = PkgSpecs
|
||||
deriving stock (Show, Eq, Generic)
|
||||
deriving anyclass (Hashable, Binary, NFData)
|
||||
|
||||
type instance RuleResult PkgSpecs = Map PackageId (FilePath, PackageVersionSpec)
|
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
@ -18,6 +19,8 @@ import Data.List (dropWhileEnd)
|
||||
import Development.Shake (
|
||||
Action,
|
||||
CmdOption (..),
|
||||
RuleResult,
|
||||
Rules,
|
||||
cmd_,
|
||||
getDirectoryFiles,
|
||||
liftIO,
|
||||
@ -32,16 +35,50 @@ import Development.Shake.FilePath (
|
||||
)
|
||||
import Distribution.Compat.Lens (set)
|
||||
import Distribution.PackageDescription.PrettyPrint (writeGenericPackageDescription)
|
||||
import Distribution.Simple (Version)
|
||||
import Distribution.Simple (PackageId, Version)
|
||||
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
|
||||
import Distribution.Types.Lens qualified as L
|
||||
import Distribution.Verbosity qualified as Verbosity
|
||||
import Network.URI (URI (..), URIAuth (..))
|
||||
import Network.URI (URI (..), URIAuth (..), pathSegments)
|
||||
import System.Directory qualified as IO
|
||||
|
||||
import Development.Shake.Classes
|
||||
import Development.Shake.Rule
|
||||
import Distribution.Pretty (prettyShow)
|
||||
import Foliage.FetchURL (fetchURL)
|
||||
import Foliage.Meta (PackageVersionSource (..))
|
||||
import Foliage.Utils.GitHub (githubRepoTarballUrl)
|
||||
import GHC.Generics (Generic)
|
||||
import Hackage.Security.Util.Path (joinFragments)
|
||||
|
||||
data FetchSource = FetchSource PackageId PackageVersionSource
|
||||
deriving stock (Eq, Show, Generic)
|
||||
deriving anyclass (Hashable, Binary, NFData)
|
||||
|
||||
type instance RuleResult FetchSource = FilePath
|
||||
|
||||
fetchSource :: PackageId -> PackageVersionSource -> Action FilePath
|
||||
fetchSource pkgId pvs = apply1 $ FetchSource pkgId pvs
|
||||
|
||||
addFetchSourceRule :: Rules ()
|
||||
addFetchSourceRule = addBuiltinRule noLint noIdentity run
|
||||
where
|
||||
run (FetchSource pkgId pvs) oldETag _mode = do
|
||||
let dstDir = "_cache/packages" </> prettyShow pkgId
|
||||
|
||||
case pvs of
|
||||
(URISource (URI{uriScheme, uriPath}) mSubdir) | uriScheme == "file:" -> do
|
||||
tarballPath <- liftIO $ IO.makeAbsolute uriPath
|
||||
extractFromTarball tarballPath mSubdir
|
||||
(URISource uri mSubdir) -> do
|
||||
tarballPath <- cachePathForURL cacheDir uri
|
||||
fetchURL uri tarballPath
|
||||
extractFromTarball tarballPath mSubdir
|
||||
(GitHubSource repo rev mSubdir) -> do
|
||||
let uri = githubRepoTarballUrl repo rev
|
||||
tarballPath <- cachePathForURL cacheDir uri
|
||||
fetchURL uri tarballPath
|
||||
extractFromTarball tarballPath mSubdir
|
||||
|
||||
applyPatches :: FilePath -> FilePath -> Action ()
|
||||
applyPatches metaFile pkgDir = do
|
||||
@ -75,10 +112,9 @@ updateCabalFileVersion path pkgVersion = do
|
||||
liftIO $ writeGenericPackageDescription path pkgDesc'
|
||||
|
||||
cachePathForURL :: FilePath -> URI -> Action FilePath
|
||||
cachePathForURL cacheDir uri = do
|
||||
cachePathForURL uri = do
|
||||
let scheme = dropWhileEnd (not . isAlpha) $ uriScheme uri
|
||||
host = maybe (error $ "invalid uri " ++ show uri) uriRegName (uriAuthority uri)
|
||||
return $ cacheDir </> scheme </> host <//> uriPath uri
|
||||
|
||||
extractFromTarball :: FilePath -> Maybe FilePath -> FilePath -> Action ()
|
||||
extractFromTarball tarballPath mSubdir destDir = do
|
||||
|
@ -34,6 +34,7 @@ executable foliage
|
||||
Foliage.Rules.Core
|
||||
Foliage.Rules.HackageExtra
|
||||
Foliage.Rules.Pages
|
||||
Foliage.Rules.Utils
|
||||
Foliage.SourceDist
|
||||
Foliage.Time
|
||||
Foliage.Utils.Aeson
|
||||
|
Loading…
Reference in New Issue
Block a user