diff --git a/.github/workflows/formatting.yaml b/.github/workflows/formatting.yaml new file mode 100644 index 0000000..c4e1217 --- /dev/null +++ b/.github/workflows/formatting.yaml @@ -0,0 +1,16 @@ +name: Check code formatting + +on: + pull_request: + +jobs: + build: + runs-on: + - ubuntu-latest + + steps: + - uses: actions/checkout@v4 + + - uses: haskell-actions/run-fourmolu@v9 + with: + version: "0.14.0.0" diff --git a/app/Distribution/Aeson.hs b/app/Distribution/Aeson.hs index f412dbc..15014ef 100644 --- a/app/Distribution/Aeson.hs +++ b/app/Distribution/Aeson.hs @@ -144,33 +144,33 @@ jsonField fn v | v == emptyArray = mempty | v == emptyString = mempty | otherwise = [Key.fromString (fromUTF8BS fn) .= v] - where - -- Should be added to aeson - emptyString :: Value - emptyString = String "" + where + -- Should be added to aeson + emptyString :: Value + emptyString = String "" jsonGenericPackageDescription :: GenericPackageDescription -> Value jsonGenericPackageDescription gpd = jsonGenericPackageDescription' v gpd - where - v = specVersion $ packageDescription gpd + where + v = specVersion $ packageDescription gpd jsonGenericPackageDescription' :: CabalSpecVersion -> GenericPackageDescription -> Value jsonGenericPackageDescription' v gpd = object $ concat - [ jsonPackageDescription v (packageDescription gpd), - jsonSetupBuildInfo v (setupBuildInfo (packageDescription gpd)), - jsonGenPackageFlags v (genPackageFlags gpd), - jsonCondLibrary v (condLibrary gpd), - jsonCondSubLibraries v (condSubLibraries gpd), - jsonCondForeignLibs v (condForeignLibs gpd), - jsonCondExecutables v (condExecutables gpd), - jsonCondTestSuites v (condTestSuites gpd), - jsonCondBenchmarks v (condBenchmarks gpd) + [ jsonPackageDescription v (packageDescription gpd) + , jsonSetupBuildInfo v (setupBuildInfo (packageDescription gpd)) + , jsonGenPackageFlags v (genPackageFlags gpd) + , jsonCondLibrary v (condLibrary gpd) + , jsonCondSubLibraries v (condSubLibraries gpd) + , jsonCondForeignLibs v (condForeignLibs gpd) + , jsonCondExecutables v (condExecutables gpd) + , jsonCondTestSuites v (condTestSuites gpd) + , jsonCondBenchmarks v (condBenchmarks gpd) ] jsonPackageDescription :: CabalSpecVersion -> PackageDescription -> [Pair] -jsonPackageDescription v pd@PackageDescription {sourceRepos, setupBuildInfo} = +jsonPackageDescription v pd@PackageDescription{sourceRepos, setupBuildInfo} = jsonFieldGrammar v packageDescriptionFieldGrammar pd <> jsonSourceRepos v sourceRepos <> jsonSetupBuildInfo v setupBuildInfo @@ -180,7 +180,7 @@ jsonSourceRepos v = concatMap (\neRepos -> ["source-repository" .= NE.map (jsonSourceRepo v) neRepos]) . NE.nonEmpty jsonSourceRepo :: CabalSpecVersion -> SourceRepo -> Value -jsonSourceRepo v repo@SourceRepo {repoKind} = +jsonSourceRepo v repo@SourceRepo{repoKind} = object $ jsonFieldGrammar v (sourceRepoFieldGrammar repoKind) repo jsonSetupBuildInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [Pair] @@ -241,33 +241,33 @@ jsonCondBenchmark v (n, condTree) = jsonCondTree :: forall a. CabalSpecVersion -> JSONFieldGrammar' a -> CondTree ConfVar [Dependency] a -> Value jsonCondTree v grammar = toJSON . go . fmap fst . conv - where - go (CondFlat a ifs) = - KeyMap.fromListWith (<>) $ - second (: []) - <$> jsonFieldGrammar v grammar a ++ concatMap (\(cv, a') -> second (ifc cv) <$> jsonFieldGrammar v grammar a') ifs + where + go (CondFlat a ifs) = + KeyMap.fromListWith (<>) $ + second (: []) + <$> jsonFieldGrammar v grammar a ++ concatMap (\(cv, a') -> second (ifc cv) <$> jsonFieldGrammar v grammar a') ifs - ifc cv a = object ["if" .= showCondition cv, "then" .= a] + ifc cv a = object ["if" .= showCondition cv, "then" .= a] data CondFlat v a = CondFlat a [(Condition v, a)] deriving (Show, Functor) conv :: forall v c a. CondTree v c a -> CondFlat v (a, c) conv = goNode - where - goNode (CondNode a c ifs) = - CondFlat (a, c) (concatMap goBranch ifs) - - goBranch (CondBranch cond thenTree Nothing) = - let (CondFlat a ifs) = goNode thenTree - in (cond, a) : fmap (first (cond `cAnd`)) ifs - goBranch (CondBranch cond thenTree (Just elseTree)) = - let (CondFlat a1 ifs1) = goNode thenTree - (CondFlat a2 ifs2) = goNode elseTree - in (cond, a1) - : (first (cond `cAnd`) <$> ifs1) - ++ (cNot cond, a2) - : (first (cNot cond `cAnd`) <$> ifs2) + where + goNode (CondNode a c ifs) = + CondFlat (a, c) (concatMap goBranch ifs) + + goBranch (CondBranch cond thenTree Nothing) = + let (CondFlat a ifs) = goNode thenTree + in (cond, a) : fmap (first (cond `cAnd`)) ifs + goBranch (CondBranch cond thenTree (Just elseTree)) = + let (CondFlat a1 ifs1) = goNode thenTree + (CondFlat a2 ifs2) = goNode elseTree + in (cond, a1) + : (first (cond `cAnd`) <$> ifs1) + ++ (cNot cond, a2) + : (first (cNot cond `cAnd`) <$> ifs2) test :: FilePath -> IO () test fn = do diff --git a/app/Foliage/CmdBuild.hs b/app/Foliage/CmdBuild.hs index 42805ae..69bf4c6 100644 --- a/app/Foliage/CmdBuild.hs +++ b/app/Foliage/CmdBuild.hs @@ -48,24 +48,24 @@ cmdBuild buildOptions = do addPrepareSdistRule outputDirRoot phony "buildAction" (buildAction buildOptions) want ["buildAction"] - where - cacheDir = "_cache" - opts = - shakeOptions - { shakeFiles = cacheDir, - shakeVerbosity = Verbose, - shakeThreads = buildOptsNumThreads buildOptions - } + where + cacheDir = "_cache" + opts = + shakeOptions + { shakeFiles = cacheDir + , shakeVerbosity = Verbose + , shakeThreads = buildOptsNumThreads buildOptions + } buildAction :: BuildOptions -> Action () buildAction BuildOptions - { buildOptsSignOpts = signOpts, - buildOptsCurrentTime = mCurrentTime, - buildOptsExpireSignaturesOn = mExpireSignaturesOn, - buildOptsInputDir = inputDir, - buildOptsOutputDir = outputDir, - buildOptsWriteMetadata = doWritePackageMeta + { buildOptsSignOpts = signOpts + , buildOptsCurrentTime = mCurrentTime + , buildOptsExpireSignaturesOn = mExpireSignaturesOn + , buildOptsInputDir = inputDir + , buildOptsOutputDir = outputDir + , buildOptsWriteMetadata = doWritePackageMeta } = do outputDirRoot <- liftIO $ makeAbsolute (fromFilePath outputDir) @@ -108,7 +108,7 @@ buildAction cabalEntries <- foldMap - ( \PreparedPackageVersion {pkgId, pkgTimestamp, cabalFilePath, originalCabalFilePath, cabalFileRevisions} -> do + ( \PreparedPackageVersion{pkgId, pkgTimestamp, cabalFilePath, originalCabalFilePath, cabalFileRevisions} -> do -- original cabal file, with its timestamp (if specified) copyFileChanged originalCabalFilePath (outputDir "package" prettyShow pkgId "revision" "0" <.> "cabal") cf <- prepareIndexPkgCabal pkgId (fromMaybe currentTime pkgTimestamp) originalCabalFilePath @@ -131,7 +131,7 @@ buildAction targetKeys <- maybeReadKeysAt "target" metadataEntries <- - forP packageVersions $ \ppv@PreparedPackageVersion {pkgId, pkgTimestamp} -> do + forP packageVersions $ \ppv@PreparedPackageVersion{pkgId, pkgTimestamp} -> do targets <- prepareIndexPkgMetadata expiryTime ppv pure $ mkTarEntry @@ -156,51 +156,51 @@ buildAction liftIO $ writeSignedJSON outputDirRoot repoLayoutMirrors privateKeysMirrors $ Mirrors - { mirrorsVersion = FileVersion 1, - mirrorsExpires = FileExpires expiryTime, - mirrorsMirrors = [] + { mirrorsVersion = FileVersion 1 + , mirrorsExpires = FileExpires expiryTime + , mirrorsMirrors = [] } liftIO $ writeSignedJSON outputDirRoot repoLayoutRoot privateKeysRoot $ Root - { rootVersion = FileVersion 1, - rootExpires = FileExpires expiryTime, - rootKeys = + { rootVersion = FileVersion 1 + , rootExpires = FileExpires expiryTime + , rootKeys = fromKeys $ concat - [ privateKeysRoot, - privateKeysTarget, - privateKeysSnapshot, - privateKeysTimestamp, - privateKeysMirrors - ], - rootRoles = + [ privateKeysRoot + , privateKeysTarget + , privateKeysSnapshot + , privateKeysTimestamp + , privateKeysMirrors + ] + , rootRoles = RootRoles { rootRolesRoot = RoleSpec - { roleSpecKeys = map somePublicKey privateKeysRoot, - roleSpecThreshold = KeyThreshold 2 - }, - rootRolesSnapshot = + { roleSpecKeys = map somePublicKey privateKeysRoot + , roleSpecThreshold = KeyThreshold 2 + } + , rootRolesSnapshot = RoleSpec - { roleSpecKeys = map somePublicKey privateKeysSnapshot, - roleSpecThreshold = KeyThreshold 1 - }, - rootRolesTargets = + { roleSpecKeys = map somePublicKey privateKeysSnapshot + , roleSpecThreshold = KeyThreshold 1 + } + , rootRolesTargets = RoleSpec - { roleSpecKeys = map somePublicKey privateKeysTarget, - roleSpecThreshold = KeyThreshold 1 - }, - rootRolesTimestamp = + { roleSpecKeys = map somePublicKey privateKeysTarget + , roleSpecThreshold = KeyThreshold 1 + } + , rootRolesTimestamp = RoleSpec - { roleSpecKeys = map somePublicKey privateKeysTimestamp, - roleSpecThreshold = KeyThreshold 1 - }, - rootRolesMirrors = + { roleSpecKeys = map somePublicKey privateKeysTimestamp + , roleSpecThreshold = KeyThreshold 1 + } + , rootRolesMirrors = RoleSpec - { roleSpecKeys = map somePublicKey privateKeysMirrors, - roleSpecThreshold = KeyThreshold 1 + { roleSpecKeys = map somePublicKey privateKeysMirrors + , roleSpecThreshold = KeyThreshold 1 } } } @@ -213,21 +213,21 @@ buildAction liftIO $ writeSignedJSON outputDirRoot repoLayoutSnapshot privateKeysSnapshot $ Snapshot - { snapshotVersion = FileVersion 1, - snapshotExpires = FileExpires expiryTime, - snapshotInfoRoot = rootInfo, - snapshotInfoMirrors = mirrorsInfo, - snapshotInfoTar = Just tarInfo, - snapshotInfoTarGz = tarGzInfo + { snapshotVersion = FileVersion 1 + , snapshotExpires = FileExpires expiryTime + , snapshotInfoRoot = rootInfo + , snapshotInfoMirrors = mirrorsInfo + , snapshotInfoTar = Just tarInfo + , snapshotInfoTarGz = tarGzInfo } snapshotInfo <- computeFileInfoSimple' (anchorPath outputDirRoot repoLayoutSnapshot) liftIO $ writeSignedJSON outputDirRoot repoLayoutTimestamp privateKeysTimestamp $ Timestamp - { timestampVersion = FileVersion 1, - timestampExpires = FileExpires expiryTime, - timestampInfoSnapshot = snapshotInfo + { timestampVersion = FileVersion 1 + , timestampExpires = FileExpires expiryTime + , timestampInfoSnapshot = snapshotInfo } makeMetadataFile :: FilePath -> [PreparedPackageVersion] -> Action () @@ -236,37 +236,37 @@ makeMetadataFile outputDir packageVersions = traced "writing metadata" $ do Aeson.encodeFile (outputDir "foliage" "packages.json") (map encodePackageVersion packageVersions) - where - encodePackageVersion - PreparedPackageVersion - { pkgId = PackageIdentifier {pkgName, pkgVersion}, - pkgTimestamp, - pkgVersionForce, - pkgVersionSource - } = - Aeson.object - ( [ "pkg-name" Aeson..= pkgName, - "pkg-version" Aeson..= pkgVersion, - "url" Aeson..= sourceUrl pkgVersionSource - ] - ++ ["forced-version" Aeson..= True | pkgVersionForce] - ++ (case pkgTimestamp of Nothing -> []; Just t -> ["timestamp" Aeson..= t]) - ) - - sourceUrl :: PackageVersionSource -> URI - sourceUrl (TarballSource uri Nothing) = uri - sourceUrl (TarballSource uri (Just subdir)) = uri {uriQuery = "?dir=" ++ subdir} - sourceUrl (GitHubSource repo rev Nothing) = - nullURI - { uriScheme = "github:", - uriPath = T.unpack (unGitHubRepo repo) T.unpack (unGitHubRev rev) - } - sourceUrl (GitHubSource repo rev (Just subdir)) = - nullURI - { uriScheme = "github:", - uriPath = T.unpack (unGitHubRepo repo) T.unpack (unGitHubRev rev), - uriQuery = "?dir=" ++ subdir - } + where + encodePackageVersion + PreparedPackageVersion + { pkgId = PackageIdentifier{pkgName, pkgVersion} + , pkgTimestamp + , pkgVersionForce + , pkgVersionSource + } = + Aeson.object + ( [ "pkg-name" Aeson..= pkgName + , "pkg-version" Aeson..= pkgVersion + , "url" Aeson..= sourceUrl pkgVersionSource + ] + ++ ["forced-version" Aeson..= True | pkgVersionForce] + ++ (case pkgTimestamp of Nothing -> []; Just t -> ["timestamp" Aeson..= t]) + ) + + sourceUrl :: PackageVersionSource -> URI + sourceUrl (TarballSource uri Nothing) = uri + sourceUrl (TarballSource uri (Just subdir)) = uri{uriQuery = "?dir=" ++ subdir} + sourceUrl (GitHubSource repo rev Nothing) = + nullURI + { uriScheme = "github:" + , uriPath = T.unpack (unGitHubRepo repo) T.unpack (unGitHubRev rev) + } + sourceUrl (GitHubSource repo rev (Just subdir)) = + nullURI + { uriScheme = "github:" + , uriPath = T.unpack (unGitHubRepo repo) T.unpack (unGitHubRev rev) + , uriQuery = "?dir=" ++ subdir + } getPackageVersions :: FilePath -> Action [PreparedPackageVersion] getPackageVersions inputDir = do @@ -275,8 +275,8 @@ getPackageVersions inputDir = do when (null metaFiles) $ do error $ unlines - [ "We could not find any package metadata file (i.e. _sources///meta.toml)", - "Make sure you are passing the right input directory. The default input directory is _sources" + [ "We could not find any package metadata file (i.e. _sources///meta.toml)" + , "Make sure you are passing the right input directory. The default input directory is _sources" ] forP metaFiles $ preparePackageVersion inputDir @@ -288,46 +288,48 @@ prepareIndexPkgCabal pkgId timestamp filePath = do pure $ mkTarEntry (BL.fromStrict contents) (IndexPkgCabal pkgId) timestamp prepareIndexPkgMetadata :: Maybe UTCTime -> PreparedPackageVersion -> Action Targets -prepareIndexPkgMetadata expiryTime PreparedPackageVersion {pkgId, sdistPath} = do +prepareIndexPkgMetadata expiryTime PreparedPackageVersion{pkgId, sdistPath} = do targetFileInfo <- liftIO $ computeFileInfoSimple sdistPath let packagePath = repoLayoutPkgTarGz hackageRepoLayout pkgId return Targets - { targetsVersion = FileVersion 1, - targetsExpires = FileExpires expiryTime, - targetsTargets = fromList [(TargetPathRepo packagePath, targetFileInfo)], - targetsDelegations = Nothing + { targetsVersion = FileVersion 1 + , targetsExpires = FileExpires expiryTime + , targetsTargets = fromList [(TargetPathRepo packagePath, targetFileInfo)] + , targetsDelegations = Nothing } -- Currently `extraEntries` are only used for encoding `prefered-versions`. getExtraEntries :: [PreparedPackageVersion] -> [Tar.Entry] getExtraEntries packageVersions = - let -- Group all (package) versions by package (name) - groupedPackageVersions :: [NE.NonEmpty PreparedPackageVersion] - groupedPackageVersions = NE.groupWith (pkgName . pkgId) packageVersions - - -- 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 PreparedPackageVersion -> [Tar.Entry] - generateEntriesForGroup packageGroup = map createTarEntry effectiveRanges - where - -- Get the package name of the current group. - pn :: PackageName - pn = pkgName $ pkgId $ 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 = sortOn fst $ foldMap versionDeprecationChanges packageGroup - -- Calculate (by applying them chronologically) the effective `VersionRange` for the package group. - effectiveRanges :: [(UTCTime, VersionRange)] - effectiveRanges = NE.tail $ NE.scanl applyChangeToRange (posixSecondsToUTCTime 0, anyVersion) deprecationChanges - - -- Create a `Tar.Entry` for the package group, its computed `VersionRange` and a timestamp. - createTarEntry (ts, effectiveRange) = mkTarEntry (BL.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 + let + -- Group all (package) versions by package (name) + groupedPackageVersions :: [NE.NonEmpty PreparedPackageVersion] + groupedPackageVersions = NE.groupWith (pkgName . pkgId) packageVersions + + -- 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 PreparedPackageVersion -> [Tar.Entry] + generateEntriesForGroup packageGroup = map createTarEntry effectiveRanges + where + -- Get the package name of the current group. + pn :: PackageName + pn = pkgName $ pkgId $ 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 = sortOn fst $ foldMap versionDeprecationChanges packageGroup + -- Calculate (by applying them chronologically) the effective `VersionRange` for the package group. + effectiveRanges :: [(UTCTime, VersionRange)] + effectiveRanges = NE.tail $ NE.scanl applyChangeToRange (posixSecondsToUTCTime 0, anyVersion) deprecationChanges + + -- Create a `Tar.Entry` for the package group, its computed `VersionRange` and a timestamp. + createTarEntry (ts, effectiveRange) = mkTarEntry (BL.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 -- TODO: the functions belows should be moved to Foliage.PreparedPackageVersion @@ -335,8 +337,8 @@ getExtraEntries packageVersions = versionDeprecationChanges :: PreparedPackageVersion -> [(UTCTime, VersionRange -> VersionRange)] versionDeprecationChanges PreparedPackageVersion - { pkgId = PackageIdentifier {pkgVersion}, - pkgVersionDeprecationChanges + { pkgId = PackageIdentifier{pkgVersion} + , pkgVersionDeprecationChanges } = map (second $ applyDeprecation pkgVersion) pkgVersionDeprecationChanges @@ -356,21 +358,21 @@ applyDeprecation pkgVersion deprecated = mkTarEntry :: BL.ByteString -> IndexFile dec -> UTCTime -> Tar.Entry mkTarEntry contents indexFile timestamp = (Tar.fileEntry tarPath contents) - { Tar.entryTime = floor $ Time.utcTimeToPOSIXSeconds timestamp, - Tar.entryOwnership = + { Tar.entryTime = floor $ Time.utcTimeToPOSIXSeconds timestamp + , Tar.entryOwnership = Tar.Ownership - { Tar.ownerName = "foliage", - Tar.groupName = "foliage", - Tar.ownerId = 0, - Tar.groupId = 0 + { Tar.ownerName = "foliage" + , Tar.groupName = "foliage" + , Tar.ownerId = 0 + , Tar.groupId = 0 } } - where - tarPath = case Tar.toTarPath False indexPath of - Left e -> error $ "Invalid tar path " ++ indexPath ++ "(" ++ e ++ ")" - Right tp -> tp + where + tarPath = case Tar.toTarPath False indexPath of + Left e -> error $ "Invalid tar path " ++ indexPath ++ "(" ++ e ++ ")" + Right tp -> tp - indexPath = toFilePath $ castRoot $ indexFileToPath hackageIndexLayout indexFile + indexPath = toFilePath $ castRoot $ indexFileToPath hackageIndexLayout indexFile anchorPath :: Path Absolute -> (RepoLayout -> RepoPath) -> FilePath anchorPath outputDirRoot p = diff --git a/app/Foliage/CmdImportIndex.hs b/app/Foliage/CmdImportIndex.hs index 1a4522f..3949789 100644 --- a/app/Foliage/CmdImportIndex.hs +++ b/app/Foliage/CmdImportIndex.hs @@ -1,8 +1,8 @@ {-# LANGUAGE ViewPatterns #-} -module Foliage.CmdImportIndex - ( cmdImportIndex, - ) +module Foliage.CmdImportIndex ( + cmdImportIndex, +) where import Codec.Archive.Tar qualified as Tar @@ -29,55 +29,56 @@ cmdImportIndex :: ImportIndexOptions -> IO () cmdImportIndex opts = do putStrLn $ unlines - [ "This command is EXPERIMENTAL and INCOMPLETE!", - "Import the Hackage index from $HOME/.cabal. Make sure you have done `cabal update` recently." + [ "This command is EXPERIMENTAL and INCOMPLETE!" + , "Import the Hackage index from $HOME/.cabal. Make sure you have done `cabal update` recently." ] home <- getEnv "HOME" entries <- Tar.read <$> BSL.readFile (home ".cabal/packages/hackage.haskell.org/01-index.tar") m <- importIndex indexfilter entries M.empty for_ (M.toList m) $ uncurry finalise - where - indexfilter = case importOptsFilter opts of - Nothing -> const True - (Just f) -> mkFilter f + where + indexfilter = case importOptsFilter opts of + Nothing -> const True + (Just f) -> mkFilter f - mkFilter (ImportFilter pn Nothing) = (== pn) . unPackageName . pkgName - mkFilter (ImportFilter pn (Just pv)) = (&&) <$> (== pn) . unPackageName . pkgName <*> (== pv) . prettyShow . pkgVersion + mkFilter (ImportFilter pn Nothing) = (== pn) . unPackageName . pkgName + mkFilter (ImportFilter pn (Just pv)) = (&&) <$> (== pn) . unPackageName . pkgName <*> (== pv) . prettyShow . pkgVersion -importIndex :: - Show e => - (PackageIdentifier -> Bool) -> - Tar.Entries e -> - Map PackageIdentifier PackageVersionSpec -> - IO (Map PackageIdentifier PackageVersionSpec) +importIndex + :: (Show e) + => (PackageIdentifier -> Bool) + -> Tar.Entries e + -> Map PackageIdentifier PackageVersionSpec + -> IO (Map PackageIdentifier PackageVersionSpec) importIndex f (Tar.Next e es) m = case isCabalFile e of Just (pkgId, contents, time) | f pkgId -> do putStrLn $ "Found cabal file " ++ prettyShow pkgId ++ " with timestamp " ++ show time - let -- new package - go Nothing = - pure $ - Just $ - PackageVersionSpec - { packageVersionSource = TarballSource (pkgIdToHackageUrl pkgId) Nothing, - packageVersionTimestamp = Just time, - packageVersionRevisions = [], - packageVersionDeprecations = [], - packageVersionForce = False - } - -- Existing package, new revision - go (Just sm) = do - let revnum = 1 + fromMaybe 0 (latestRevisionNumber sm) - newRevision = RevisionSpec {revisionNumber = revnum, revisionTimestamp = time} - -- Repeatedly adding at the end of a list is bad performance but good for the moment. - let sm' = sm {packageVersionRevisions = packageVersionRevisions sm ++ [newRevision]} - let PackageIdentifier pkgName pkgVersion = pkgId - let outDir = "_sources" unPackageName pkgName prettyShow pkgVersion "revisions" - createDirectoryIfMissing True outDir - BSL.writeFile (outDir show revnum <.> "cabal") contents - return $ Just sm' + let + -- new package + go Nothing = + pure $ + Just $ + PackageVersionSpec + { packageVersionSource = TarballSource (pkgIdToHackageUrl pkgId) Nothing + , packageVersionTimestamp = Just time + , packageVersionRevisions = [] + , packageVersionDeprecations = [] + , packageVersionForce = False + } + -- Existing package, new revision + go (Just sm) = do + let revnum = 1 + fromMaybe 0 (latestRevisionNumber sm) + newRevision = RevisionSpec{revisionNumber = revnum, revisionTimestamp = time} + -- Repeatedly adding at the end of a list is bad performance but good for the moment. + let sm' = sm{packageVersionRevisions = packageVersionRevisions sm ++ [newRevision]} + let PackageIdentifier pkgName pkgVersion = pkgId + let outDir = "_sources" unPackageName pkgName prettyShow pkgVersion "revisions" + createDirectoryIfMissing True outDir + BSL.writeFile (outDir show revnum <.> "cabal") contents + return $ Just sm' m' <- M.alterF go pkgId m importIndex f es m' _ -> importIndex f es m @@ -89,28 +90,28 @@ importIndex _f (Tar.Fail e) _ = pkgIdToHackageUrl :: PackageIdentifier -> URI pkgIdToHackageUrl pkgId = nullURI - { uriScheme = "https:", - uriAuthority = Just $ nullURIAuth {uriRegName = "hackage.haskell.org"}, - uriPath = "/package" prettyShow pkgId prettyShow pkgId <.> "tar.gz" + { uriScheme = "https:" + , uriAuthority = Just $ nullURIAuth{uriRegName = "hackage.haskell.org"} + , uriPath = "/package" prettyShow pkgId prettyShow pkgId <.> "tar.gz" } -finalise :: - PackageIdentifier -> - PackageVersionSpec -> - IO () -finalise PackageIdentifier {pkgName, pkgVersion} meta = do +finalise + :: PackageIdentifier + -> PackageVersionSpec + -> IO () +finalise PackageIdentifier{pkgName, pkgVersion} meta = do let dir = "_sources" unPackageName pkgName prettyShow pkgVersion createDirectoryIfMissing True dir writePackageVersionSpec (dir "meta.toml") meta -isCabalFile :: - Tar.Entry -> - Maybe (PackageIdentifier, BSL.ByteString, UTCTime) +isCabalFile + :: Tar.Entry + -> Maybe (PackageIdentifier, BSL.ByteString, UTCTime) isCabalFile Tar.Entry - { Tar.entryTarPath = Tar.fromTarPath -> path, - Tar.entryContent = Tar.NormalFile contents _, - Tar.entryTime = posixSecondsToUTCTime . fromIntegral -> time + { Tar.entryTarPath = Tar.fromTarPath -> path + , Tar.entryContent = Tar.NormalFile contents _ + , Tar.entryTime = posixSecondsToUTCTime . fromIntegral -> time } | ".cabal" `isSuffixOf` path = let [pkgName, pkgVersion, _] = splitDirectories path diff --git a/app/Foliage/HackageSecurity.hs b/app/Foliage/HackageSecurity.hs index f9cf394..b51f610 100644 --- a/app/Foliage/HackageSecurity.hs +++ b/app/Foliage/HackageSecurity.hs @@ -2,14 +2,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ImportQualifiedPost #-} -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, - ) +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 import Control.Monad (replicateM) @@ -27,7 +27,7 @@ import Hackage.Security.Util.Some import System.Directory (createDirectoryIfMissing) import System.FilePath -readJSONSimple :: FromJSON ReadJSON_NoKeys_NoLayout a => FilePath -> IO (Either DeserializationError a) +readJSONSimple :: (FromJSON ReadJSON_NoKeys_NoLayout a) => FilePath -> IO (Either DeserializationError a) readJSONSimple fp = do p <- makeAbsolute (fromFilePath fp) readJSON_NoKeys_NoLayout p @@ -46,16 +46,16 @@ 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 + 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 + showKeys keys = + for_ keys $ \key -> + putStrLn $ " " ++ showKey key showKey :: Some Key -> [Char] showKey k = T.unpack $ encodeBase16 $ exportSomePublicKey $ somePublicKey k @@ -75,14 +75,14 @@ writeKey fp key = do p <- makeAbsolute (fromFilePath fp) writeJSON_NoLayout p key -renderSignedJSON :: ToJSON WriteJSON a => [Some Key] -> a -> BSL.ByteString +renderSignedJSON :: (ToJSON WriteJSON a) => [Some Key] -> a -> BSL.ByteString renderSignedJSON keys thing = renderJSON hackageRepoLayout (withSignatures hackageRepoLayout keys thing) -writeSignedJSON :: ToJSON WriteJSON a => Path Absolute -> (RepoLayout -> RepoPath) -> [Some Key] -> a -> IO () +writeSignedJSON :: (ToJSON WriteJSON a) => Path Absolute -> (RepoLayout -> RepoPath) -> [Some Key] -> a -> IO () writeSignedJSON outputDirRoot repoPath keys thing = do writeLazyByteString fp $ renderSignedJSON keys thing - where - fp = anchorRepoPathLocally outputDirRoot $ repoPath hackageRepoLayout + where + fp = anchorRepoPathLocally outputDirRoot $ repoPath hackageRepoLayout diff --git a/app/Foliage/Meta.hs b/app/Foliage/Meta.hs index b5642d8..3a6794c 100644 --- a/app/Foliage/Meta.hs +++ b/app/Foliage/Meta.hs @@ -5,29 +5,29 @@ {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Foliage.Meta - ( packageVersionTimestamp, - packageVersionSource, - packageVersionRevisions, - packageVersionDeprecations, - packageVersionForce, - PackageVersionSpec (PackageVersionSpec), - readPackageVersionSpec, - writePackageVersionSpec, - RevisionSpec (RevisionSpec), - revisionTimestamp, - revisionNumber, - DeprecationSpec (DeprecationSpec), - deprecationTimestamp, - deprecationIsDeprecated, - PackageVersionSource, - pattern TarballSource, - pattern GitHubSource, - GitHubRepo (..), - GitHubRev (..), - UTCTime, - latestRevisionNumber, - ) +module Foliage.Meta ( + packageVersionTimestamp, + packageVersionSource, + packageVersionRevisions, + packageVersionDeprecations, + packageVersionForce, + PackageVersionSpec (PackageVersionSpec), + readPackageVersionSpec, + writePackageVersionSpec, + RevisionSpec (RevisionSpec), + revisionTimestamp, + revisionNumber, + DeprecationSpec (DeprecationSpec), + deprecationTimestamp, + deprecationIsDeprecated, + PackageVersionSource, + pattern TarballSource, + pattern GitHubSource, + GitHubRepo (..), + GitHubRev (..), + UTCTime, + latestRevisionNumber, +) where import Control.Applicative ((<|>)) @@ -56,13 +56,13 @@ newtype GitHubRev = GitHubRev {unGitHubRev :: Text} data PackageVersionSource = TarballSource - { tarballSourceURI :: URI, - subdir :: Maybe String + { tarballSourceURI :: URI + , subdir :: Maybe String } | GitHubSource - { githubRepo :: GitHubRepo, - githubRev :: GitHubRev, - subdir :: Maybe String + { githubRepo :: GitHubRepo + , githubRev :: GitHubRev + , subdir :: Maybe String } deriving (Show, Eq, Generic) deriving anyclass (Binary, Hashable, NFData) @@ -74,11 +74,11 @@ packageSourceCodec = uri :: Toml.Key -> TomlCodec URI uri = Toml.textBy to from - where - to = T.pack . show - from t = case parseURI (T.unpack t) of - Nothing -> Left $ "Invalid url: " <> t - Just uri' -> Right uri' + where + to = T.pack . show + from t = case parseURI (T.unpack t) of + Nothing -> Left $ "Invalid url: " <> t + Just uri' -> Right uri' tarballSourceCodec :: TomlCodec (URI, Maybe String) tarballSourceCodec = @@ -107,16 +107,16 @@ matchGitHubSource (GitHubSource repo rev mSubdir) = Just ((repo, rev), mSubdir) matchGitHubSource _ = Nothing data PackageVersionSpec = PackageVersionSpec - { -- | timestamp - packageVersionTimestamp :: Maybe UTCTime, - -- | source parameters - packageVersionSource :: PackageVersionSource, - -- | revisions - packageVersionRevisions :: [RevisionSpec], - -- | deprecations - packageVersionDeprecations :: [DeprecationSpec], - -- | force version - packageVersionForce :: Bool + { packageVersionTimestamp :: Maybe UTCTime + -- ^ timestamp + , packageVersionSource :: PackageVersionSource + -- ^ source parameters + , packageVersionRevisions :: [RevisionSpec] + -- ^ revisions + , packageVersionDeprecations :: [DeprecationSpec] + -- ^ deprecations + , packageVersionForce :: Bool + -- ^ force version } deriving (Show, Eq, Generic) deriving anyclass (Binary, Hashable, NFData) @@ -125,15 +125,15 @@ sourceMetaCodec :: TomlCodec PackageVersionSpec sourceMetaCodec = PackageVersionSpec <$> Toml.dioptional (timeCodec "timestamp") - .= packageVersionTimestamp + .= packageVersionTimestamp <*> packageSourceCodec - .= packageVersionSource + .= packageVersionSource <*> Toml.list revisionMetaCodec "revisions" - .= packageVersionRevisions + .= packageVersionRevisions <*> Toml.list deprecationMetaCodec "deprecations" - .= packageVersionDeprecations + .= packageVersionDeprecations <*> withDefault False (Toml.bool "force-version") - .= packageVersionForce + .= packageVersionForce readPackageVersionSpec :: FilePath -> IO PackageVersionSpec readPackageVersionSpec = Toml.decodeFile sourceMetaCodec @@ -142,8 +142,8 @@ writePackageVersionSpec :: FilePath -> PackageVersionSpec -> IO () writePackageVersionSpec fp a = void $ Toml.encodeToFile sourceMetaCodec fp a data RevisionSpec = RevisionSpec - { revisionTimestamp :: UTCTime, - revisionNumber :: Int + { revisionTimestamp :: UTCTime + , revisionNumber :: Int } deriving (Show, Eq, Generic, Ord) deriving anyclass (Binary, Hashable, NFData) @@ -152,16 +152,16 @@ revisionMetaCodec :: TomlCodec RevisionSpec revisionMetaCodec = RevisionSpec <$> timeCodec "timestamp" - .= revisionTimestamp + .= revisionTimestamp <*> Toml.int "number" - .= revisionNumber + .= revisionNumber data DeprecationSpec = DeprecationSpec - { deprecationTimestamp :: UTCTime, - -- | 'True' means the package version has been deprecated - -- 'False' means the package version has been undeprecated - -- FIXME: we should consider something better than 'Bool' - deprecationIsDeprecated :: Bool + { deprecationTimestamp :: UTCTime + , deprecationIsDeprecated :: Bool + -- ^ 'True' means the package version has been deprecated + -- 'False' means the package version has been undeprecated + -- FIXME: we should consider something better than 'Bool' } deriving (Show, Eq, Generic, Ord) deriving anyclass (Binary, Hashable, NFData) @@ -170,9 +170,9 @@ deprecationMetaCodec :: TomlCodec DeprecationSpec deprecationMetaCodec = DeprecationSpec <$> timeCodec "timestamp" - .= deprecationTimestamp + .= deprecationTimestamp <*> withDefault True (Toml.bool "deprecated") - .= deprecationIsDeprecated + .= deprecationIsDeprecated timeCodec :: Toml.Key -> TomlCodec UTCTime timeCodec key = Toml.dimap (utcToZonedTime utc) zonedTimeToUTC $ Toml.zonedTime key @@ -183,7 +183,7 @@ latestRevisionNumber sm = [] -> Nothing rev : _ -> Just (revisionNumber rev) -withDefault :: Eq a => a -> TomlCodec a -> TomlCodec a +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 + where + f a = if a == d then Nothing else Just a diff --git a/app/Foliage/Meta/Aeson.hs b/app/Foliage/Meta/Aeson.hs index 47a7462..bae3cc7 100644 --- a/app/Foliage/Meta/Aeson.hs +++ b/app/Foliage/Meta/Aeson.hs @@ -26,8 +26,8 @@ instance ToJSON PackageVersionSource where toJSON = genericToJSON defaultOptions - { sumEncoding = ObjectWithSingleField, - omitNothingFields = True + { sumEncoding = ObjectWithSingleField + , omitNothingFields = True } instance ToJSON URI where diff --git a/app/Foliage/Options.hs b/app/Foliage/Options.hs index 285edee..e3c85a9 100644 --- a/app/Foliage/Options.hs +++ b/app/Foliage/Options.hs @@ -2,14 +2,14 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -module Foliage.Options - ( parseCommand, - Command (..), - BuildOptions (..), - SignOptions (..), - ImportIndexOptions (..), - ImportFilter (..), - ) +module Foliage.Options ( + parseCommand, + Command (..), + BuildOptions (..), + SignOptions (..), + ImportIndexOptions (..), + ImportFilter (..), +) where import Development.Shake.Classes (Binary, Hashable, NFData) @@ -47,13 +47,13 @@ data SignOptions deriving anyclass (Binary, Hashable, NFData) data BuildOptions = BuildOptions - { buildOptsSignOpts :: SignOptions, - buildOptsCurrentTime :: Maybe UTCTime, - buildOptsExpireSignaturesOn :: Maybe UTCTime, - buildOptsInputDir :: FilePath, - buildOptsOutputDir :: FilePath, - buildOptsNumThreads :: Int, - buildOptsWriteMetadata :: Bool + { buildOptsSignOpts :: SignOptions + , buildOptsCurrentTime :: Maybe UTCTime + , buildOptsExpireSignaturesOn :: Maybe UTCTime + , buildOptsInputDir :: FilePath + , buildOptsOutputDir :: FilePath + , buildOptsNumThreads :: Int + , buildOptsWriteMetadata :: Bool } buildCommand :: Parser Command @@ -107,20 +107,20 @@ buildCommand = <> showDefault ) ) - where - signOpts = - ( SignOptsSignWithKeys - <$> strOption - ( long "keys" - <> metavar "KEYS" - <> help "TUF keys location" - <> showDefault - <> value "_keys" - ) - ) - <|> ( SignOptsDon'tSign - <$ switch (long "no-signatures" <> help "Don't sign the repository") - ) + where + signOpts = + ( SignOptsSignWithKeys + <$> strOption + ( long "keys" + <> metavar "KEYS" + <> help "TUF keys location" + <> showDefault + <> value "_keys" + ) + ) + <|> ( SignOptsDon'tSign + <$ switch (long "no-signatures" <> help "Don't sign the repository") + ) createKeysCommand :: Parser Command createKeysCommand = diff --git a/app/Foliage/Pages.hs b/app/Foliage/Pages.hs index c0c103f..952cd8d 100644 --- a/app/Foliage/Pages.hs +++ b/app/Foliage/Pages.hs @@ -3,15 +3,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -module Foliage.Pages - ( allPackagesPageTemplate, - allPackageVersionsPageTemplate, - packageVersionPageTemplate, - makeAllPackagesPage, - makePackageVersionPage, - makeAllPackageVersionsPage, - makeIndexPage, - ) +module Foliage.Pages ( + allPackagesPageTemplate, + allPackageVersionsPageTemplate, + packageVersionPageTemplate, + makeAllPackagesPage, + makePackageVersionPage, + makeAllPackageVersionsPage, + makeIndexPage, +) where import Data.Aeson (KeyValue ((.=)), ToJSON, object) @@ -47,11 +47,11 @@ makeIndexPage outputDir = object [] data AllPackagesPageEntry = AllPackagesPageEntry - { allPackagesPageEntryPkgId :: PackageIdentifier, - allPackagesPageEntryTimestamp :: UTCTime, - allPackagesPageEntryTimestampPosix :: POSIXTime, - allPackagesPageEntrySource :: PackageVersionSource, - allPackagesPageEntryLatestRevisionTimestamp :: Maybe UTCTime + { allPackagesPageEntryPkgId :: PackageIdentifier + , allPackagesPageEntryTimestamp :: UTCTime + , allPackagesPageEntryTimestampPosix :: POSIXTime + , allPackagesPageEntrySource :: PackageVersionSource + , allPackagesPageEntryLatestRevisionTimestamp :: Maybe UTCTime } deriving stock (Generic) deriving (ToJSON) via MyAesonEncoding AllPackagesPageEntry @@ -63,47 +63,47 @@ makeAllPackagesPage currentTime outputDir packageVersions = TL.writeFile (outputDir "all-packages" "index.html") $ renderMustache allPackagesPageTemplate $ object ["packages" .= packages] - where - packages = - packageVersions - -- group package versions by package name - & NE.groupBy ((==) `on` (pkgName . pkgId)) - -- for each package name pick the most recent version - & map - ( \group -> - group - -- sort them from the most recent version to the least recent - & NE.sortBy (comparing $ Down . pkgVersion . pkgId) - -- pick the most recent version - & NE.head - -- turn it into the template data - & ( \(PreparedPackageVersion {pkgId, pkgTimestamp, cabalFileRevisions, pkgVersionSource}) -> - AllPackagesPageEntry - { allPackagesPageEntryPkgId = pkgId, - allPackagesPageEntryTimestamp = fromMaybe currentTime pkgTimestamp, - allPackagesPageEntryTimestampPosix = utcTimeToPOSIXSeconds (fromMaybe currentTime pkgTimestamp), - allPackagesPageEntrySource = pkgVersionSource, - allPackagesPageEntryLatestRevisionTimestamp = fst <$> listToMaybe cabalFileRevisions - } - ) - ) - -- sort packages by pkgId - & sortOn allPackagesPageEntryPkgId + where + packages = + packageVersions + -- group package versions by package name + & NE.groupBy ((==) `on` (pkgName . pkgId)) + -- for each package name pick the most recent version + & map + ( \group -> + group + -- sort them from the most recent version to the least recent + & NE.sortBy (comparing $ Down . pkgVersion . pkgId) + -- pick the most recent version + & NE.head + -- turn it into the template data + & ( \(PreparedPackageVersion{pkgId, pkgTimestamp, cabalFileRevisions, pkgVersionSource}) -> + AllPackagesPageEntry + { allPackagesPageEntryPkgId = pkgId + , allPackagesPageEntryTimestamp = fromMaybe currentTime pkgTimestamp + , allPackagesPageEntryTimestampPosix = utcTimeToPOSIXSeconds (fromMaybe currentTime pkgTimestamp) + , allPackagesPageEntrySource = pkgVersionSource + , allPackagesPageEntryLatestRevisionTimestamp = fst <$> listToMaybe cabalFileRevisions + } + ) + ) + -- sort packages by pkgId + & sortOn allPackagesPageEntryPkgId -- FIXME: refactor this data AllPackageVersionsPageEntry = AllPackageVersionsPageEntryPackage - { allPackageVersionsPageEntryPkgId :: PackageIdentifier, - allPackageVersionsPageEntryTimestamp :: UTCTime, - allPackageVersionsPageEntryTimestampPosix :: POSIXTime, - allPackageVersionsPageEntrySource :: PackageVersionSource, - allPackageVersionsPageEntryDeprecated :: Bool + { allPackageVersionsPageEntryPkgId :: PackageIdentifier + , allPackageVersionsPageEntryTimestamp :: UTCTime + , allPackageVersionsPageEntryTimestampPosix :: POSIXTime + , allPackageVersionsPageEntrySource :: PackageVersionSource + , allPackageVersionsPageEntryDeprecated :: Bool } | AllPackageVersionsPageEntryRevision - { allPackageVersionsPageEntryPkgId :: PackageIdentifier, - allPackageVersionsPageEntryTimestamp :: UTCTime, - allPackageVersionsPageEntryTimestampPosix :: POSIXTime, - allPackageVersionsPageEntryDeprecated :: Bool + { allPackageVersionsPageEntryPkgId :: PackageIdentifier + , allPackageVersionsPageEntryTimestamp :: UTCTime + , allPackageVersionsPageEntryTimestampPosix :: POSIXTime + , allPackageVersionsPageEntryDeprecated :: Bool } deriving stock (Generic) deriving (ToJSON) via MyAesonEncoding AllPackageVersionsPageEntry @@ -115,45 +115,45 @@ makeAllPackageVersionsPage currentTime outputDir packageVersions = TL.writeFile (outputDir "all-package-versions" "index.html") $ renderMustache allPackageVersionsPageTemplate $ object ["entries" .= entries] - where - entries = - -- collect all cabal file revisions including the original cabal file - foldMap - ( \PreparedPackageVersion {pkgId, pkgTimestamp, pkgVersionSource, pkgVersionIsDeprecated, cabalFileRevisions} -> - -- original cabal file - AllPackageVersionsPageEntryPackage - { allPackageVersionsPageEntryPkgId = pkgId, - allPackageVersionsPageEntryTimestamp = fromMaybe currentTime pkgTimestamp, - allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds (fromMaybe currentTime pkgTimestamp), - allPackageVersionsPageEntrySource = pkgVersionSource, - allPackageVersionsPageEntryDeprecated = pkgVersionIsDeprecated - } - -- list of revisions - : [ AllPackageVersionsPageEntryRevision - { allPackageVersionsPageEntryPkgId = pkgId, - allPackageVersionsPageEntryTimestamp = revisionTimestamp, - allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds revisionTimestamp, - allPackageVersionsPageEntryDeprecated = pkgVersionIsDeprecated - } - | (revisionTimestamp, _) <- cabalFileRevisions - ] - ) - packageVersions - -- sort them by timestamp - & sortOn (Down . allPackageVersionsPageEntryTimestamp) + where + entries = + -- collect all cabal file revisions including the original cabal file + foldMap + ( \PreparedPackageVersion{pkgId, pkgTimestamp, pkgVersionSource, pkgVersionIsDeprecated, cabalFileRevisions} -> + -- original cabal file + AllPackageVersionsPageEntryPackage + { allPackageVersionsPageEntryPkgId = pkgId + , allPackageVersionsPageEntryTimestamp = fromMaybe currentTime pkgTimestamp + , allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds (fromMaybe currentTime pkgTimestamp) + , allPackageVersionsPageEntrySource = pkgVersionSource + , allPackageVersionsPageEntryDeprecated = pkgVersionIsDeprecated + } + -- list of revisions + : [ AllPackageVersionsPageEntryRevision + { allPackageVersionsPageEntryPkgId = pkgId + , allPackageVersionsPageEntryTimestamp = revisionTimestamp + , allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds revisionTimestamp + , allPackageVersionsPageEntryDeprecated = pkgVersionIsDeprecated + } + | (revisionTimestamp, _) <- cabalFileRevisions + ] + ) + packageVersions + -- sort them by timestamp + & sortOn (Down . allPackageVersionsPageEntryTimestamp) makePackageVersionPage :: FilePath -> PreparedPackageVersion -> Action () -makePackageVersionPage outputDir PreparedPackageVersion {pkgId, pkgTimestamp, pkgVersionSource, pkgDesc, cabalFileRevisions, pkgVersionIsDeprecated} = do +makePackageVersionPage outputDir PreparedPackageVersion{pkgId, pkgTimestamp, pkgVersionSource, pkgDesc, cabalFileRevisions, pkgVersionIsDeprecated} = do traced ("webpages / package / " ++ prettyShow pkgId) $ do IO.createDirectoryIfMissing True (outputDir "package" prettyShow pkgId) TL.writeFile (outputDir "package" prettyShow pkgId "index.html") $ renderMustache packageVersionPageTemplate $ object - [ "pkgVersionSource" .= pkgVersionSource, - "cabalFileRevisions" .= map fst cabalFileRevisions, - "pkgDesc" .= jsonGenericPackageDescription pkgDesc, - "pkgTimestamp" .= pkgTimestamp, - "pkgVersionDeprecated" .= pkgVersionIsDeprecated + [ "pkgVersionSource" .= pkgVersionSource + , "cabalFileRevisions" .= map fst cabalFileRevisions + , "pkgDesc" .= jsonGenericPackageDescription pkgDesc + , "pkgTimestamp" .= pkgTimestamp + , "pkgVersionDeprecated" .= pkgVersionIsDeprecated ] indexPageTemplate :: Template diff --git a/app/Foliage/PreparePackageVersion.hs b/app/Foliage/PreparePackageVersion.hs index ed6867c..3925013 100644 --- a/app/Foliage/PreparePackageVersion.hs +++ b/app/Foliage/PreparePackageVersion.hs @@ -2,23 +2,23 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -module Foliage.PreparePackageVersion - ( PreparedPackageVersion - ( pkgId, - pkgTimestamp, - pkgVersionSource, - pkgVersionForce, - pkgVersionIsDeprecated, - pkgVersionDeprecationChanges, - pkgDesc, - sdistPath, - cabalFilePath, - originalCabalFilePath, - cabalFileRevisions - ), - pattern PreparedPackageVersion, - preparePackageVersion, - ) +module Foliage.PreparePackageVersion ( + PreparedPackageVersion ( + pkgId, + pkgTimestamp, + pkgVersionSource, + pkgVersionForce, + pkgVersionIsDeprecated, + pkgVersionDeprecationChanges, + pkgDesc, + sdistPath, + cabalFilePath, + originalCabalFilePath, + cabalFileRevisions + ), + pattern PreparedPackageVersion, + preparePackageVersion, +) where import Control.Monad (unless) @@ -42,17 +42,17 @@ import System.FilePath (takeBaseName, takeFileName, (<.>), ()) -- TODO: can we ensure that `pkgVersionDeprecationChanges` and `cabalFileRevisions` are -- sorted by timestamp? e.g https://hackage.haskell.org/package/sorted-list data PreparedPackageVersion = PreparedPackageVersion - { pkgId :: PackageId, - pkgTimestamp :: Maybe UTCTime, - pkgVersionSource :: PackageVersionSource, - pkgVersionForce :: Bool, - pkgVersionIsDeprecated :: Bool, - pkgVersionDeprecationChanges :: [(UTCTime, Bool)], - pkgDesc :: GenericPackageDescription, - sdistPath :: FilePath, - cabalFilePath :: FilePath, - originalCabalFilePath :: FilePath, - cabalFileRevisions :: [(UTCTime, FilePath)] + { pkgId :: PackageId + , pkgTimestamp :: Maybe UTCTime + , pkgVersionSource :: PackageVersionSource + , pkgVersionForce :: Bool + , pkgVersionIsDeprecated :: Bool + , pkgVersionDeprecationChanges :: [(UTCTime, Bool)] + , pkgDesc :: GenericPackageDescription + , sdistPath :: FilePath + , cabalFilePath :: FilePath + , originalCabalFilePath :: FilePath + , cabalFileRevisions :: [(UTCTime, FilePath)] } -- @andreabedini comments: @@ -93,27 +93,27 @@ preparePackageVersion inputDir metaFile = do let pkgId = PackageIdentifier pkgName pkgVersion pkgSpec <- - readPackageVersionSpec' (inputDir metaFile) >>= \meta@PackageVersionSpec {..} -> do + readPackageVersionSpec' (inputDir metaFile) >>= \meta@PackageVersionSpec{..} -> do case (NE.nonEmpty packageVersionRevisions, packageVersionTimestamp) of (Just _someRevisions, Nothing) -> error $ unlines - [ inputDir metaFile <> " has cabal file revisions but the package has no timestamp.", - "This combination doesn't make sense. Either add a timestamp on the original package or remove the revisions." + [ inputDir metaFile <> " has cabal file revisions but the package has no timestamp." + , "This combination doesn't make sense. Either add a timestamp on the original package or remove the revisions." ] (Just (NE.sort -> someRevisions), Just ts) -- WARN: this should really be a <= | revisionTimestamp (NE.head someRevisions) < ts -> error $ unlines - [ inputDir metaFile <> " has a revision with timestamp earlier than the package itself.", - "Adjust the timestamps so that all revisions come after the package publication." + [ inputDir metaFile <> " has a revision with timestamp earlier than the package itself." + , "Adjust the timestamps so that all revisions come after the package publication." ] | not (null $ duplicates (revisionTimestamp <$> someRevisions)) -> error $ unlines - [ inputDir metaFile <> " has two revisions entries with the same timestamp.", - "Adjust the timestamps so that all the revisions happen at a different time." + [ inputDir metaFile <> " has two revisions entries with the same timestamp." + , "Adjust the timestamps so that all the revisions happen at a different time." ] _otherwise -> return () @@ -121,15 +121,15 @@ preparePackageVersion inputDir metaFile = do (Just _someDeprecations, Nothing) -> error $ unlines - [ inputDir metaFile <> " has deprecations but the package has no timestamp.", - "This combination doesn't make sense. Either add a timestamp on the original package or remove the deprecation." + [ inputDir metaFile <> " has deprecations but the package has no timestamp." + , "This combination doesn't make sense. Either add a timestamp on the original package or remove the deprecation." ] (Just (NE.sort -> someDeprecations), Just ts) | deprecationTimestamp (NE.head someDeprecations) <= ts -> error $ unlines - [ inputDir metaFile <> " has a deprecation entry with timestamp earlier (or equal) than the package itself.", - "Adjust the timestamps so that all the (un-)deprecations come after the package publication." + [ inputDir metaFile <> " has a deprecation entry with timestamp earlier (or equal) than the package itself." + , "Adjust the timestamps so that all the (un-)deprecations come after the package publication." ] | not (deprecationIsDeprecated (NE.head someDeprecations)) -> error $ @@ -137,14 +137,14 @@ preparePackageVersion inputDir metaFile = do | not (null $ duplicates (deprecationTimestamp <$> someDeprecations)) -> error $ unlines - [ inputDir metaFile <> " has two deprecation entries with the same timestamp.", - "Adjust the timestamps so that all the (un-)deprecations happen at a different time." + [ inputDir metaFile <> " has two deprecation entries with the same timestamp." + , "Adjust the timestamps so that all the (un-)deprecations happen at a different time." ] | not (null $ doubleDeprecations someDeprecations) -> error $ unlines - [ inputDir metaFile <> " contains two consecutive deprecations or two consecutive un-deprecations.", - "Make sure deprecations and un-deprecations alternate in time." + [ inputDir metaFile <> " contains two consecutive deprecations or two consecutive un-deprecations." + , "Make sure deprecations and un-deprecations alternate in time." ] _otherwise -> return () @@ -156,11 +156,11 @@ preparePackageVersion inputDir metaFile = do cabalFileRevisionPath revisionNumber = joinPath - [ inputDir, - prettyShow pkgName, - prettyShow pkgVersion, - "revisions", - show revisionNumber + [ inputDir + , prettyShow pkgName + , prettyShow pkgVersion + , "revisions" + , show revisionNumber ] <.> "cabal" @@ -178,47 +178,47 @@ preparePackageVersion inputDir metaFile = do unless (takeFileName sdistPath == expectedSdistName) $ do error $ unlines - [ "creating a source distribution for " ++ prettyShow pkgId ++ " has failed because", - "cabal has produced a source distribtion that does not match the expected file name:", - "actual: " ++ takeBaseName sdistPath, - "expected: " ++ expectedSdistName, - "possible cause: the package name and/or version implied by the metadata file path does not match what is contained in the cabal file", - "metadata file: " ++ metaFile, - "version in cabal file: " ++ prettyShow (Distribution.Types.PackageId.pkgVersion $ package $ packageDescription pkgDesc) + [ "creating a source distribution for " ++ prettyShow pkgId ++ " has failed because" + , "cabal has produced a source distribtion that does not match the expected file name:" + , "actual: " ++ takeBaseName sdistPath + , "expected: " ++ expectedSdistName + , "possible cause: the package name and/or version implied by the metadata file path does not match what is contained in the cabal file" + , "metadata file: " ++ metaFile + , "version in cabal file: " ++ prettyShow (Distribution.Types.PackageId.pkgVersion $ package $ packageDescription pkgDesc) ] let cabalFileRevisions = sortOn Down [ (revisionTimestamp, cabalFileRevisionPath revisionNumber) - | RevisionSpec {revisionTimestamp, revisionNumber} <- packageVersionRevisions pkgSpec + | RevisionSpec{revisionTimestamp, revisionNumber} <- packageVersionRevisions pkgSpec ] let pkgVersionDeprecationChanges = sortOn Down [ (deprecationTimestamp, deprecationIsDeprecated) - | DeprecationSpec {deprecationTimestamp, deprecationIsDeprecated} <- packageVersionDeprecations pkgSpec + | DeprecationSpec{deprecationTimestamp, deprecationIsDeprecated} <- packageVersionDeprecations pkgSpec ] let pkgVersionIsDeprecated = maybe False snd $ listToMaybe pkgVersionDeprecationChanges return PreparedPackageVersion - { pkgId, - pkgTimestamp = packageVersionTimestamp pkgSpec, - pkgVersionSource = packageVersionSource pkgSpec, - pkgVersionForce = packageVersionForce pkgSpec, - pkgVersionDeprecationChanges, - pkgVersionIsDeprecated, - pkgDesc, - sdistPath, - cabalFilePath, - originalCabalFilePath, - cabalFileRevisions + { pkgId + , pkgTimestamp = packageVersionTimestamp pkgSpec + , pkgVersionSource = packageVersionSource pkgSpec + , pkgVersionForce = packageVersionForce pkgSpec + , pkgVersionDeprecationChanges + , pkgVersionIsDeprecated + , pkgDesc + , sdistPath + , cabalFilePath + , originalCabalFilePath + , cabalFileRevisions } -duplicates :: Ord a => NE.NonEmpty a -> [a] +duplicates :: (Ord a) => NE.NonEmpty a -> [a] duplicates = mapMaybe (listToMaybe . NE.tail) . NE.group doubleDeprecations :: NE.NonEmpty DeprecationSpec -> [NE.NonEmpty DeprecationSpec] diff --git a/app/Foliage/PrepareSdist.hs b/app/Foliage/PrepareSdist.hs index 3f461b1..7d9108d 100644 --- a/app/Foliage/PrepareSdist.hs +++ b/app/Foliage/PrepareSdist.hs @@ -2,10 +2,10 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE TypeFamilies #-} -module Foliage.PrepareSdist - ( prepareSdist, - addPrepareSdistRule, - ) +module Foliage.PrepareSdist ( + prepareSdist, + addPrepareSdistRule, +) where import Control.Monad (when) @@ -41,70 +41,70 @@ prepareSdist srcDir = apply1 $ PrepareSdistRule srcDir addPrepareSdistRule :: Path Absolute -> Rules () addPrepareSdistRule outputDirRoot = addBuiltinRule noLint noIdentity run - where - run :: PrepareSdistRule -> Maybe BS.ByteString -> RunMode -> Action (RunResult FilePath) - run (PrepareSdistRule srcDir) (Just old) RunDependenciesSame = do - let (hvExpected, path) = load old - - -- Check of has of the sdist, if the sdist is still there and it is - -- indeed what we expect, signal that nothing changed. Otherwise - -- warn the user and proceed to recompute. - ehvExisting <- liftIO $ tryIOError $ readFileHashValue path - case ehvExisting of - Right hvExisting - | hvExisting == hvExpected -> - return RunResult {runChanged = ChangedNothing, runStore = old, runValue = path} - Right hvExisting -> do - putWarn $ "Changed " ++ path ++ " (expecting hash " ++ showHashValue hvExpected ++ " found " ++ showHashValue hvExisting ++ "). I will rebuild it." - run (PrepareSdistRule srcDir) (Just old) RunDependenciesChanged - Left _e -> do - putWarn $ "Unable to read " ++ path ++ ". I will rebuild it." - run (PrepareSdistRule srcDir) (Just old) RunDependenciesChanged - run (PrepareSdistRule srcDir) old _mode = do - -- create the sdist distribution - (hv, path) <- makeSdist srcDir - - let new = save (hv, path) - - let changed = case fmap ((== hv) . fst . load) old of - Just True -> ChangedRecomputeSame - _differentOrMissing -> ChangedRecomputeDiff - - when (changed == ChangedRecomputeSame) $ - putInfo ("Wrote " ++ path ++ " (same hash " ++ showHashValue hv ++ ")") - - when (changed == ChangedRecomputeDiff) $ - putInfo ("Wrote " ++ path ++ " (new hash " ++ showHashValue hv ++ ")") - - return $ RunResult {runChanged = changed, runStore = new, runValue = path} - - makeSdist srcDir = do - cabalFiles <- getDirectoryFiles srcDir ["*.cabal"] - let cabalFile = case cabalFiles of - [f] -> f - fs -> - error $ - unlines - [ "Invalid source directory: " ++ srcDir, - "It contains multiple cabal files, while only one is allowed", - unwords fs - ] - - traced "cabal sdist" $ do - gpd <- readGenericPackageDescription Verbosity.normal (srcDir cabalFile) - let pkgId = packageId gpd - packagePath = repoLayoutPkgTarGz hackageRepoLayout pkgId - path = toFilePath $ anchorRepoPathLocally outputDirRoot packagePath - IO.createDirectoryIfMissing True (takeDirectory path) - sdist <- packageDirToSdist Verbosity.normal gpd srcDir - BSL.writeFile path sdist - return (SHA256.hashlazy sdist, path) - - save :: (BS.ByteString, FilePath) -> BS.ByteString - save = BSL.toStrict . Binary.encode - - load :: BS.ByteString -> (BS.ByteString, FilePath) - load = Binary.decode . BSL.fromStrict + where + run :: PrepareSdistRule -> Maybe BS.ByteString -> RunMode -> Action (RunResult FilePath) + run (PrepareSdistRule srcDir) (Just old) RunDependenciesSame = do + let (hvExpected, path) = load old + + -- Check of has of the sdist, if the sdist is still there and it is + -- indeed what we expect, signal that nothing changed. Otherwise + -- warn the user and proceed to recompute. + ehvExisting <- liftIO $ tryIOError $ readFileHashValue path + case ehvExisting of + Right hvExisting + | hvExisting == hvExpected -> + return RunResult{runChanged = ChangedNothing, runStore = old, runValue = path} + Right hvExisting -> do + putWarn $ "Changed " ++ path ++ " (expecting hash " ++ showHashValue hvExpected ++ " found " ++ showHashValue hvExisting ++ "). I will rebuild it." + run (PrepareSdistRule srcDir) (Just old) RunDependenciesChanged + Left _e -> do + putWarn $ "Unable to read " ++ path ++ ". I will rebuild it." + run (PrepareSdistRule srcDir) (Just old) RunDependenciesChanged + run (PrepareSdistRule srcDir) old _mode = do + -- create the sdist distribution + (hv, path) <- makeSdist srcDir + + let new = save (hv, path) + + let changed = case fmap ((== hv) . fst . load) old of + Just True -> ChangedRecomputeSame + _differentOrMissing -> ChangedRecomputeDiff + + when (changed == ChangedRecomputeSame) $ + putInfo ("Wrote " ++ path ++ " (same hash " ++ showHashValue hv ++ ")") + + when (changed == ChangedRecomputeDiff) $ + putInfo ("Wrote " ++ path ++ " (new hash " ++ showHashValue hv ++ ")") + + return $ RunResult{runChanged = changed, runStore = new, runValue = path} + + makeSdist srcDir = do + cabalFiles <- getDirectoryFiles srcDir ["*.cabal"] + let cabalFile = case cabalFiles of + [f] -> f + fs -> + error $ + unlines + [ "Invalid source directory: " ++ srcDir + , "It contains multiple cabal files, while only one is allowed" + , unwords fs + ] + + traced "cabal sdist" $ do + gpd <- readGenericPackageDescription Verbosity.normal (srcDir cabalFile) + let pkgId = packageId gpd + packagePath = repoLayoutPkgTarGz hackageRepoLayout pkgId + path = toFilePath $ anchorRepoPathLocally outputDirRoot packagePath + IO.createDirectoryIfMissing True (takeDirectory path) + sdist <- packageDirToSdist Verbosity.normal gpd srcDir + BSL.writeFile path sdist + return (SHA256.hashlazy sdist, path) + + save :: (BS.ByteString, FilePath) -> BS.ByteString + save = BSL.toStrict . Binary.encode + + load :: BS.ByteString -> (BS.ByteString, FilePath) + load = Binary.decode . BSL.fromStrict readFileHashValue :: FilePath -> IO BS.ByteString readFileHashValue = fmap SHA256.hash . BS.readFile diff --git a/app/Foliage/PrepareSource.hs b/app/Foliage/PrepareSource.hs index f7a3e5f..d4ca097 100644 --- a/app/Foliage/PrepareSource.hs +++ b/app/Foliage/PrepareSource.hs @@ -40,83 +40,83 @@ prepareSource pkgId pkgMeta = apply1 $ PrepareSourceRule pkgId pkgMeta addPrepareSourceRule :: FilePath -> FilePath -> Rules () addPrepareSourceRule inputDir cacheDir = addBuiltinRule noLint noIdentity run - where - run :: PrepareSourceRule -> Maybe BS.ByteString -> RunMode -> Action (RunResult FilePath) - run (PrepareSourceRule pkgId pkgMeta) _old mode = do - let PackageIdentifier {pkgName, pkgVersion} = pkgId - let PackageVersionSpec {packageVersionSource, packageVersionForce} = pkgMeta - let srcDir = cacheDir unPackageName pkgName prettyShow pkgVersion - - case mode of - RunDependenciesSame -> - return $ RunResult ChangedNothing BS.empty srcDir - RunDependenciesChanged -> do - -- FIXME too much rework? - -- this action only depends on the tarball and the package metadata - - -- delete everything inside the package source tree - liftIO $ do - -- FIXME this should only delete inside srcDir but apparently - -- also deletes srcDir itself - removeFiles srcDir ["//*"] - IO.createDirectoryIfMissing True srcDir - - case packageVersionSource of - TarballSource url mSubdir -> do - tarballPath <- fetchRemoteAsset url - - withTempDir $ \tmpDir -> do - cmd_ "tar xzf" [tarballPath] "-C" [tmpDir] - - -- Special treatment of top-level directory: we remove it - -- - -- Note: Don't let shake look into tmpDir! it will cause - -- unnecessary rework because tmpDir is always new - ls <- liftIO $ IO.getDirectoryContents tmpDir - let ls' = filter (not . all (== '.')) ls - - let fix1 = case ls' of [l] -> ( l); _ -> id - fix2 = case mSubdir of Just s -> ( s); _ -> id - tdir = fix2 $ fix1 tmpDir - - cmd_ "cp --recursive --no-target-directory --dereference" [tdir, srcDir] - -- - -- This is almost identical to the above but we get to keep the - -- metadata. - -- - GitHubSource repo rev mSubdir -> do - let url = githubRepoTarballUrl repo rev - - tarballPath <- fetchRemoteAsset url - - withTempDir $ \tmpDir -> do - cmd_ "tar xzf" [tarballPath] "-C" [tmpDir] - - -- Special treatment of top-level directory: we remove it - -- - -- Note: Don't let shake look into tmpDir! it will cause - -- unnecessary rework because tmpDir is always new - ls <- liftIO $ IO.getDirectoryContents tmpDir - let ls' = filter (not . all (== '.')) ls - - let fix1 = case ls' of [l] -> ( l); _ -> id - fix2 = case mSubdir of Just s -> ( s); _ -> id - tdir = fix2 $ fix1 tmpDir - - cmd_ "cp --recursive --no-target-directory --dereference" [tdir, srcDir] - - let patchesDir = inputDir unPackageName pkgName prettyShow pkgVersion "patches" - hasPatches <- doesDirectoryExist patchesDir - - when hasPatches $ do - patchfiles <- getDirectoryFiles patchesDir ["*.patch"] - for_ patchfiles $ \patchfile -> do - let patch = patchesDir patchfile - cmd_ Shell (Cwd srcDir) (FileStdin patch) "patch -p1" - - when packageVersionForce $ do - let cabalFilePath = srcDir unPackageName pkgName <.> "cabal" - putInfo $ "Updating version in cabal file" ++ cabalFilePath - liftIO $ rewritePackageVersion cabalFilePath pkgVersion - - return $ RunResult ChangedRecomputeDiff BS.empty srcDir + where + run :: PrepareSourceRule -> Maybe BS.ByteString -> RunMode -> Action (RunResult FilePath) + run (PrepareSourceRule pkgId pkgMeta) _old mode = do + let PackageIdentifier{pkgName, pkgVersion} = pkgId + let PackageVersionSpec{packageVersionSource, packageVersionForce} = pkgMeta + let srcDir = cacheDir unPackageName pkgName prettyShow pkgVersion + + case mode of + RunDependenciesSame -> + return $ RunResult ChangedNothing BS.empty srcDir + RunDependenciesChanged -> do + -- FIXME too much rework? + -- this action only depends on the tarball and the package metadata + + -- delete everything inside the package source tree + liftIO $ do + -- FIXME this should only delete inside srcDir but apparently + -- also deletes srcDir itself + removeFiles srcDir ["//*"] + IO.createDirectoryIfMissing True srcDir + + case packageVersionSource of + TarballSource url mSubdir -> do + tarballPath <- fetchRemoteAsset url + + withTempDir $ \tmpDir -> do + cmd_ "tar xzf" [tarballPath] "-C" [tmpDir] + + -- Special treatment of top-level directory: we remove it + -- + -- Note: Don't let shake look into tmpDir! it will cause + -- unnecessary rework because tmpDir is always new + ls <- liftIO $ IO.getDirectoryContents tmpDir + let ls' = filter (not . all (== '.')) ls + + let fix1 = case ls' of [l] -> ( l); _ -> id + fix2 = case mSubdir of Just s -> ( s); _ -> id + tdir = fix2 $ fix1 tmpDir + + cmd_ "cp --recursive --no-target-directory --dereference" [tdir, srcDir] + -- + -- This is almost identical to the above but we get to keep the + -- metadata. + -- + GitHubSource repo rev mSubdir -> do + let url = githubRepoTarballUrl repo rev + + tarballPath <- fetchRemoteAsset url + + withTempDir $ \tmpDir -> do + cmd_ "tar xzf" [tarballPath] "-C" [tmpDir] + + -- Special treatment of top-level directory: we remove it + -- + -- Note: Don't let shake look into tmpDir! it will cause + -- unnecessary rework because tmpDir is always new + ls <- liftIO $ IO.getDirectoryContents tmpDir + let ls' = filter (not . all (== '.')) ls + + let fix1 = case ls' of [l] -> ( l); _ -> id + fix2 = case mSubdir of Just s -> ( s); _ -> id + tdir = fix2 $ fix1 tmpDir + + cmd_ "cp --recursive --no-target-directory --dereference" [tdir, srcDir] + + let patchesDir = inputDir unPackageName pkgName prettyShow pkgVersion "patches" + hasPatches <- doesDirectoryExist patchesDir + + when hasPatches $ do + patchfiles <- getDirectoryFiles patchesDir ["*.patch"] + for_ patchfiles $ \patchfile -> do + let patch = patchesDir patchfile + cmd_ Shell (Cwd srcDir) (FileStdin patch) "patch -p1" + + when packageVersionForce $ do + let cabalFilePath = srcDir unPackageName pkgName <.> "cabal" + putInfo $ "Updating version in cabal file" ++ cabalFilePath + liftIO $ rewritePackageVersion cabalFilePath pkgVersion + + return $ RunResult ChangedRecomputeDiff BS.empty srcDir diff --git a/app/Foliage/RemoteAsset.hs b/app/Foliage/RemoteAsset.hs index 065bc26..16e790b 100644 --- a/app/Foliage/RemoteAsset.hs +++ b/app/Foliage/RemoteAsset.hs @@ -2,10 +2,10 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE TypeFamilies #-} -module Foliage.RemoteAsset - ( fetchRemoteAsset, - addFetchRemoteAssetRule, - ) +module Foliage.RemoteAsset ( + fetchRemoteAsset, + addFetchRemoteAssetRule, +) where import Control.Monad @@ -38,32 +38,32 @@ fetchRemoteAsset = apply1 . RemoteAsset addFetchRemoteAssetRule :: FilePath -> Rules () addFetchRemoteAssetRule cacheDir = addBuiltinRule noLint noIdentity run - where - run :: BuiltinRun RemoteAsset FilePath - run (RemoteAsset uri) old _mode = do - unless (uriQuery uri == "") $ - error ("Query elements in URI are not supported: " <> show uri) + where + run :: BuiltinRun RemoteAsset FilePath + run (RemoteAsset uri) old _mode = do + unless (uriQuery uri == "") $ + error ("Query elements in URI are not supported: " <> show uri) - unless (uriFragment uri == "") $ - error ("Fragments in URI are not supported: " <> show uri) + unless (uriFragment uri == "") $ + error ("Fragments in URI are not supported: " <> show uri) - let scheme = dropWhileEnd (not . isAlpha) $ uriScheme uri + let scheme = dropWhileEnd (not . isAlpha) $ uriScheme uri - let host = maybe (error $ "invalid uri " ++ show uri) uriRegName (uriAuthority uri) + let host = maybe (error $ "invalid uri " ++ show uri) uriRegName (uriAuthority uri) - let path = cacheDir joinPath (scheme : host : pathSegments uri) + let path = cacheDir joinPath (scheme : host : pathSegments uri) - -- parse etag from store - let oldETag = fromMaybe BS.empty old + -- parse etag from store + let oldETag = fromMaybe BS.empty old - newETag <- - withTempFile $ \etagFile -> do - liftIO $ createDirectoryIfMissing True (takeDirectory path) - liftIO $ BS.writeFile etagFile oldETag - actionRetry 5 $ runCurl uri path etagFile + newETag <- + withTempFile $ \etagFile -> do + liftIO $ createDirectoryIfMissing True (takeDirectory path) + liftIO $ BS.writeFile etagFile oldETag + actionRetry 5 $ runCurl uri path etagFile - let changed = if newETag == oldETag then ChangedRecomputeSame else ChangedRecomputeDiff - return $ RunResult {runChanged = changed, runStore = newETag, runValue = path} + let changed = if newETag == oldETag then ChangedRecomputeSame else ChangedRecomputeDiff + return $ RunResult{runChanged = changed, runStore = newETag, runValue = path} runCurl :: URI -> String -> String -> Action ETag runCurl uri path etagFile = do @@ -71,31 +71,31 @@ runCurl uri path etagFile = do traced "curl" $ cmd Shell - [ "curl", - -- Silent or quiet mode. Do not show progress meter or error messages. Makes Curl mute. - "--silent", - -- Fail fast with no output at all on server errors. - "--fail", - -- If the server reports that the requested page has moved to a different location this + [ "curl" + , -- Silent or quiet mode. Do not show progress meter or error messages. Makes Curl mute. + "--silent" + , -- Fail fast with no output at all on server errors. + "--fail" + , -- If the server reports that the requested page has moved to a different location this -- option will make curl redo the request on the new place. -- NOTE: This is needed because github always replies with a redirect - "--location", - -- This option makes a conditional HTTP request for the specific ETag read from the + "--location" + , -- This option makes a conditional HTTP request for the specific ETag read from the -- given file by sending a custom If-None-Match header using the stored ETag. -- For correct results, make sure that the specified file contains only a single line -- with the desired ETag. An empty file is parsed as an empty ETag. - "--etag-compare", - etagFile, - -- This option saves an HTTP ETag to the specified file. If no ETag is sent by the server, + "--etag-compare" + , etagFile + , -- This option saves an HTTP ETag to the specified file. If no ETag is sent by the server, -- an empty file is created. - "--etag-save", - etagFile, - -- Write output to instead of stdout. - "--output", - path, - "--write-out", - "%{json}", - -- URL to fetch + "--etag-save" + , etagFile + , -- Write output to instead of stdout. + "--output" + , path + , "--write-out" + , "%{json}" + , -- URL to fetch show uri ] case exitCode of @@ -107,11 +107,11 @@ runCurl uri path etagFile = do Left err -> error $ unlines - [ "curl failed with return code " ++ show c ++ " while fetching " ++ show uri, - "Error while reading curl diagnostic: " ++ err + [ "curl failed with return code " ++ show c ++ " while fetching " ++ show uri + , "Error while reading curl diagnostic: " ++ err ] -- We can consider displaying different messages based on some fields (e.g. response_code) - Right CurlWriteOut {errormsg} -> + Right CurlWriteOut{errormsg} -> error errormsg type ETag = BS.ByteString diff --git a/app/Foliage/Shake.hs b/app/Foliage/Shake.hs index a28883a..dbb7792 100644 --- a/app/Foliage/Shake.hs +++ b/app/Foliage/Shake.hs @@ -1,9 +1,9 @@ -module Foliage.Shake - ( computeFileInfoSimple', - readKeysAt, - readPackageVersionSpec', - readGenericPackageDescription', - ) +module Foliage.Shake ( + computeFileInfoSimple', + readKeysAt, + readPackageVersionSpec', + readGenericPackageDescription', +) where import Data.Traversable (for) diff --git a/app/Foliage/Time.hs b/app/Foliage/Time.hs index 0e16286..ea40b69 100644 --- a/app/Foliage/Time.hs +++ b/app/Foliage/Time.hs @@ -1,16 +1,16 @@ {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Foliage.Time - ( iso8601ParseM, - iso8601Show, - getCurrentTime, - UTCTime (..), - utcTimeToPOSIXSeconds, - addUTCTime, - nominalDay, - truncateSeconds, - ) +module Foliage.Time ( + iso8601ParseM, + iso8601Show, + getCurrentTime, + UTCTime (..), + utcTimeToPOSIXSeconds, + addUTCTime, + nominalDay, + truncateSeconds, +) where import Data.Time diff --git a/app/Foliage/UpdateCabalFile.hs b/app/Foliage/UpdateCabalFile.hs index 53fb7a6..79fd1ae 100644 --- a/app/Foliage/UpdateCabalFile.hs +++ b/app/Foliage/UpdateCabalFile.hs @@ -7,12 +7,12 @@ import Distribution.Types.Lens import Distribution.Types.Version import Distribution.Verbosity -rewritePackageVersion :: - -- | path to @.cabal@ file - FilePath -> - -- | new version - Version -> - IO () +rewritePackageVersion + :: FilePath + -- ^ path to @.cabal@ file + -> Version + -- ^ new version + -> IO () rewritePackageVersion cabalPath ver = do gpd <- readGenericPackageDescription normal cabalPath writeGenericPackageDescription cabalPath (set (packageDescription . package . pkgVersion) ver gpd) diff --git a/app/Foliage/Utils/Aeson.hs b/app/Foliage/Utils/Aeson.hs index 220cb25..7f3c8bb 100644 --- a/app/Foliage/Utils/Aeson.hs +++ b/app/Foliage/Utils/Aeson.hs @@ -15,8 +15,8 @@ newtype MyAesonEncoding a = MyAesonEncoding a myOptions :: Options myOptions = defaultOptions - { sumEncoding = ObjectWithSingleField, - omitNothingFields = True + { sumEncoding = ObjectWithSingleField + , omitNothingFields = True } instance (Generic a, GToJSON' Value Zero (Rep a), GToJSON' Encoding Zero (Rep a)) => ToJSON (MyAesonEncoding a) where diff --git a/app/Foliage/Utils/GitHub.hs b/app/Foliage/Utils/GitHub.hs index 96c1461..b3eb1e1 100644 --- a/app/Foliage/Utils/GitHub.hs +++ b/app/Foliage/Utils/GitHub.hs @@ -1,6 +1,6 @@ -module Foliage.Utils.GitHub - ( githubRepoTarballUrl, - ) +module Foliage.Utils.GitHub ( + githubRepoTarballUrl, +) where import Data.Text qualified as T @@ -11,7 +11,7 @@ import System.FilePath (()) githubRepoTarballUrl :: GitHubRepo -> GitHubRev -> URI githubRepoTarballUrl repo rev = nullURI - { uriScheme = "https:", - uriAuthority = Just nullURIAuth {uriRegName = "github.com"}, - uriPath = "/" T.unpack (unGitHubRepo repo) "tarball" T.unpack (unGitHubRev rev) + { uriScheme = "https:" + , uriAuthority = Just nullURIAuth{uriRegName = "github.com"} + , uriPath = "/" T.unpack (unGitHubRepo repo) "tarball" T.unpack (unGitHubRev rev) } diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..d95c753 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,50 @@ +# Number of spaces per indentation step +indentation: 2 + +# Max line length for automatic line breaking +column-limit: none + +# Styling of arrows in type signatures (choices: trailing, leading, or leading-args) +function-arrows: leading + +# How to place commas in multi-line lists, records, etc. (choices: leading or trailing) +comma-style: leading + +# Styling of import/export lists (choices: leading, trailing, or diff-friendly) +import-export-style: diff-friendly + +# Whether to full-indent or half-indent 'where' bindings past the preceding body +indent-wheres: false + +# Whether to leave a space before an opening record brace +record-brace-space: false + +# Number of spaces between top-level declarations +newlines-between-decls: 1 + +# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) +haddock-style: multi-line + +# How to print module docstring +haddock-style-module: null + +# Styling of let blocks (choices: auto, inline, newline, or mixed) +let-style: auto + +# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) +in-style: right-align + +# Whether to put parentheses around a single constraint (choices: auto, always, or never) +single-constraint-parens: always + +# Output Unicode syntax (choices: detect, always, or never) +unicode: never + +# Give the programmer more choice on where to insert blank lines +respectful: true + +# Fixity information for operators +fixities: [] + +# Module reexports Fourmolu should know about +reexports: []