diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,9 +3,22 @@ `arch-hs` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.11.0.0 + +- Add `arch-hs-rdepcheck` + +- Support Cabal 3.6 + +- Fix datasubdir generation + +- Update dependency versions + +- Update name preset + ## 0.10.2.0 - Don't treat special licenses as custom licenses + - Add `--datasubdir` to template ## 0.10.1.0 diff --git a/arch-hs.cabal b/arch-hs.cabal --- a/arch-hs.cabal +++ b/arch-hs.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: arch-hs -version: 0.10.2.0 +version: 0.11.0.0 synopsis: Distribute hackage packages to archlinux description: @arch-hs@ is a command-line program, which simplifies the process of producing @@ -23,7 +23,7 @@ CHANGELOG.md README.md -tested-with: GHC ==8.10.7 || ==9.0.2 +tested-with: GHC ==8.10.7 || ==9.0.2 || ==9.2.3 source-repository head type: git @@ -36,12 +36,12 @@ common common-options build-depends: - , aeson >=1.5.4 && <2.1 - , algebraic-graphs >=0.5 && <0.7 + , aeson >=1.5.4 && <2.2 + , algebraic-graphs >=0.5 && <0.8 , arch-web ^>=0.1.1 - , base >=4.12 && <5 + , base >=4.12 && <5 , bytestring - , Cabal >=3.2 && <3.5 + , Cabal >=3.2 && <3.7 , conduit ^>=1.3.2 , conduit-extra ^>=1.3.5 , containers @@ -52,18 +52,18 @@ , hackage-db ^>=2.1.0 , http-client , http-client-tls - , megaparsec ^>=9.0.0 || ^>=9.1.0 || ^>=9.2.0 + , megaparsec ^>=9.0.0 || ^>=9.1.0 || ^>=9.2.0 || ^>=9.3.0 , microlens ^>=0.4.11 , microlens-th ^>=0.4.3 , neat-interpolation ^>=0.5.1 , optparse-simple ^>=0.1.1.3 - , polysemy >=1.5.0 && <1.7.2 + , polysemy >=1.5.0 && <1.9.1 , prettyprinter ^>=1.7.0 , prettyprinter-ansi-terminal ^>=1.1.2 - , servant-client >=0.18.2 && <0.20 + , servant-client >=0.18.2 && <0.20 , split ^>=0.2.3 , tar-conduit ^>=0.3.2 - , template-haskell ^>=2.16.0 || ^>=2.17.0 + , template-haskell ^>=2.16.0 || ^>=2.17.0 || ^>=2.18.0 , text ghc-options: @@ -150,6 +150,17 @@ Submit Submit.CSV Utils + + build-depends: arch-hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + +executable arch-hs-rdepcheck + import: common-options + hs-source-dirs: rdepcheck + main-is: Main.hs + other-modules: + Args + Check build-depends: arch-hs ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/cbits/clib.c b/cbits/clib.c --- a/cbits/clib.c +++ b/cbits/clib.c @@ -4,7 +4,20 @@ #include #include -void query_community(callback_t callback) { +void dispatch_list(community_list_callback_t callback, const char *name, + const char *key, alpm_list_t *src) { + if (src == NULL) + return; + alpm_list_t *l; + for (l = src; l; l = alpm_list_next(l)) { + alpm_depend_t *dep = l->data; + const char *d_ver = dep->version; + callback(name, key, dep->name, d_ver == NULL ? "" : d_ver); + } +} + +void query_community(community_pkg_callback_t pkg_callback, + community_list_callback_t list_callback) { alpm_errno_t err; alpm_handle_t *handle; handle = alpm_initialize("/", "/var/lib/pacman", &err); @@ -17,6 +30,16 @@ for (i = pkgs; i; i = alpm_list_next(i)) { const char *name = alpm_pkg_get_name(i->data); const char *ver = alpm_pkg_get_version(i->data); + const char *desc = alpm_pkg_get_desc(i->data); + const char *url = alpm_pkg_get_url(i->data); + alpm_list_t *depends = alpm_pkg_get_depends(i->data); + alpm_list_t *makedepends = alpm_pkg_get_makedepends(i->data); + alpm_list_t *checkdepends = alpm_pkg_get_checkdepends(i->data); + alpm_list_t *provides = alpm_pkg_get_provides(i->data); + alpm_list_t *conflicts = alpm_pkg_get_conflicts(i->data); + alpm_list_t *replaces = alpm_pkg_get_replaces(i->data); + alpm_list_t *optdepends = alpm_pkg_get_optdepends(i->data); + pkg_callback(name, ver, desc, url); if (strcmp(name, "ghc") == 0 || strcmp(name, "ghc-libs") == 0) { alpm_list_t *v, *provides; provides = alpm_pkg_get_provides(i->data); @@ -24,41 +47,49 @@ alpm_depend_t *d = v->data; const char *d_name = d->name; const char *d_ver = d->version; - callback(d_name, d_ver); + // promote + pkg_callback(d_name, d_ver, "", ""); } - } else - callback(name, ver); + } + + dispatch_list(list_callback, name, "depends", depends); + dispatch_list(list_callback, name, "makedepends", makedepends); + dispatch_list(list_callback, name, "checkdepends", checkdepends); + dispatch_list(list_callback, name, "provides", provides); + dispatch_list(list_callback, name, "conflicts", conflicts); + dispatch_list(list_callback, name, "replaces", replaces); + dispatch_list(list_callback, name, "optdepends", optdepends); } alpm_release(handle); } -void query_files(const char *dbname, callback_t callback) { - alpm_errno_t err; - alpm_handle_t *handle; - handle = alpm_initialize("/", "/var/lib/pacman", &err); - alpm_option_set_dbext(handle, ".files"); - alpm_db_t *db = alpm_register_syncdb(handle, dbname, ALPM_SIG_USE_DEFAULT); - alpm_list_t *pkg, *pkgs = NULL; +void query_files(const char *dbname, file_callback_t callback) { + alpm_errno_t err; + alpm_handle_t *handle; + handle = alpm_initialize("/", "/var/lib/pacman", &err); + alpm_option_set_dbext(handle, ".files"); + alpm_db_t *db = alpm_register_syncdb(handle, dbname, ALPM_SIG_USE_DEFAULT); + alpm_list_t *pkg, *pkgs = NULL; - pkgs = alpm_db_get_pkgcache(db); + pkgs = alpm_db_get_pkgcache(db); - for (pkg = pkgs; pkg; pkg = alpm_list_next(pkg)) { - const char *pkg_name = alpm_pkg_get_name(pkg->data); - alpm_filelist_t *pkg_files = alpm_pkg_get_files(pkg->data); - for (size_t file_num = 0; file_num < pkg_files->count; file_num++) { - alpm_file_t *file = pkg_files->files + file_num; - char *path = file->name; - if (strncmp("usr/lib/", path, 8) != 0) - continue; - size_t n = strlen(path); - if (path[n - 3] != '.') - continue; - if (!((path[n - 2] == 's' && path[n - 1] == 'o') || - (path[n - 2] == 'p' && path[n - 1] == 'c'))) - continue; + for (pkg = pkgs; pkg; pkg = alpm_list_next(pkg)) { + const char *pkg_name = alpm_pkg_get_name(pkg->data); + alpm_filelist_t *pkg_files = alpm_pkg_get_files(pkg->data); + for (size_t file_num = 0; file_num < pkg_files->count; file_num++) { + alpm_file_t *file = pkg_files->files + file_num; + char *path = file->name; + if (strncmp("usr/lib/", path, 8) != 0) + continue; + size_t n = strlen(path); + if (path[n - 3] != '.') + continue; + if (!((path[n - 2] == 's' && path[n - 1] == 'o') || + (path[n - 2] == 'p' && path[n - 1] == 'c'))) + continue; - callback(pkg_name, basename(path)); - } + callback(pkg_name, basename(path)); } - alpm_release(handle); + } + alpm_release(handle); } diff --git a/cbits/clib.h b/cbits/clib.h --- a/cbits/clib.h +++ b/cbits/clib.h @@ -1,10 +1,15 @@ #ifndef CLIB_H #define CLIB_H -typedef void callback_t(const char *, const char *); +typedef void file_callback_t(const char *pkg_name, const char *file_path); +typedef void community_pkg_callback_t(const char *pkg_name, const char *version, + const char *desc, const char *url); +typedef void community_list_callback_t(const char *pkg_name, const char *key, + const char *dependent_pkg_name, + const char *dependent_pkg_version); -void query_community(callback_t callback); +void query_community(community_pkg_callback_t pkg_callback, community_list_callback_t list_callback); -void query_files(const char *dbname, callback_t callback); +void query_files(const char *dbname, file_callback_t callback); #endif diff --git a/data/NAME_PRESET.json b/data/NAME_PRESET.json --- a/data/NAME_PRESET.json +++ b/data/NAME_PRESET.json @@ -1,12 +1,16 @@ { "agda": "Agda", "alex": "alex", + "allure": "Allure", + "arbtt": "arbtt", "arch-hs": "arch-hs", "bnfc": "BNFC", + "bustle": "bustle", "c2hs": "c2hs", "haskell-cabal": "Cabal", "cabal-install": "cabal-install", "cabal-plan": "cabal-plan", + "cbor-tool": "cbor-tool", "cgrep": "cgrep", "clash-ghc": "clash-ghc", "cryptol": "cryptol", @@ -19,7 +23,10 @@ "dhall-yaml": "dhall-yaml", "git-annex": "git-annex", "git-repair": "git-repair", + "glirc": "glirc", "happy": "happy", + "haskell-boolean": "Boolean", + "haskell-boundedchan": "BoundedChan", "haskell-chasingbottoms": "ChasingBottoms", "haskell-ci": "haskell-ci", "haskell-configfile": "ConfigFile", @@ -36,39 +43,43 @@ "haskell-gi-base": "haskell-gi-base", "haskell-gi-overloading": "haskell-gi-overloading", "haskell-glob": "Glob", - "haskell-gtk": "gtk3", "haskell-graphscc": "GraphSCC", "haskell-hopenpgp": "hOpenPGP", + "haskell-hstringtemplate": "HStringTemplate", "haskell-htf": "HTF", "haskell-http": "HTTP", "haskell-hunit": "HUnit", "haskell-ifelse": "IfElse", + "haskell-iospec": "IOSpec", "haskell-juicypixels": "JuicyPixels", "haskell-language-server": "haskell-language-server", "haskell-lexer": "haskell-lexer", "haskell-listlike": "ListLike", - "haskell-lsp0": "haskell-lsp", - "haskell-lsp0-types": "haskell-lsp-types", "haskell-missingh": "MissingH", "haskell-monadlib": "monadLib", "haskell-monadrandom": "MonadRandom", "haskell-onetuple": "OneTuple", "haskell-only": "Only", "haskell-hsopenssl": "HsOpenSSL", + "haskell-hsopenssl-x509-system": "HsOpenSSL-x509-system", "haskell-hsyaml": "HsYAML", "haskell-hsyaml-aeson": "HsYAML-aeson", + "haskell-lambdahack": "LambdaHack", "haskell-libbf": "libBF", "haskell-memotrie": "MemoTrie", "haskell-monadprompt": "MonadPrompt", + "haskell-numinstances": "NumInstances", "haskell-rsa": "RSA", "haskell-puremd5": "pureMD5", "haskell-quickcheck": "QuickCheck", + "haskell-quickcheck-safe": "QuickCheck-safe", "haskell-ranged-sets": "Ranged-sets", "haskell-safesemaphore": "SafeSemaphore", "haskell-sha": "SHA", "haskell-smtlib": "smtLib", "haskell-src": "haskell-src", "haskell-src-exts": "haskell-src-exts", + "haskell-src-exts-simple": "haskell-src-exts-simple", "haskell-src-exts-util": "haskell-src-exts-util", "haskell-src-meta": "haskell-src-meta", "haskell-statevar": "StateVar", @@ -85,10 +96,12 @@ "hlint": "hlint", "hoogle": "hoogle", "hopenpgp-tools": "hopenpgp-tools", + "hslua-cli": "hslua-cli", "idris": "idris", + "ihaskell": "ihaskell", + "mighttpd2": "mighttpd2", "misfortune": "misfortune", - "pandoc": "pandoc", - "pandoc-citeproc": "pandoc-citeproc", + "pandoc-cli": "pandoc-cli", "pandoc-crossref": "pandoc-crossref", "postgrest": "postgrest", "shellcheck": "ShellCheck", @@ -102,5 +115,6 @@ "xmobar": "xmobar", "xmonad": "xmonad", "xmonad-contrib": "xmonad-contrib", + "xmonad-extras": "xmonad-extras", "xmonad-utils": "xmonad-utils" } diff --git a/diff/Main.hs b/diff/Main.hs --- a/diff/Main.hs +++ b/diff/Main.hs @@ -7,7 +7,6 @@ import Args import Control.Monad (unless) import qualified Data.Map as Map -import Data.Text.Prettyprint.Doc.Render.Terminal import Diff import Distribution.ArchHs.Core (subsumeGHCVersion) import Distribution.ArchHs.Exception diff --git a/rdepcheck/Args.hs b/rdepcheck/Args.hs new file mode 100644 --- /dev/null +++ b/rdepcheck/Args.hs @@ -0,0 +1,37 @@ +module Args + ( Options (..), + cmdOptions, + runArgsParser, + ) +where + +import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.Options +import Distribution.ArchHs.Types +import Distribution.ArchHs.Utils (archHsVersion) + +data Options = Options + { optFlags :: FlagAssignments, + optCommunityDB :: CommunityDBOptions, + optHackage :: HackageDBOptions, + optPackageName :: PackageName + } + +cmdOptions :: Parser Options +cmdOptions = + Options + <$> optFlagAssignmentParser + <*> communityDBOptionsParser + <*> hackageDBOptionsParser + <*> argument optPackageNameReader (metavar "TARGET") + +runArgsParser :: IO Options +runArgsParser = do + (x, ()) <- + simpleOptions + archHsVersion + "arch-hs-rdepcheck - check the version of a dependent Haskell package" + "arch-hs-rdepcheck is a CLI tool that shows all reverse dependencies of a Haskell package in [community], giving the version range how it is depended on" + cmdOptions + empty + pure x diff --git a/rdepcheck/Check.hs b/rdepcheck/Check.hs new file mode 100644 --- /dev/null +++ b/rdepcheck/Check.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Check (check) where + +import Control.Monad (forM_, unless) +import Data.List (find) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) +import Distribution.ArchHs.CommunityDB +import Distribution.ArchHs.Core +import Distribution.ArchHs.Exception +import Distribution.ArchHs.Hackage +import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.Name +import Distribution.ArchHs.PP +import Distribution.ArchHs.PkgDesc +import Distribution.ArchHs.Types + +data DepSrc = Check | Make | Run + deriving stock (Show, Eq, Ord) + +instance Pretty DepSrc where + pretty = \case + Check -> "CheckDepends" + Make -> "MakeDepends" + Run -> "Depends" + +check :: + Members + [ CommunityEnv, + HackageEnv, + KnownGHCVersion, + FlagAssignmentsEnv, + Trace, + DependencyRecord, + WithMyErr, + Embed IO + ] + r => + PackageName -> + Sem r () +check target = do + let aTarget = toArchLinuxName target + exists <- isInCommunity aTarget + unless exists $ throw $ PkgNotFound target + reverseDeps <- + ( \xs -> + [ (desc, [Make | md] <> [Check | cd] <> [Run | d]) + | ( _, + desc@PkgDesc + { _name = isHaskellPackage -> isHs, + _makeDepends = flip containsDep aTarget -> md, + _checkDepends = flip containsDep aTarget -> cd, + _depends = flip containsDep aTarget -> d + } + ) <- + xs, + isHs, + md || cd || d + ] + ) + . Map.toList + <$> ask @CommunityDB + forM_ reverseDeps $ \(PkgDesc {..}, src) -> do + eCabal <- + try @MyException $ + getCabal (toHackageName _name) =<< case simpleParsec _version of + Just v -> pure v + _ -> throw $ VersionNoParse _version + case eCabal of + Right cabal -> do + result <- getDepVersion cabal target src + embed . putDoc $ + vsep + ( annMagneta "Reverse dependency" <> colon + <+> pretty (unArchLinuxName _name) + : [indent 2 $ pretty s <> colon <+> viaPretty r | (s, r) <- result] + ) + <> line + Left e -> + printWarn $ "Skip" <+> pretty (unArchLinuxName _name) <> colon <+> viaShow e + +getDepVersion :: + Members + [ KnownGHCVersion, + FlagAssignmentsEnv, + DependencyRecord, + Trace + ] + r => + GenericPackageDescription -> + PackageName -> + [DepSrc] -> + Sem r [(DepSrc, VersionRange)] +getDepVersion cabal name src = do + (libDeps, libToolsDeps, _) <- collectLibDeps id cabal + (subLibDeps, subLibToolsDeps, _) <- collectSubLibDeps id cabal [] + (exeDeps, exeToolsDeps, _) <- collectExeDeps id cabal [] + (testDeps, testToolsDeps, _) <- collectTestDeps id cabal [] + setupDeps <- collectSetupDeps id cabal + let flatten = mconcat . fmap snd + deps = libDeps <> concatMap flatten [exeDeps, subLibDeps] + makeOrCheckDeps = libToolsDeps <> setupDeps <> concatMap flatten [subLibToolsDeps, exeToolsDeps, testDeps, testToolsDeps] + pure $ + catMaybes + [ case s of + Check -> f makeOrCheckDeps + Make -> f makeOrCheckDeps + Run -> f deps + | s <- src, + let f xs = (_1 .~ s) <$> find ((== name) . fst) xs + ] diff --git a/rdepcheck/Main.hs b/rdepcheck/Main.hs new file mode 100644 --- /dev/null +++ b/rdepcheck/Main.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Main (main) where + +import Args +import Check +import Control.Monad (unless) +import qualified Data.Map.Strict as Map +import Distribution.ArchHs.Core +import Distribution.ArchHs.Exception +import Distribution.ArchHs.Hackage +import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.Options +import Distribution.ArchHs.PP +import Distribution.ArchHs.Types +import GHC.IO.Encoding (setLocaleEncoding) +import GHC.IO.Encoding.UTF8 (utf8) + +main :: IO () +main = printHandledIOException $ + do + setLocaleEncoding utf8 + Options {..} <- runArgsParser + let isFlagEmpty = Map.null optFlags + + unless isFlagEmpty $ do + printInfo "You assigned flags:" + putDoc $ prettyFlagAssignments optFlags <> line + + hackage <- loadHackageDBFromOptions optHackage + community <- loadCommunityDBFromOptions optCommunityDB + + printInfo "Start running..." + runCheck hackage community optFlags (subsumeGHCVersion $ check optPackageName) & printAppResult + +runCheck :: + HackageDB -> + CommunityDB -> + FlagAssignments -> + Sem '[HackageEnv, CommunityEnv, FlagAssignmentsEnv, Trace, DependencyRecord, WithMyErr, Embed IO, Final IO] a -> + IO (Either MyException a) +runCheck community flags manager = + runFinal + . embedToFinal + . errorToIOFinal + . evalState Map.empty + . ignoreTrace + . runReader manager + . runReader flags + . runReader community diff --git a/src/Distribution/ArchHs/CommunityDB.hs b/src/Distribution/ArchHs/CommunityDB.hs --- a/src/Distribution/ArchHs/CommunityDB.hs +++ b/src/Distribution/ArchHs/CommunityDB.hs @@ -13,6 +13,7 @@ loadCommunityDB, isInCommunity, versionInCommunity, + getPkgDesc, #ifdef ALPM loadCommunityDBFFI, #endif @@ -29,40 +30,80 @@ import Distribution.ArchHs.Name import Distribution.ArchHs.PkgDesc import Distribution.ArchHs.Types -import Distribution.ArchHs.Utils +import Data.Maybe (mapMaybe) ----------------------------------------------------------------------------- #ifdef ALPM {-# LANGUAGE ForeignFunctionInterface #-} -import qualified Data.Sequence as Seq -import Data.Foldable (toList) + import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Distribution.ArchHs.Utils (extractFromEVR) import Foreign.C.String (CString, peekCString) import Foreign.Ptr (FunPtr, freeHaskellFunPtr) foreign import ccall "wrapper" - wrap :: (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ())) + wrap :: (CString -> CString -> CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> CString -> CString -> IO ())) foreign import ccall "clib.h query_community" - query_community :: FunPtr (CString -> CString -> IO ()) -> IO () + query_community :: FunPtr (CString -> CString -> CString -> CString -> IO ()) -> FunPtr (CString -> CString -> CString -> CString -> IO ()) -> IO () -callback :: IORef (Seq.Seq (ArchLinuxName, ArchLinuxVersion)) -> CString -> CString -> IO () -callback ref x y = do - x' <- peekCString x - y' <- peekCString y - modifyIORef' ref (Seq.|> (ArchLinuxName x', extractFromEVR y')) +type RawPkgSet = IORef (Map.Map ArchLinuxName ((ArchLinuxVersion, String, String), IORef (Map.Map String [(ArchLinuxName, Maybe ArchLinuxVersion)]))) +pkgCallback :: RawPkgSet -> CString -> CString -> CString -> CString -> IO () +pkgCallback ref name version desc url = do + name' <- peekCString name + version' <- peekCString version + desc' <- peekCString desc + url' <- peekCString url + m <- newIORef Map.empty + modifyIORef' ref (Map.insert (ArchLinuxName name') ((extractFromEVR version', desc', url'), m)) + +listCallback :: RawPkgSet -> CString -> CString -> CString -> CString -> IO () +listCallback ref name key dm dv = do + name' <- peekCString name + key' <- peekCString key + dm' <- peekCString dm + dv' <- peekCString dv + s <- snd . (\r -> r Map.! ArchLinuxName name') <$> readIORef ref + modifyIORef' s (Map.insertWith (++) key' [(ArchLinuxName dm', if null dv' then Nothing else Just (extractFromEVR dv'))]) + -- | The same purpose as 'loadCommunity' but use alpm to query community db instead. loadCommunityDBFFI :: IO CommunityDB loadCommunityDBFFI = do - ref <- newIORef Seq.empty - callbackW <- wrap $ callback ref - query_community callbackW - freeHaskellFunPtr callbackW - Map.fromList . toList <$> readIORef ref + ref <- newIORef Map.empty + pkgCallbackW <- wrap $ pkgCallback ref + listCallbackW <- wrap $ listCallback ref + query_community pkgCallbackW listCallbackW + freeHaskellFunPtr pkgCallbackW + freeHaskellFunPtr listCallbackW + s <- readIORef ref + re <- + mapM + ( \(name, ((ver, desc, url), r)) -> do + l <- readIORef r + let f (Just xs) = uncurry PkgDependent <$> xs + f Nothing = [] + pure + ( name, + PkgDesc + { _name = name, + _version = ver, + _desc = desc, + _url = if null url then Nothing else Just url, + _depends = f $ l Map.!? "depends", + _provides = f $ l Map.!? "provides", + _conflicts = f $ l Map.!? "conflicts", + _optDepends = f $ l Map.!? "optdepends", + _makeDepends = f $ l Map.!? "makedepends", + _checkDepends = f $ l Map.!? "checkdepends", + _replaces = f $ l Map.!? "replaces" + } + ) + ) + $ Map.toList s + pure $ Map.fromList re #endif - ----------------------------------------------------------------------------- -- | Default path to @community.db@. @@ -72,7 +113,7 @@ loadCommunityDBC :: (MonadResource m, PrimMonad m, MonadThrow m) => FilePath -> - ConduitT i (ArchLinuxName, ArchLinuxVersion) m () + ConduitT i (ArchLinuxName, PkgDesc) m () loadCommunityDBC path = do sourceFileBS path .| Zlib.ungzip .| Tar.untarChunks .| Tar.withEntries action where @@ -80,17 +121,18 @@ when (Tar.headerFileType header == Tar.FTNormal) $ do x <- mconcat <$> sinkList let txt = T.unpack . decodeUtf8 $ x - provided r = r Map.! "PROVIDES" - parseProvidedTerm t = let s = splitOn "=" t in (s ^. ix 0, s ^. ix 1) - result = case runDescFieldsParser (Tar.headerFilePath header) txt of - Right r -> case head $ r Map.! "NAME" of - "ghc" -> parseProvidedTerm <$> provided r - "ghc-libs" -> parseProvidedTerm <$> provided r - _ -> [(head $ r Map.! "NAME", extractFromEVR . head $ r Map.! "VERSION")] - -- Drop it if failed to parse - Left _ -> [] - - yieldMany $ result & each . _1 %~ ArchLinuxName + parsed = runDescParser (Tar.headerFilePath header) txt + result = case parsed of + Right desc -> + desc + : ( if _name desc == ArchLinuxName "ghc" + || _name desc == ArchLinuxName "ghc-libs" + then mapMaybe promoteDependent (_provides desc) + else [] + ) + -- Drop it if failed to parse + Left _ -> [] + yieldMany $ (\desc -> (_name desc, desc)) <$> result -- | Load @community.db@ from @path@. -- @desc@ files in the db will be parsed by @descParser@. @@ -107,7 +149,12 @@ -- | Get the version of a package in archlinux community repo. -- If the package does not exist, 'PkgNotFound' will be thrown. versionInCommunity :: (HasMyName n, Members [CommunityEnv, WithMyErr] r) => n -> Sem r ArchLinuxVersion -versionInCommunity name = +versionInCommunity name = _version <$> getPkgDesc name + +-- | Get the pkgdesc a package in archlinux community repo. +-- If the package does not exist, 'PkgNotFound' will be thrown. +getPkgDesc :: (HasMyName n, Members [CommunityEnv, WithMyErr] r) => n -> Sem r PkgDesc +getPkgDesc name = ask @CommunityDB >>= \db -> case db Map.!? toArchLinuxName name of - Just x -> return x + Just x -> pure x _ -> throw $ PkgNotFound name diff --git a/src/Distribution/ArchHs/Compat.hs b/src/Distribution/ArchHs/Compat.hs --- a/src/Distribution/ArchHs/Compat.hs +++ b/src/Distribution/ArchHs/Compat.hs @@ -4,11 +4,17 @@ module Distribution.ArchHs.Compat ( pattern PkgFlag, PkgFlag, + licenseFile, ) where +import Data.Maybe (listToMaybe) import Distribution.Types.ConfVar import Distribution.Types.Flag +import Distribution.Types.PackageDescription (PackageDescription, licenseFiles) +#if MIN_VERSION_Cabal(3,6,0) +import Distribution.Utils.Path (getSymbolicPath) +#endif pattern PkgFlag :: FlagName -> ConfVar {-# COMPLETE PkgFlag #-} @@ -19,4 +25,11 @@ #else type PkgFlag = Flag pattern PkgFlag x = Flag x +#endif + +licenseFile :: PackageDescription -> Maybe FilePath +#if MIN_VERSION_Cabal(3,6,0) +licenseFile = fmap getSymbolicPath . listToMaybe . licenseFiles +#else +licenseFile = listToMaybe . licenseFiles #endif diff --git a/src/Distribution/ArchHs/Core.hs b/src/Distribution/ArchHs/Core.hs --- a/src/Distribution/ArchHs/Core.hs +++ b/src/Distribution/ArchHs/Core.hs @@ -342,7 +342,7 @@ _makeDepends = (if uusi then " 'uusi'" else "") <> depsToString _depName makeDepends _url = getUrl cabal wrap s = " '" <> s <> "'" - _licenseFile = licenseFiles cabal ^? ix 0 + _licenseFile = licenseFile cabal _enableUusi = uusi return PkgBuild {..} diff --git a/src/Distribution/ArchHs/Exception.hs b/src/Distribution/ArchHs/Exception.hs --- a/src/Distribution/ArchHs/Exception.hs +++ b/src/Distribution/ArchHs/Exception.hs @@ -38,14 +38,16 @@ | CyclicExist [PackageName] | NetworkException ClientError | TargetDisappearException PackageName + | VersionNoParse String instance Show MyException where show (PkgNotFound name) = "Unable to find \"" <> unPackageName (toHackageName name) <> "\"" - show (VersionNotFound name version) = "Unable to find \"" <> unPackageName (toHackageName name) <> "\" " <> prettyShow version + show (VersionNotFound name version) = "Unable to find \"" <> unPackageName (toHackageName name) <> "\" " <> prettyShow version <> " in Hackage DB" show (TargetExist name provider) = "Target \"" <> unPackageName name <> "\" has been provided by " <> show provider show (CyclicExist c) = "Graph contains a cycle \"" <> show (fmap unPackageName c) <> "\"" show (NetworkException e) = show e show (TargetDisappearException name) = "Target \"" <> unPackageName name <> "\" is discarded during the dependency resolving" + show (VersionNoParse v) = "String \"" <> v <> "\" can not be parsed to Cabal version" -- | Catch 'CE.IOException' and print it. printHandledIOException :: IO () -> IO () diff --git a/src/Distribution/ArchHs/Internal/NamePresetLoader.hs b/src/Distribution/ArchHs/Internal/NamePresetLoader.hs --- a/src/Distribution/ArchHs/Internal/NamePresetLoader.hs +++ b/src/Distribution/ArchHs/Internal/NamePresetLoader.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskellQuotes #-} module Distribution.ArchHs.Internal.NamePresetLoader (loadNamePreset) where diff --git a/src/Distribution/ArchHs/Local.hs b/src/Distribution/ArchHs/Local.hs --- a/src/Distribution/ArchHs/Local.hs +++ b/src/Distribution/ArchHs/Local.hs @@ -51,6 +51,7 @@ "directory", "exceptions", "filepath", + "ghc-bignum", "ghc-boot", "ghc-boot-th", "ghc-compact", diff --git a/src/Distribution/ArchHs/PkgBuild.hs b/src/Distribution/ArchHs/PkgBuild.hs --- a/src/Distribution/ArchHs/PkgBuild.hs +++ b/src/Distribution/ArchHs/PkgBuild.hs @@ -170,7 +170,7 @@ cd $$_hkgname-$$pkgver runhaskell Setup configure -O --enable-shared --enable-executable-dynamic --disable-library-vanilla \ - --prefix=/usr --docdir=/usr/share/doc/$$pkgname --datasubdir=$pkgname --enable-tests \ + --prefix=/usr --docdir=/usr/share/doc/$$pkgname --datasubdir=$$pkgname --enable-tests \ --dynlibdir=/usr/lib --libsubdir=\$$compiler/site-local/\$$pkgid \ --ghc-option=-optl-Wl\,-z\,relro\,-z\,now \ --ghc-option='-pie' $flags diff --git a/src/Distribution/ArchHs/PkgDesc.hs b/src/Distribution/ArchHs/PkgDesc.hs --- a/src/Distribution/ArchHs/PkgDesc.hs +++ b/src/Distribution/ArchHs/PkgDesc.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE RecordWildCards #-} @@ -16,36 +14,23 @@ descFieldsParser, runDescFieldsParser, runDescParser, + promoteDependent, + containsDep, ) where +import Control.Monad (void) import qualified Data.Map.Strict as Map import Data.Void (Void) import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.Types +import Distribution.ArchHs.Utils (extractFromEVR) import Text.Megaparsec import Text.Megaparsec.Char -- | A parser takes 'String' as input, without user state. type DescParser = Parsec Void String --- | Package description file of a installed system package, --- which lies in @repo.db@ file. -data PkgDesc = PkgDesc - { _name :: String, - _version :: String, - _desc :: String, - _url :: Maybe String, - _license :: Maybe String, - _provides :: [String], - _optDepends :: [String], - _replaces :: [String], - _conflicts :: [String], - _depends :: [String], - _makeDepends :: [String] - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) - -- Common fields {- fieldList = [ "FILENAME", @@ -68,6 +53,30 @@ "CONFLICTS" ] -} +-- | Promote a versioned dependent to package description +promoteDependent :: PkgDependent -> Maybe PkgDesc +promoteDependent PkgDependent {..} = + ( \ver -> + PkgDesc + { _name = _pdName, + _version = ver, + _desc = "", + _url = Nothing, + _provides = [], + _optDepends = [], + _replaces = [], + _conflicts = [], + _makeDepends = [], + _depends = [], + _checkDepends = [] + } + ) + <$> _pdVersion + +-- | Check if a name is in 'PkgDependentList' +containsDep :: PkgDependentList -> ArchLinuxName -> Bool +containsDep deps name = name `elem` (_pdName <$> deps) + -- | Parse fields of @desc@. descFieldsParser :: DescParser (Map.Map String [String]) descFieldsParser = @@ -81,7 +90,7 @@ ) `manyTill` eof where - sep = () <$ char '%' + sep = void $ char '%' line = manyTill anySingle newline -- | Parse a desc file. @@ -89,20 +98,24 @@ descParser = descFieldsParser >>= ( \fields -> do - _name <- lookupSingle fields "NAME" - _version <- lookupSingle fields "VERSION" + _name <- ArchLinuxName <$> lookupSingle fields "NAME" + _version <- extractFromEVR <$> lookupSingle fields "VERSION" _desc <- lookupSingle fields "DESC" _url <- lookupSingleMaybe fields "URL" - _license <- lookupSingleMaybe fields "LICENSE" - _depends <- lookupList fields "DEPENDS" - _makeDepends <- lookupList fields "MAKEDEPENDS" - _provides <- lookupList fields "PROVIDES" - _optDepends <- lookupList fields "OPTDEPENDS" - _replaces <- lookupList fields "REPLACES" - _conflicts <- lookupList fields "CONFLICTS" + _depends <- toDepList =<< lookupList fields "DEPENDS" + _makeDepends <- toDepList =<< lookupList fields "MAKEDEPENDS" + _provides <- toDepList =<< lookupList fields "PROVIDES" + _optDepends <- toDepList =<< lookupList fields "OPTDEPENDS" + _replaces <- toDepList =<< lookupList fields "REPLACES" + _conflicts <- toDepList =<< lookupList fields "CONFLICTS" + _checkDepends <- toDepList =<< lookupList fields "CHECKDEPENDS" return PkgDesc {..} ) where + toDepList = mapM $ \t -> case splitOn "=" t of + [name, version] -> pure $ PkgDependent (ArchLinuxName name) (Just version) + [name] -> pure $ PkgDependent (ArchLinuxName name) Nothing + _ -> fail $ "Unable to parse dep list " <> t lookupSingle fields f = case Map.lookup f fields of (Just x) -> case x of (e : _) -> return e diff --git a/src/Distribution/ArchHs/Types.hs b/src/Distribution/ArchHs/Types.hs --- a/src/Distribution/ArchHs/Types.hs +++ b/src/Distribution/ArchHs/Types.hs @@ -17,6 +17,9 @@ ComponentPkgList, ArchLinuxName (..), SystemDependency (..), + PkgDependent (..), + PkgDependentList, + PkgDesc (..), ArchLinuxVersion, CommunityDB, HackageEnv, @@ -64,11 +67,39 @@ deriving stock (Show, Read, Eq, Ord, Generic) deriving anyclass (NFData) +-- | Arch Linux dependency type for @depends@, @replaces@, @conflicts@,.etc in 'PkgDesc' +data PkgDependent = PkgDependent + { _pdName :: ArchLinuxName, + _pdVersion :: Maybe ArchLinuxVersion + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +-- | A list of 'PkgDependent' +type PkgDependentList = [PkgDependent] + +-- | Package description file of a installed system package, retrieved from @repo.db@ file. +data PkgDesc = PkgDesc + { _name :: ArchLinuxName, + _version :: ArchLinuxVersion, + _desc :: String, + _url :: Maybe String, + _provides :: PkgDependentList, + _optDepends :: PkgDependentList, + _replaces :: PkgDependentList, + _conflicts :: PkgDependentList, + _depends :: PkgDependentList, + _makeDepends :: PkgDependentList, + _checkDepends :: PkgDependentList + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + -- | Version of packages in archlinux community repo type ArchLinuxVersion = String -- | Representation of @cummunity.db@ -type CommunityDB = Map ArchLinuxName ArchLinuxVersion +type CommunityDB = Map ArchLinuxName PkgDesc -- | Reader effect of 'HackageDB' type HackageEnv = Reader HackageDB diff --git a/sync/Main.hs b/sync/Main.hs --- a/sync/Main.hs +++ b/sync/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module Main (main) where @@ -72,7 +73,8 @@ printInfo $ "Output will be dumped to" <+> pretty optOutput exist <- doesFileExist optOutput when exist $ - printWarn $ "File" <+> pretty optOutput <+> "already existed" <+> "overwrite it" + printWarn $ + "File" <+> pretty optOutput <+> "already existed" <+> "overwrite it" printInfo "Start running..." unless (optUpload || hasOutput) $ @@ -89,6 +91,6 @@ putStrLn $ unlines [ unArchLinuxName name <> (if optWithVersion then ": " <> version else "") - | (name, version) <- Map.toList community, + | (name, _version -> version) <- Map.toList community, isHaskellPackage name ] diff --git a/sync/Utils.hs b/sync/Utils.hs --- a/sync/Utils.hs +++ b/sync/Utils.hs @@ -21,10 +21,10 @@ linkedHaskellPackages = do communityHaskellPackages <- filter (isHaskellPackage . fst) . Map.toList <$> ask @CommunityDB hackagePackages <- Map.keys <$> ask @HackageDB - let go xs ys ((name, version) : pkgs) = + let go xs ys ((name, desc) : pkgs) = let hName = toHackageName name in if hName `elem` hackagePackages - then getLatestCabal hName >>= \cabal -> go ((name, version, cabal) : xs) ys pkgs + then getLatestCabal hName >>= \cabal -> go ((name, _version desc, cabal) : xs) ys pkgs else go xs (name : ys) pkgs go xs ys [] = pure (xs, ys) (linked, unlinked) <- go [] [] communityHaskellPackages