diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,24 @@ `arch-hs` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.6.0.0 + +* Adopt [prettyprinter](https://hackage.haskell.org/package/prettyprinter) + +* Support resolving `pkgconfigDepends` and `extraLibs` using pacman files db + +* Support resolving custom-setup dependencies + +* Add an option to force `arch-hs` to run even if the target is in [community] + +* Adopt [Diff](https://hackage.haskell.org/package/Diff) in `arch-hs-diff` and `arch-hs-submit` + +* Fix the bug that `ghc` is missing in depends + +* Fix typo ([#35](https://github.com/berberman/arch-hs/pull/35)) + +* Update dependencies ([#34](https://github.com/berberman/arch-hs/pull/34)) + ## 0.5.0.0 * Add `TargetDisappearException` to complain if target is clearly not reachable diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,10 +1,13 @@ # arch-hs -[![GitHub CI](https://github.com/berberman/arch-hs/workflows/CI/badge.svg)](https://github.com/berberman/arch-hs/actions) -[![Build Status](https://travis-ci.com/berberman/arch-hs.svg?branch=master)](https://travis-ci.com/berberman/arch-hs) [![Hackage](https://img.shields.io/hackage/v/arch-hs.svg?logo=haskell)](https://hackage.haskell.org/package/arch-hs) [![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE) +| Env | CI | +| ---------------- | ------------------------------------------------------------ | +| pacman (-f alpm) | [![GitHub CI](https://github.com/berberman/arch-hs/workflows/CI/badge.svg)](https://github.com/berberman/arch-hs/actions) | +| cabal-install | [![Build Status](https://travis-ci.com/berberman/arch-hs.svg?branch=master)](https://travis-ci.com/berberman/arch-hs) | + A program generating PKGBUILD for hackage packages. Special thanks to [felixonmars](https://github.com/felixonmars/). **Notice that `arch-hs` will always support only the latest GHC version.** @@ -13,7 +16,7 @@ ## Introduction Given the name of a package in hackage, `arch-hs` can generate PKGBUILD files, not only for the package -whose name is given, but also for all dependencies missing in [\[community\]](https://www.archlinux.org/packages/). +whose name is given, but also for all dependencies missing in [[community]](https://www.archlinux.org/packages/). `arch-hs` has a naive built-in dependency solver, which can fetch those dependencies and find out which are required to be packaged. During the dependency calculation, all version constraints will be discarded due to the arch haskell packaging strategy, thus there is no guarantee of dependencies' version consistency. @@ -22,7 +25,7 @@ `arch-hs` is a PKGBUILD text file generator, which is not integrated with `pacman`(See [Alpm Support](#Alpm-Support)), depending on nothing than: -* Pacman database (`community.db`) +* Pacman databases (`community.db`, `community.files`, `core.files`, and `extra.files`) * Hackage index tarball (`01-index.tar`, or `00-index.tar` previously) -- usually provided by `cabal-install` @@ -30,7 +33,7 @@ `arch-hs` is portable, which means it's not restricted to Arch Linux. However, `arch-hs` can use libalpm to load pacman database on Arch Linux, -and if you want to run them on other systems, you have to build it from source. +and if you want to run on other systems, you have to build it from source. ### Install the latest release @@ -38,7 +41,7 @@ # pacman -S arch-hs ``` -`arch-hs` is available in [\[community\]](https://www.archlinux.org/packages/community/x86_64/arch-hs/), so you can install it using `pacman`. +`arch-hs` is available in [[community]](https://www.archlinux.org/packages/community/x86_64/arch-hs/), so you can install it using `pacman`. ### Install the development version @@ -46,7 +49,7 @@ # pacman -S arch-hs-git ``` -The `-git` version is available in [\[archlinuxcn\]](https://github.com/archlinuxcn/repo), following the latest git commit. +The `-git` version is available in [[archlinuxcn]](https://github.com/archlinuxcn/repo), following the latest git commit. ## Build @@ -69,61 +72,102 @@ ## Usage +**Please ignore `hsc2hs`. This package may emerge unexpectedly, since it is missing in provide list of `ghc`.** +**This will be fixed in next GHC release by haskell maintainers of Arch Linux.** + Just run `arch-hs` in command line with options and a target. Here is an example: -we will create the archlinux package of [accelerate](https://hackage.haskell.org/package/accelerate): +we will create the archlinux package of [gi-gdk](https://hackage.haskell.org/package/gi-gdk): ``` -$ arch-hs -o ~/test accelerate +$ arch-hs -o ~/test --alpm gi-gdk ...... - ⓘ Recommended package order (from topological sort): -1. unique -2. tasty-kat -3. accelerate +ⓘ Recommended package order: +1. hsc2hs +2. gi-glib +3. gi-gobject +4. gi-harfbuzz +5. gi-pango +6. gi-gio +7. gi-gdkpixbuf +8. gi-gdk ...... - ⓘ Write file: /home/berberman/test/haskell-accelerate/PKGBUILD - ⓘ Write file: /home/berberman/test/haskell-unique/PKGBUILD - ⓘ Write file: /home/berberman/test/haskell-tasty-kat/PKGBUILD - ✔ Success! +ⓘ Now finding corresponding system package(s) using files db: +ⓘ Loading core files from libalpm... +ⓘ Loading extra files from libalpm... +ⓘ Loading community files from libalpm... +ⓘ Done: +gtk4.pc ✘ +gdk-pixbuf-2.0.pc ⇒ gdk-pixbuf2 +gio-2.0.pc ⇒ glib2 +glib-2.0.pc ⇒ glib2 +gobject-2.0.pc ⇒ glib2 +harfbuzz.pc ⇒ harfbuzz +harfbuzz-gobject.pc ⇒ harfbuzz +pango.pc ⇒ pango +⚠ Unable to obtain all required system packages + +...... + +ⓘ Write file: /home/berberman/test/haskell-gi-gdk/PKGBUILD +ⓘ Write file: /home/berberman/test/haskell-gi-gdkpixbuf/PKGBUILD +ⓘ Write file: /home/berberman/test/haskell-gi-gio/PKGBUILD +ⓘ Write file: /home/berberman/test/haskell-gi-glib/PKGBUILD +ⓘ Write file: /home/berberman/test/haskell-gi-gobject/PKGBUILD +ⓘ Write file: /home/berberman/test/haskell-gi-harfbuzz/PKGBUILD +ⓘ Write file: /home/berberman/test/haskell-gi-pango/PKGBUILD +ⓘ Write file: /home/berberman/test/haskell-hsc2hs/PKGBUILD +✔ Success! + ``` -This message tells us that in order to package `accelerate`, we must package `unique` -and `tasty-kat` first sequentially, because `accelerate` dependents on them to build or test, -whereas they are not present in archlinux \[community\] repo. +This message tells us that in order to package `gi-gdk`, we must package its dependencies +listed in package order, which are not present in [community] repo. Particularly, `gi-gdk` +requires external system dependencies, so `arch-hs` can map them to system packages using files db. ``` $ tree ~/test -/home/berberman/Desktop/test -├── haskell-accelerate +/home/berberman/test +├── haskell-gi-gdk │ └── PKGBUILD -├── haskell-tasty-kat +├── haskell-gi-gdkpixbuf │ └── PKGBUILD -└── haskell-unique +├── haskell-gi-gio +│ └── PKGBUILD +├── haskell-gi-glib +│ └── PKGBUILD +├── haskell-gi-gobject +│ └── PKGBUILD +├── haskell-gi-harfbuzz +│ └── PKGBUILD +├── haskell-gi-pango +│ └── PKGBUILD +└── haskell-hsc2hs └── PKGBUILD ``` -`arch-hs` will generate PKGBUILD for each package. Let's see what we have in `./haskell-accelerate/PKGBUILD`: +`arch-hs` generates PKGBUILD for each package. Let's see what we have in `./haskell-gi-harfbuzz/PKGBUILD`: ``` bash -# This file was generated by arch-hs, please check it manually. +# This file was generated by https://github.com/berberman/arch-hs, please check it manually. # Maintainer: Your Name -_hkgname=accelerate -pkgname=haskell-accelerate -pkgver=1.3.0.0 +_hkgname=gi-harfbuzz +pkgname=haskell-gi-harfbuzz +pkgver=0.0.3 pkgrel=1 -pkgdesc="An embedded language for accelerated array processing" -url="https://github.com/AccelerateHS/accelerate/" -license=("custom:BSD3") +pkgdesc="HarfBuzz bindings" +url="https://github.com/haskell-gi/haskell-gi" +license=("LGPL2.1") arch=('x86_64') -depends=('ghc-libs' 'haskell-ansi-terminal' 'haskell-base-orphans' 'haskell-cryptonite' 'haskell-half' 'haskell-hashable' 'haskell-hashtables' 'haskell-hedgehog' 'haskell-lens' 'haskell-prettyprinter' 'haskell-prettyprinter-ansi-terminal' 'haskell-primitive' 'haskell-tasty' 'haskell-terminal-size' 'haskell-unique' 'haskell-unordered-containers' 'haskell-vector') -makedepends=('ghc' 'haskell-doctest') +depends=('ghc-libs' 'haskell-gi-glib' 'haskell-gi-gobject' 'haskell-gi' 'haskell-gi-base' 'haskell-gi-overloading' 'harfbuzz') +makedepends=('ghc') source=("https://hackage.haskell.org/packages/archive/$_hkgname/$pkgver/$_hkgname-$pkgver.tar.gz") -sha256sums=('4b97161f145c81f7554679802059598587e06d49b2c153e7bafc4dd6974bad92') +sha256sums=('5f61c7b07427d0b77f867c3bc560043239c6184f98921295ce28fc8c9ce257e5') build() { cd $_hkgname-$pkgver @@ -141,11 +185,6 @@ sed -i -r -e "s|ghc-pkg.*unregister[^ ]* |&'--force' |" unregister.sh } -check() { - cd $_hkgname-$pkgver - runhaskell Setup test -} - package() { cd $_hkgname-$pkgver @@ -160,7 +199,7 @@ `arch-hs` will collect the information from hackage db, and apply it into a fixed template after some processing steps including renaming, matching license, and filling out dependencies etc. However, packaging haven't been done so far. -`arch-hs` may does well statically, but we should guarantee that this package can be built by ghc with the latest dependencies; +`arch-hs` can't guarantee that this package can be built by ghc with the latest dependencies; hence some patchs may be required in `prepare()`, such as [uusi](#Uusi). @@ -247,7 +286,14 @@ See [Alpm Support](#Alpm-Support). +### Force +``` +$ arch-hs --force TARGET +``` + +With `--force`, `arch-hs` will try to package even if the target is provided. + ## [Name preset](https://github.com/berberman/arch-hs/blob/master/data/NAME_PRESET.json) To distribute a haskell package to archlinux, the name of package should be changed according to the naming convention: @@ -264,76 +310,102 @@ ## Diff -`arch-hs` also provides a component called `arch-hs-diff`. `arch-hs-diff` can show the differences of package description between two versions of a package. -This is useful in the subsequent maintenance of a package. Example: +`arch-hs` also provides a component called `arch-hs-diff`. `arch-hs-diff` can show the differences of package description between two versions of a package, +and remind us if some required packages in community repo can't satisfy the version constraints, or they are non-existent. +This is useful in the subsequent maintenance of a package. For example: ``` -$ arch-hs-diff HTTP 4000.3.14 4000.3.15 - ▶ You didn't pass -f, different flag values may make difference in dependency resolving. - ⓘ Start running... - ⓘ Downloading cabal file from https://hackage.haskell.org/package/HTTP-4000.3.14/revision/0.cabal... - ⓘ Downloading cabal file from https://hackage.haskell.org/package/HTTP-4000.3.15/revision/0.cabal... -Package: HTTP -Version: 4000.3.14 ⇒ 4000.3.15 -Synopsis: A library for client-side HTTP -URL: https://github.com/haskell/HTTP +$ arch-hs-diff --alpm comonad 5.0.6 5.0.7 +ⓘ Loading community.db from libalpm +ⓘ Start running... +ⓘ Downloading cabal file from https://hackage.haskell.org/package/comonad-5.0.6/revision/0.cabal... +ⓘ Downloading cabal file from https://hackage.haskell.org/package/comonad-5.0.7/revision/0.cabal... +Package: comonad +Version: 5.0.6 ⇒ 5.0.7 +Synopsis: Comonads +URL: http://github.com/ekmett/comonad/ Depends: - base >=4.3.0.0 && <4.14 - time >=1.1.2.3 && <1.10 - array >=0.3.0.2 && <0.6 - bytestring >=0.9.1.5 && <0.11 - mtl >=2.0 && <2.3 - network >=2.6 && <3.2 - network-uri ==2.6.* - parsec >=2.0 && <3.2 + base >=4 && <5 + containers >=0.3 && <0.7 + distributive >=0.2.2 && <1 + tagged >=0.7 && <1 + transformers >=0.2 && <0.6 + transformers-compat >=0.3 && <1 -------------------------------------- - base >=4.3.0.0 && <4.15 - time >=1.1.2.3 && <1.11 - array >=0.3.0.2 && <0.6 - bytestring >=0.9.1.5 && <0.11 - mtl >=2.0 && <2.3 - network >=2.6 && <3.2 - network-uri ==2.6.* - parsec >=2.0 && <3.2 + base >=4 && <5 + containers >=0.3 && <0.7 + distributive >=0.2.2 && <1 + indexed-traversable >=0.1 && <0.2 + tagged >=0.7 && <1 + transformers >=0.2 && <0.6 + transformers-compat >=0.3 && <1 + MakeDepends: - HUnit >=1.2.0.1 && <1.7 - deepseq >=1.3.0.0 && <1.5 - httpd-shed >=0.4 && <0.5 - mtl >=1.1.1.0 && <2.3 - pureMD5 >=0.2.4 && <2.2 - split >=0.1.3 && <0.3 - test-framework >=0.2.0 && <0.9 - test-framework-hunit >=0.3.0 && <0.4 + base -any + doctest >=0.11.1 && <0.17 +-------------------------------------- + base -any + doctest >=0.11.1 && <0.18 +"doctest" is required to be in range (>=0.11.1 && <0.17), but [community] provides (0.17). Flags: - HTTP - ⚐ mtl1: - description: - Use the old mtl version 1. - default: False - isManual: False - ⚐ warn-as-error: - description: - Build with warnings-as-errors - default: False - isManual: True - ⚐ conduit10: - description: - Use version 1.0.x or below of the conduit package (for the test suite) - default: False - isManual: False - ⚐ warp-tests: - description: - Test against warp - default: False - isManual: True - ⚐ network-uri: - description: - Get Network.URI from the network-uri package - default: True - isManual: False + comonad + ⚐ test-doctests: + description: + + default: True + isManual: True + ⚐ containers: + description: + You can disable the use of the `containers` package using `-f-containers`. + Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + default: True + isManual: True + ⚐ distributive: + description: + You can disable the use of the `distributive` package using `-f-distributive`. - ✔ Success! + Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + + If disabled we will not supply instances of `Distributive` + + default: True + isManual: True +-------------------------------------- + comonad + ⚐ test-doctests: + description: + + default: True + isManual: True + ⚐ containers: + description: + You can disable the use of the `containers` package using `-f-containers`. + + Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + default: True + isManual: True + ⚐ distributive: + description: + You can disable the use of the `distributive` package using `-f-distributive`. + + Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + + If disabled we will not supply instances of `Distributive` + + default: True + isManual: True + ⚐ indexed-traversable: + description: + You can disable the use of the `indexed-traversable` package using `-f-indexed-traversable`. + + Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + + If disabled we will not supply instances of `FunctorWithIndex` + + default: True + isManual: True +✔ Success! ``` `arch-hs-diff` does not require hackage db, it downloads cabal files from hackage server instead. @@ -345,7 +417,7 @@ ## Limitations * `arch-hs` will run into error, if solved targets contain cycle. Indeed, circular dependency lies ubiquitously in hackage because of tests, -but basic cycles are resolved manually in \[community\] by maintainers. So after the provider simplification, `arch-hs` can eliminate these cycles. +but basic cycles are resolved manually in [community] by maintainers. So after the provider simplification, `arch-hs` can eliminate these cycles. Nevertheless, if the target introduces new cycle or it dependens on a package in an unknown cycle, `arch-hs` will throw `CyclicExist` exception. * `arch-hs` is not able to handle with complicated situations: the libraries of a package partially exist in hackage, some libraries include external sources, etc. @@ -356,7 +428,7 @@ ## Alpm Support [alpm](https://www.archlinux.org/pacman/libalpm.3.html) is Arch Linux Package Management library. -When running on Arch Linux, loading `community.db` through this library is slightly faster than using the internal parser of `arch-hs`. +When running on Arch Linux, loading `community.db` and files dbs through this library is slightly faster than using the internal parser of `arch-hs`. Thus, `arch-hs` provides a flag `alpm` to enable this feature: ``` @@ -366,15 +438,7 @@ This flag is enabled by default in `arch-hs` Arch Linux package. Compiled with `alpm`, `arch-hs` can accept runtime flag `--alpm`. **That said, if you want to use alpm to boost `arch-hs`, you need compile `arch-hs` with cabal flag `alpm`, and pass `--aplm` to `arch-hs` when running.** -> When `alpm` is enabled, `arch-hs` will lose the capability of specifying the path of `community.db`. - -## ToDoList - -- [ ] **Standardized pretty printing**. - -- [x] AUR support. - -- [x] Working with given `.cabal` files which haven't been released to hackage. +> When `alpm` is enabled, `arch-hs` will lose the capability of specifying the path of `community.db` and directory of files db. ## Contributing diff --git a/app/Args.hs b/app/Args.hs --- a/app/Args.hs +++ b/app/Args.hs @@ -13,10 +13,16 @@ import Distribution.ArchHs.OptionReader import Distribution.ArchHs.Types +#ifndef ALPM +import Distribution.ArchHs.CommunityDB (defaultCommunityDBPath) +import Distribution.ArchHs.FilesDB (defaultFilesDBDir) +#endif + data Options = Options { optHackagePath :: FilePath, #ifndef ALPM - optCommunityPath :: FilePath, + optCommunityDBPath :: FilePath, + optFilesDBPath :: FilePath, #endif optOutputDir :: FilePath, optFlags :: FlagAssignments, @@ -26,6 +32,7 @@ optStdoutTrace :: Bool, optFileTrace :: FilePath, optUusi :: Bool, + optForce :: Bool, optMetaDir :: FilePath, #ifdef ALPM optAlpm :: Bool, @@ -43,7 +50,7 @@ <> short 'h' <> help "Path to hackage index tarball" <> showDefault - <> value "~/.cabal/packages/YOUR_HACKAGE_MIRROR/01-index.tar | 00-index.tar" + <> value "" ) #ifndef ALPM <*> strOption @@ -52,8 +59,16 @@ <> short 'c' <> help "Path to community.db" <> showDefault - <> value "/var/lib/pacman/sync/community.db" + <> value defaultCommunityDBPath ) + <*> strOption + ( long "files" + <> metavar "PATH" + <> short 'f' + <> help "Path of dir that includes core.files, extra.files and community.files" + <> showDefault + <> value defaultFilesDBDir + ) #endif <*> strOption ( long "output" @@ -104,6 +119,10 @@ <*> switch ( long "uusi" <> help "Splice uusi into prepare()" + ) + <*> switch + ( long "force" + <> help "Try to package even if target is provided" ) <*> strOption ( long "meta" diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -10,19 +10,20 @@ import qualified Algebra.Graph.AdjacencyMap.Algorithm as G import qualified Algebra.Graph.Labelled.AdjacencyMap as GL import Args -import qualified Colourista as C import Control.Monad (filterM, forM_, unless) import Data.Containers.ListUtils (nubOrd) -import Data.IORef (IORef, newIORef) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) import Data.List.NonEmpty (toList) import qualified Data.Map.Strict as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import qualified Data.Set as Set import qualified Data.Text as T +import qualified Data.Text.IO as T import Distribution.ArchHs.Aur (Aur, aurToIO, isInAur) -import Distribution.ArchHs.Community +import Distribution.ArchHs.CommunityDB import Distribution.ArchHs.Core import Distribution.ArchHs.Exception +import Distribution.ArchHs.FilesDB import Distribution.ArchHs.Hackage import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Local @@ -41,38 +42,46 @@ Bool -> [String] -> Bool -> + Bool -> FilePath -> + (DBKind -> IO FilesDB) -> Sem r () -app target path aurSupport skip uusi metaPath = do - (deps, sublibs) <- getDependencies (fmap mkUnqualComponentName skip) Nothing target +app target path aurSupport skip uusi force metaPath loadFilesDB' = do + (deps, sublibs, sysDeps) <- getDependencies (fmap mkUnqualComponentName skip) Nothing target inCommunity <- isInCommunity target - when inCommunity $ throw $ TargetExist target ByCommunity + when inCommunity $ + if force + then printWarn "Target has been provided by [community], ignoring it" + else throw $ TargetExist target ByCommunity when aurSupport $ do inAur <- isInAur target - when inAur $ throw $ TargetExist target ByAur + when inAur $ + if force + then printWarn "Target has been provided by [aur], ignoring it" + else throw $ TargetExist target ByAur - let removeSublibs list = - list ^.. each . filtered (\x -> x ^. pkgName `notElem` sublibs) & each %~ (\x -> x & pkgDeps %~ filter (\d -> d ^. depName `notElem` sublibs)) + let removeSublibs pkgs = + pkgs ^.. each . filtered (\x -> x ^. pkgName `notElem` sublibs) & each %~ (\x -> x & pkgDeps %~ filter (\d -> d ^. depName `notElem` sublibs)) grouped = removeSublibs $ groupDeps deps namesFromSolved x = x ^.. each . pkgName <> x ^.. each . pkgDeps . each . depName allNames = nubOrd $ namesFromSolved grouped - communityProvideList <- (<> ghcLibList) <$> filterM isInCommunity allNames + communityProvideList <- (<> ghcLibList) <$> filterM (\x -> if x == target && force then return False else isInCommunity x) allNames let providedPackages = filter (\x -> x ^. pkgName `elem` communityProvideList) grouped abnormalDependencies = mapMaybe ( \x -> case filter (`notElem` communityProvideList) (x ^. pkgDeps ^.. each . depName) of [] -> Nothing - list -> Just (x ^. pkgName, list) + pkgs -> Just (x ^. pkgName, pkgs) ) providedPackages embed $ forM_ abnormalDependencies $ \(T.pack . unPackageName -> parent, childs) -> do - C.warningMessage $ "Package \"" <> parent <> "\" is provided without:" + printWarn $ "Package \"" <> parent <> "\" is provided without:" forM_ childs $ putStrLn . unPackageName let fillProvidedPkgs provideList provider = map (\x -> if (x ^. pkgName) `elem` provideList then ProvidedPackage (x ^. pkgName) provider else x) @@ -80,10 +89,10 @@ filledByCommunity = fillProvidedPkgs communityProvideList ByCommunity . fillProvidedDeps communityProvideList ByCommunity $ grouped toBePacked1 = filledByCommunity ^.. each . filtered (not . isProvided) (filledByBoth, toBePacked2) <- do - embed . when aurSupport $ C.infoMessage "Start searching AUR..." + when aurSupport $ printInfo "Start searching AUR..." aurProvideList <- if aurSupport - then filterM (\n -> do embed $ C.infoMessage ("Searching " <> T.pack (unPackageName n)); isInAur n) $ toBePacked1 ^.. each . pkgName + then filterM (\n -> do printInfo ("Searching " <> T.pack (unPackageName n)); isInAur n) $ filter (\x -> not $ x == target && force) $ toBePacked1 ^.. each . pkgName else return [] let a = fillProvidedPkgs aurProvideList ByAur . fillProvidedDeps aurProvideList ByAur $ filledByCommunity b = a ^.. each . filtered (not . isProvided) @@ -92,28 +101,62 @@ when (null filledByBoth) $ throw $ TargetDisappearException target - embed $ C.infoMessage "Solved:" - embed $ putStrLn . prettySolvedPkgs $ filledByBoth + printInfo "Solved:" + embed $ T.putStrLn . prettySolvedPkgs $ filledByBoth - embed $ C.infoMessage "Recommended package order:" + printInfo "Recommended package order:" let vertexesToBeRemoved = filledByBoth ^.. each . filtered isProvided ^.. each . pkgName removeSelfCycle g = foldr (\n acc -> GL.removeEdge n n acc) g $ toBePacked2 ^.. each . pkgName newGraph = GL.induce (`notElem` vertexesToBeRemoved) deps flattened <- case G.topSort . GL.skeleton $ removeSelfCycle newGraph of Left c -> throw . CyclicExist $ toList c Right x -> return $ filter (`notElem` sublibs) x - embed $ putStrLn . prettyDeps . reverse $ flattened + + embed . putDoc $ (prettyDeps . reverse $ flattened) <> line <> line + + let sysDepsToBePacked = Map.filterWithKey (\k _ -> k `elem` flattened) sysDeps + + unless (null sysDepsToBePacked) $ do + printInfo "Detected pkgconfig or extraLib from target(s):" + embed $ T.putStrLn $ ppSysDependencies sysDepsToBePacked + + sysDepsRef <- embed . newIORef $ toUnsolved <$> nubOrd (Map.foldMapWithKey (\_ x -> x) sysDepsToBePacked) + + embed $ + isAllSolvedM sysDepsRef >>= \b -> unless b $ do + printInfo "Now finding corresponding system package(s) using files db:" + coreFiles <- loadFilesDB' Core + modifyIORef' sysDepsRef $ fmap (trySolve coreFiles) + b' <- isAllSolvedM sysDepsRef + unless b' $ do + extraFiles <- loadFilesDB' Extra + modifyIORef' sysDepsRef $ fmap (trySolve extraFiles) + b'' <- isAllSolvedM sysDepsRef + unless b'' $ do + communityFiles <- loadFilesDB' Community + modifyIORef' sysDepsRef $ fmap (trySolve communityFiles) + + sysDepsResult <- embed $ readIORef sysDepsRef + + embed . unless (null sysDepsToBePacked) $ do + printInfo "Done:" + T.putStrLn . align2col $ ppEmergedSysDep <$> sysDepsResult + unless (isAllSolved sysDepsResult) $ printWarn "Unable to obtain all required system packages" + + let sysDepsMapping = collectAllSolved sysDepsResult + getSysDeps name = nubOrd $ catMaybes [sysDepsMapping Map.!? file | (SystemDependency file) <- fromMaybe [] $ sysDeps Map.!? name] + flags <- filter (\(_, l) -> not $ null l) <$> mapM (\n -> (n,) <$> getPackageFlag n) flattened embed $ unless (null flags) $ do - C.infoMessage "Detected flag(s) from targets:" - putStrLn . prettyFlags $ flags + printInfo "Detected flag(s) from targets:" + putDoc $ prettyFlags flags <> line <> line unless (null path) $ mapM_ ( \solved -> do - pkgBuild <- cabalToPkgBuild solved uusi + pkgBuild <- cabalToPkgBuild solved uusi $ getSysDeps (solved ^. pkgName) let pName = N._pkgName pkgBuild dir = path pName fileName = dir "PKGBUILD" @@ -121,7 +164,7 @@ embed $ do createDirectoryIfMissing True dir writeFile fileName txt - C.infoMessage $ "Write file: " <> T.pack fileName + printInfo $ "Write file: " <> T.pack fileName ) toBePacked2 @@ -134,7 +177,7 @@ pkg ^. pkgDeps ^.. each . filtered (\x -> depNotMyself (pkg ^. pkgName) x && depNotInGHCLib x && x ^. depProvider == Just ByCommunity) - toStr x = "'" <> (unCommunityName . toCommunityName . _depName) x <> "'" + toStr x = "'" <> (unArchLinuxName . toArchLinuxName . _depName) x <> "'" depends = case unwords . nubOrd . fmap toStr . mconcat $ providedDepends <$> toBePacked2 of [] -> "" xs -> " " <> xs @@ -149,10 +192,37 @@ embed $ do createDirectoryIfMissing True dir writeFile fileName (T.unpack txt) - C.infoMessage $ "Write file: " <> T.pack fileName + printInfo $ "Write file: " <> T.pack fileName ----------------------------------------------------------------------------- +data EmergedSysDep = Solved File ArchLinuxName | Unsolved File + deriving stock (Eq, Ord, Show) +toUnsolved :: SystemDependency -> EmergedSysDep +toUnsolved (SystemDependency x) = Unsolved x + +trySolve :: FilesDB -> EmergedSysDep -> EmergedSysDep +trySolve db dep + | (Unsolved x) <- dep, + (pkg : _) <- lookupPkg x db = + Solved x pkg + | otherwise = dep + +isAllSolved :: [EmergedSysDep] -> Bool +isAllSolved xs = null [() | (Unsolved _) <- xs] + +isAllSolvedM :: IORef [EmergedSysDep] -> IO Bool +isAllSolvedM ref = isAllSolved <$> readIORef ref + +collectAllSolved :: [EmergedSysDep] -> Map.Map File ArchLinuxName +collectAllSolved xs = Map.fromList [(file, name) | (Solved file name) <- xs] + +ppEmergedSysDep :: EmergedSysDep -> (Doc AnsiStyle, Doc AnsiStyle) +ppEmergedSysDep (Solved file (ArchLinuxName name)) = (annGreen . pretty $ file, " ⇒ " <> (annCyan . pretty $ name)) +ppEmergedSysDep (Unsolved file) = (annYellow . annBold . pretty $ file, indent 19 cuo) + +----------------------------------------------------------------------------- + runApp :: HackageDB -> CommunityDB -> @@ -188,59 +258,63 @@ Options {..} <- runArgsParser unless (null optFileTrace) $ do - C.infoMessage $ "Trace will be dumped to " <> T.pack optFileTrace <> "." + printInfo $ "Trace will be dumped to " <> T.pack optFileTrace <> "." writeFile optFileTrace "" - let useDefaultHackage = "YOUR_HACKAGE_MIRROR" `isInfixOf` optHackagePath - when useDefaultHackage $ C.skipMessage "You didn't pass -h, use hackage index file from default path." - -#ifndef ALPM - let useDefaultCommunity = "/var/lib/pacman/sync/community.db" == optCommunityPath - when useDefaultCommunity $ C.skipMessage "You didn't pass -c, use community db file from default path." -#endif - let isFlagEmpty = Map.null optFlags isSkipEmpty = null optSkip - when isFlagEmpty $ C.skipMessage "You didn't pass -f, different flag assignments may make difference in dependency resolving." unless isFlagEmpty $ do - C.infoMessage "You assigned flags:" - putStrLn . prettyFlagAssignments $ optFlags + printInfo "You assigned flags:" + putDoc $ prettyFlagAssignments optFlags <> line <> line unless isSkipEmpty $ do - C.infoMessage "You chose to skip:" - putStrLn $ prettySkip optSkip + printInfo "You chose to skip:" + putDoc $ prettySkip optSkip <> line <> line - when optAur $ C.infoMessage "You passed -a, searching AUR may takes a long time." + when optAur $ printInfo "You passed -a, searching AUR may takes a long time." - when optUusi $ C.infoMessage "You passed --uusi, uusi will become makedepends of each package." + when optUusi $ printInfo "You passed --uusi, uusi will become makedepends of each package." - hackage <- loadHackageDB =<< if useDefaultHackage then lookupHackagePath else return optHackagePath - C.infoMessage "Loading hackage..." + hackagePath <- if null optHackagePath then lookupHackagePath else return optHackagePath + printInfo $ "Loading hackage from " <> T.pack hackagePath + + hackage <- loadHackageDB hackagePath + let isExtraEmpty = null optExtraCabalPath unless isExtraEmpty $ - C.infoMessage $ "You added " <> (T.pack . intercalate ", " $ map takeFileName optExtraCabalPath) <> " as extra cabal file(s), starting parsing right now." + printInfo $ "You added " <> (T.pack . intercalate ", " $ map takeFileName optExtraCabalPath) <> " as extra cabal file(s), starting parsing right now." parsedExtra <- mapM parseCabalFile optExtraCabalPath let newHackage = foldr insertDB hackage parsedExtra #ifdef ALPM - when optAlpm $ C.infoMessage "Using alpm." - community <- if optAlpm then loadCommunityFFI else loadProcessedCommunity defaultCommunityPath + let src = T.pack $ if optAlpm then "libalpm" else defaultCommunityDBPath + printInfo $ "Loading community.db from " <> src + community <- if optAlpm then loadCommunityDBFFI else loadCommunityDB defaultCommunityDBPath #else - community <- loadProcessedCommunity $ if useDefaultCommunity then defaultCommunityPath else optCommunityPath + printInfo $ "Loading community.db from " <> T.pack optCommunityDBPath + community <- loadCommunityDB optCommunityDBPath #endif - C.infoMessage "Loading community.db..." - - C.infoMessage "Start running..." + printInfo "Start running..." empty <- newIORef Set.empty - runApp newHackage community optFlags optStdoutTrace optFileTrace empty (app optTarget optOutputDir optAur optSkip optUusi optMetaDir) & printAppResult + let loadF db = do +#ifdef ALPM + printInfo $ "Loading " <> T.pack (show db) <>" files from libalpm..." + if optAlpm then loadFilesDBFFI db else loadFilesDB db defaultFilesDBDir +#else + printInfo $ "Loading " <> T.pack (show db) <>" files from " <> T.pack optFilesDBPath <> "..." + loadFilesDB db optFilesDBPath + +#endif + + runApp newHackage community optFlags optStdoutTrace optFileTrace empty (app optTarget optOutputDir optAur optSkip optUusi optForce optMetaDir loadF) & printAppResult ----------------------------------------------------------------------------- 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.5.0.0 +version: 0.6.0.0 synopsis: Distribute hackage packages to archlinux description: @arch-hs@ is a command-line program, which simplifies the process of producing @@ -14,7 +14,7 @@ license: MIT license-file: LICENSE author: berberman -maintainer: berberman <1793913507@qq.com> +maintainer: berberman copyright: 2020 berberman category: Distribution build-type: Simple @@ -36,30 +36,32 @@ common common-options build-depends: - , aeson ^>=1.5.4 - , algebraic-graphs ^>=0.5 - , base ^>=4.14.0 - , bytestring ^>=0.10.10 - , Cabal ^>=3.2.0 - , colourista ^>=0.1 - , conduit ^>=1.3.2 - , conduit-extra ^>=1.3.5 - , containers ^>=0.6.2 - , deepseq ^>=1.4.4 - , directory ^>=1.3.6 - , filepath ^>=1.4.2 - , hackage-db ^>=2.1.0 - , megaparsec ^>=8.0.0 - , microlens ^>=0.4.11 - , microlens-th ^>=0.4.3 - , neat-interpolation ^>=0.5.1 - , optparse-applicative ^>=0.16.0 + , aeson ^>=1.5.4 + , algebraic-graphs ^>=0.5 + , base ^>=4.14.0 + , bytestring ^>=0.10.10 + , Cabal ^>=3.2.0 + , conduit ^>=1.3.2 + , conduit-extra ^>=1.3.5 + , containers ^>=0.6.2 + , deepseq ^>=1.4.4 + , Diff ^>=0.4.0 + , directory ^>=1.3.6 + , filepath ^>=1.4.2 + , hackage-db ^>=2.1.0 + , megaparsec ^>=9.0.0 + , microlens ^>=0.4.11 + , microlens-th ^>=0.4.3 + , neat-interpolation ^>=0.5.1 + , optparse-applicative ^>=0.16.0 , polysemy - , req ^>=3.8.0 - , split ^>=0.2.3 - , tar-conduit ^>=0.3.2 - , template-haskell ^>=2.16.0 - , text ^>=1.2.3 + , prettyprinter + , prettyprinter-ansi-terminal + , req ^>=3.8.0 + , split ^>=0.2.3 + , tar-conduit ^>=0.3.2 + , template-haskell ^>=2.16.0 + , text ^>=1.2.3 ghc-options: -Wall -Wcompat -Widentities -Wincomplete-uni-patterns @@ -92,9 +94,10 @@ hs-source-dirs: src exposed-modules: Distribution.ArchHs.Aur - Distribution.ArchHs.Community + Distribution.ArchHs.CommunityDB Distribution.ArchHs.Core Distribution.ArchHs.Exception + Distribution.ArchHs.FilesDB Distribution.ArchHs.Hackage Distribution.ArchHs.Internal.Prelude Distribution.ArchHs.Local diff --git a/cbits/clib.c b/cbits/clib.c --- a/cbits/clib.c +++ b/cbits/clib.c @@ -1,7 +1,7 @@ #include "clib.h" #include #include -#include +#include #include void query_community(callback_t callback) { @@ -30,4 +30,35 @@ callback(name, ver); } 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; + + 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; + + callback(pkg_name, basename(path)); + } + } + alpm_release(handle); } diff --git a/cbits/clib.h b/cbits/clib.h --- a/cbits/clib.h +++ b/cbits/clib.h @@ -5,4 +5,6 @@ void query_community(callback_t callback); +void query_files(const char *dbname, callback_t callback); + #endif diff --git a/diff/Diff.hs b/diff/Diff.hs --- a/diff/Diff.hs +++ b/diff/Diff.hs @@ -9,16 +9,16 @@ ) where -import qualified Colourista as C +import Data.Algorithm.Diff import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) import qualified Data.Text as T -import Distribution.ArchHs.Community (versionInCommunity) +import Distribution.ArchHs.CommunityDB (versionInCommunity) import Distribution.ArchHs.Core (evalConditionTree) import Distribution.ArchHs.Exception import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.OptionReader -import Distribution.ArchHs.PP (prettyFlags) +import Distribution.ArchHs.PP import Distribution.ArchHs.Types import Distribution.ArchHs.Utils import Distribution.PackageDescription (CondTree, ConfVar) @@ -28,12 +28,16 @@ import Distribution.Utils.ShortText (fromShortText) import Network.HTTP.Req hiding (header) +#ifndef ALPM +import Distribution.ArchHs.CommunityDB (defaultCommunityDBPath) +#endif + data Options = Options { optFlags :: FlagAssignments, #ifdef ALPM - optAlpm :: Bool, + optAlpm :: Bool, #else - optCommunityPath :: FilePath, + optCommunityDBPath :: FilePath, #endif optPackageName :: PackageName, optVersionA :: Version, @@ -58,7 +62,7 @@ <> short 'c' <> help "Path to community.db" <> showDefault - <> value "/var/lib/pacman/sync/community.db" + <> value defaultCommunityDBPath ) #else <*> switch @@ -131,7 +135,7 @@ let urlPath = T.pack $ unPackageName name <> "-" <> prettyShow version api = https "hackage.haskell.org" /: "package" /: urlPath /: "revision" /: "0.cabal" r = req GET api NoReqBody bsResponse mempty - embed $ C.infoMessage $ "Downloading cabal file from " <> renderUrl api <> "..." + printInfo $ "Downloading cabal file from " <> renderUrl api <> "..." response <- interceptHttpException (runReq defaultHttpConfig r) case parseGenericPackageDescriptionMaybe $ responseBody response of Just x -> return x @@ -156,11 +160,12 @@ distinct = filter (notMyself . fst) . nub depends = distinct $ l <> e makedepends = distinct (lt <> et <> t <> tt) \\ depends - return (depends, makedepends) + sort' = sortBy (\x y -> uncurry compare $ getTwo _1 x y) + return (sort' depends, sort' makedepends) ----------------------------------------------------------------------------- -diffCabal :: Members [CommunityEnv, FlagAssignmentsEnv, WithMyErr, Trace, DependencyRecord, Embed IO] r => PackageName -> Version -> Version -> Sem r String +diffCabal :: Members [CommunityEnv, FlagAssignmentsEnv, WithMyErr, Trace, DependencyRecord, Embed IO] r => PackageName -> Version -> Version -> Sem r () diffCabal name a b = do ga <- getCabalFromHackage name a gb <- getCabalFromHackage name b @@ -172,39 +177,36 @@ (bb, mb) <- directDependencies gb queryb <- lookupDiffCommunity ba bb querym <- lookupDiffCommunity ma mb - return $ - unlines - [ C.formatWith [C.magenta] "Package: " <> unPackageName name, + embed . putDoc $ + vsep + [ annMagneta "Package" <> colon <+> viaPretty name, ver pa pb, desc pa pb, url pa pb, - dep "Depends: \n" ba bb, - "", + dep "Depends" ba bb, queryb, - dep "MakeDepends: \n" ma mb, - "", + dep "MakeDepends" ma mb, querym, flags name fa fb - ] + ] <> line -diffTerm :: String -> (a -> String) -> a -> a -> String +diffTerm :: String -> (a -> String) -> a -> a -> Doc AnsiStyle diffTerm s f a b = - let f' = T.unpack . T.strip . T.pack . f - (ra, rb) = (f' a, f' b) - in C.formatWith [C.magenta] s - <> (if ra == rb then ra else C.formatWith [C.red] ra <> " ⇒ " <> C.formatWith [C.green] rb) - -desc :: PackageDescription -> PackageDescription -> String -desc = diffTerm "Synopsis: " $ fromShortText . synopsis + let (ra, rb) = (f a, f b) + in annMagneta (pretty s) <> colon + <+> ( if ra == rb + then pretty ra + else ppFromTo 2 (annRed (pretty ra)) (annGreen (pretty rb)) + ) -ver :: PackageDescription -> PackageDescription -> String -ver = diffTerm "Version: " (prettyShow . getPkgVersion) +desc :: PackageDescription -> PackageDescription -> Doc AnsiStyle +desc = diffTerm "Synopsis" $ fromShortText . synopsis -url :: PackageDescription -> PackageDescription -> String -url = diffTerm "URL: " getUrl +ver :: PackageDescription -> PackageDescription -> Doc AnsiStyle +ver = diffTerm "Version" (prettyShow . getPkgVersion) -splitLine :: String -splitLine = "\n" <> replicate 38 '-' <> "\n" +url :: PackageDescription -> PackageDescription -> Doc AnsiStyle +url = diffTerm "URL" getUrl inRange :: Members [CommunityEnv, WithMyErr] r => (PackageName, VersionRange) -> Sem r (Either (PackageName, VersionRange) (PackageName, VersionRange, Version, Bool)) inRange (name, hRange) = @@ -213,65 +215,66 @@ Right y -> let version = fromJust . simpleParsec $ y in return . Right $ (name, hRange, version, withinRange version hRange) Left _ -> return . Left $ (name, hRange) -lookupDiffCommunity :: Members [CommunityEnv, WithMyErr] r => VersionedList -> VersionedList -> Sem r String +lookupDiffCommunity :: Members [CommunityEnv, WithMyErr] r => VersionedList -> VersionedList -> Sem r (Doc AnsiStyle) lookupDiffCommunity va vb = do - let diffNew = vb \\ va - diffOld = va \\ vb - color b = C.formatWith [if b then C.green else C.red] + let diff = getGroupedDiff va vb + diffOld = mconcat $ unDiff <$> filterFirstDiff diff + diffNew = mconcat $ unDiff <$> filterSecondDiff diff + annF b = if b then annGreen else annRed pp b (Right (name, range, v, False)) = - "\"" - <> color b (unPackageName name) - <> "\" is required to be in range (" - <> color b (prettyShow range) - <> "), " - <> "but [community] provides (" - <> color b (prettyShow v) - <> ")." + dquotes (annF b $ viaPretty name) + <+> "is required to be in range" + <+> parens (annF b $ viaPretty range) + <> comma + <+> "but" + <+> ppCommunity + <+> "provides" + <+> parens (annF b $ viaPretty v) + <> dot pp _ (Right _) = "" pp b (Left (name, range)) = - "\"" - <> color b (unPackageName name) - <> "\" is required to be in range (" - <> color b (prettyShow range) - <> "), " - <> "but [community] does not provide this package." + dquotes (annF b $ viaPretty name) + <+> "is required to be in range" + <+> parens (annF b $ viaPretty range) + <> comma + <+> "but" + <+> ppCommunity + <+> "does not provide this package" + <> comma new <- fmap (pp True) <$> mapM inRange diffNew old <- fmap (pp False) <$> mapM inRange diffOld - let join = unlines . filter (not . null) - return $ join old <> join new + return $ hsep [hsep old, hsep new] -dep :: String -> VersionedList -> VersionedList -> String +dep :: Doc AnsiStyle -> VersionedList -> VersionedList -> Doc AnsiStyle dep s va vb = - C.formatWith [C.magenta] s <> " " <> case diffOld <> diffNew of - [] -> joinToString a - _ -> - joinToString (fmap (\x -> red (x `elem` diffOld) x) a) - <> splitLine - <> " " - <> joinToString (fmap (\x -> green (x `elem` diffNew) x) b) + annMagneta s <> colon <> line + <> if noDiff diff + then joinToString [] + else + joinToString da + <> splitLine + <> joinToString db where a = joinVersionWithName <$> va b = joinVersionWithName <$> vb - diffNew = b \\ a - diffOld = a \\ b - joinToString [] = "[]" - joinToString xs = intercalate "\n " $ sort xs + da = mconcat $ ppDiffColored <$> filterFirstAndBothDiff diff + db = mconcat $ ppDiffColored <$> filterSecondAndBothDiff diff + diff = getGroupedDiff a b + joinToString [] = indent 2 "[]" + joinToString xs = indent 2 $ vsep xs joinVersionWithName (n, range) = unPackageName n <> " " <> prettyShow range - red p x = if p then C.formatWith [C.red] x else x - green p x = if p then C.formatWith [C.green] x else x -flags :: PackageName -> [Flag] -> [Flag] -> String +flags :: PackageName -> [Flag] -> [Flag] -> Doc AnsiStyle flags name a b = - C.formatWith [C.magenta] "Flags:\n" <> " " <> case diffOld <> diffNew of - [] -> joinToString a - _ -> - joinToString a - <> splitLine - <> " " - <> joinToString b + annMagneta "Flags" <> colon <> line + <> if noDiff diff + then joinToString a + else + joinToString a + <> splitLine + <> joinToString b where - diffNew = b \\ a - diffOld = a \\ b - joinToString [] = "[]" - joinToString xs = prettyFlags [(name, xs)] + diff = getGroupedDiff a b + joinToString [] = indent 2 "[]" + joinToString xs = indent 2 $ prettyFlags [(name, xs)] diff --git a/diff/Main.hs b/diff/Main.hs --- a/diff/Main.hs +++ b/diff/Main.hs @@ -4,15 +4,15 @@ module Main (main) where -import qualified Colourista as C import Control.Monad (unless) import qualified Data.Map as Map import qualified Data.Text as T +import Data.Text.Prettyprint.Doc.Render.Terminal import Diff -import Distribution.ArchHs.Community +import Distribution.ArchHs.CommunityDB import Distribution.ArchHs.Exception import Distribution.ArchHs.Internal.Prelude -import Distribution.ArchHs.PP (prettyFlagAssignments) +import Distribution.ArchHs.PP import Distribution.ArchHs.Types main :: IO () @@ -21,29 +21,21 @@ Options {..} <- runArgsParser let isFlagEmpty = Map.null optFlags -#ifndef ALPM - let useDefaultCommunity = "/var/lib/pacman/sync/community.db" == optCommunityPath - when useDefaultCommunity $ C.skipMessage "You didn't pass -c, use community db file from default path." -#endif - - when isFlagEmpty $ C.skipMessage "You didn't pass -f, different flag values may make difference in dependency resolving." unless isFlagEmpty $ do - C.infoMessage "You assigned flags:" - putStrLn . prettyFlagAssignments $ optFlags + printInfo "You assigned flags:" + putDoc $ prettyFlagAssignments optFlags <> line #ifdef ALPM - when optAlpm $ C.infoMessage "Using alpm." - community <- if optAlpm then loadCommunityFFI else loadProcessedCommunity defaultCommunityPath + let src = T.pack $ if optAlpm then "libalpm" else defaultCommunityDBPath + printInfo $ "Loading community.db from " <> src + community <- if optAlpm then loadCommunityDBFFI else loadCommunityDB defaultCommunityDBPath #else - community <- loadProcessedCommunity $ if useDefaultCommunity then defaultCommunityPath else optCommunityPath + printInfo $ "Loading community.db from " <> T.pack optCommunityDBPath + community <- loadCommunityDB optCommunityDBPath #endif - - C.infoMessage "Loading community.db..." - C.infoMessage "Start running..." - runDiff community optFlags (diffCabal optPackageName optVersionA optVersionB) >>= \case - Left x -> C.errorMessage $ "Runtime Error: " <> (T.pack . show $ x) - Right r -> putStrLn r >> C.successMessage "Success!" + printInfo "Start running..." + runDiff community optFlags (diffCabal optPackageName optVersionA optVersionB) & printAppResult runDiff :: CommunityDB -> FlagAssignments -> Sem '[CommunityEnv, FlagAssignmentsEnv, Trace, DependencyRecord, WithMyErr, Embed IO, Final IO] a -> IO (Either MyException a) runDiff community flags = runFinal . embedToFinal . errorToIOFinal . evalState Map.empty . ignoreTrace . runReader flags . runReader community diff --git a/src/Distribution/ArchHs/Aur.hs b/src/Distribution/ArchHs/Aur.hs --- a/src/Distribution/ArchHs/Aur.hs +++ b/src/Distribution/ArchHs/Aur.hs @@ -5,7 +5,7 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT --- Maintainer: berberman <1793913507@qq.com> +-- Maintainer: berberman -- Stability: experimental -- Portability: portable -- This module supports searching. @@ -109,7 +109,7 @@ makeSem_ ''Aur --- | Serach a package from AUR +-- | Search a package from AUR searchByName :: Member Aur r => String -> Sem r (Maybe AurSearch) -- | Get package info from AUR @@ -148,7 +148,7 @@ 1 -> Just . head $ r_results body _ -> Nothing (IsInAur name) -> do - result <- aurToIO . searchByName . unCommunityName . toCommunityName $ name + result <- aurToIO . searchByName . unArchLinuxName . toArchLinuxName $ name return $ case result of Just _ -> True _ -> False diff --git a/src/Distribution/ArchHs/Community.hs b/src/Distribution/ArchHs/Community.hs deleted file mode 100644 --- a/src/Distribution/ArchHs/Community.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - --- | Copyright: (c) 2020 berberman --- SPDX-License-Identifier: MIT --- Maintainer: berberman <1793913507@qq.com> --- Stability: experimental --- Portability: portable --- This module provides functions operating with @community.db@ of pacman. -module Distribution.ArchHs.Community - ( defaultCommunityPath, - loadProcessedCommunity, - isInCommunity, - versionInCommunity, - compiledWithAlpm, -#ifdef ALPM - loadCommunityFFI, -#endif - ) -where - -import Conduit -import qualified Data.Conduit.Tar as Tar -import qualified Data.Conduit.Zlib as Zlib -import qualified Data.Map.Strict as Map -import qualified Data.Text as T -import Distribution.ArchHs.Exception -import Distribution.ArchHs.Internal.Prelude -import Distribution.ArchHs.Name -import Distribution.ArchHs.PkgDesc -import Distribution.ArchHs.Types -import Distribution.ArchHs.Utils - ------------------------------------------------------------------------------ - -#ifdef ALPM -{-# LANGUAGE ForeignFunctionInterface #-} -import qualified Data.Sequence as Seq -import Data.Foldable (toList) -import Data.IORef (IORef, modifyIORef', newIORef, readIORef) -import Foreign.C.String (CString, peekCString) -import Foreign.Ptr (FunPtr, freeHaskellFunPtr) - -foreign import ccall "wrapper" - wrap :: (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ())) - -foreign import ccall "clib.h query_community" - query_community :: FunPtr (CString -> CString -> IO ()) -> IO () - -callback :: IORef (Seq.Seq (CommunityName, CommunityVersion)) -> CString -> CString -> IO () -callback ref x y = do - x' <- peekCString x - y' <- peekCString y - modifyIORef' ref (Seq.|> (CommunityName x', extractFromEVR y')) - --- | The same purpose as 'loadCommunity' but use alpm to query community db instead. -loadCommunityFFI :: IO CommunityDB -loadCommunityFFI = do - ref <- newIORef Seq.empty - callbackW <- wrap $ callback ref - query_community callbackW - freeHaskellFunPtr callbackW - Map.fromList . toList <$> readIORef ref -#endif - --- | Whether this program enables alpm support. -compiledWithAlpm :: Bool -compiledWithAlpm = -#ifdef ALPM - True -#else - False -#endif - ------------------------------------------------------------------------------ - --- | Default path to @community.db@. -defaultCommunityPath :: FilePath -defaultCommunityPath = "/" "var" "lib" "pacman" "sync" "community.db" - -loadCommunity :: - (MonadResource m, PrimMonad m, MonadThrow m) => - FilePath -> - ConduitT i (CommunityName, CommunityVersion) m () -loadCommunity path = do - sourceFileBS path .| Zlib.ungzip .| Tar.untarChunks .| Tar.withEntries action - where - action header = - when (Tar.headerFileType header == Tar.FTNormal) $ do - x <- mconcat <$> sinkList - let txt = T.unpack . decodeUtf8 $ x - result = - let provided r = r Map.! "PROVIDES" - parseProvidedTerm t = let s = splitOn "=" t in (s ^. ix 0, s ^. ix 1) - in 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 %~ CommunityName - --- | Load @community.db@ from @path@. --- @desc@ files in the db will be parsed by @descParser@. -loadProcessedCommunity :: (MonadUnliftIO m, PrimMonad m, MonadThrow m) => FilePath -> m CommunityDB -loadProcessedCommunity path = Map.fromList <$> runConduitRes (loadCommunity path .| sinkList) - ------------------------------------------------------------------------------ - --- | Check if a package exists in archlinux community repo. --- See 'HasMyName'. -isInCommunity :: (HasMyName n, Member CommunityEnv r) => n -> Sem r Bool -isInCommunity name = ask @CommunityDB >>= \db -> return $ toCommunityName name `Map.member` db - --- | 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 CommunityVersion -versionInCommunity name = - ask @CommunityDB >>= \db -> case db Map.!? toCommunityName name of - Just x -> return x - _ -> throw $ PkgNotFound name diff --git a/src/Distribution/ArchHs/CommunityDB.hs b/src/Distribution/ArchHs/CommunityDB.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/ArchHs/CommunityDB.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +-- | Copyright: (c) 2020 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman +-- Stability: experimental +-- Portability: portable +-- This module provides functions operating with @community.db@ of pacman. +module Distribution.ArchHs.CommunityDB + ( defaultCommunityDBPath, + loadCommunityDB, + isInCommunity, + versionInCommunity, +#ifdef ALPM + loadCommunityDBFFI, +#endif + ) +where + +import Conduit +import qualified Data.Conduit.Tar as Tar +import qualified Data.Conduit.Zlib as Zlib +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Distribution.ArchHs.Exception +import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.Name +import Distribution.ArchHs.PkgDesc +import Distribution.ArchHs.Types +import Distribution.ArchHs.Utils + +----------------------------------------------------------------------------- + +#ifdef ALPM +{-# LANGUAGE ForeignFunctionInterface #-} +import qualified Data.Sequence as Seq +import Data.Foldable (toList) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Foreign.C.String (CString, peekCString) +import Foreign.Ptr (FunPtr, freeHaskellFunPtr) + +foreign import ccall "wrapper" + wrap :: (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ())) + +foreign import ccall "clib.h query_community" + query_community :: FunPtr (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')) + +-- | 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 +#endif + +----------------------------------------------------------------------------- + +-- | Default path to @community.db@. +defaultCommunityDBPath :: FilePath +defaultCommunityDBPath = "/" "var" "lib" "pacman" "sync" "community.db" + +loadCommunityDBC :: + (MonadResource m, PrimMonad m, MonadThrow m) => + FilePath -> + ConduitT i (ArchLinuxName, ArchLinuxVersion) m () +loadCommunityDBC path = do + sourceFileBS path .| Zlib.ungzip .| Tar.untarChunks .| Tar.withEntries action + where + action header = + 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 + +-- | Load @community.db@ from @path@. +-- @desc@ files in the db will be parsed by @descParser@. +loadCommunityDB :: FilePath -> IO CommunityDB +loadCommunityDB path = Map.fromList <$> runConduitRes (loadCommunityDBC path .| sinkList) + +----------------------------------------------------------------------------- + +-- | Check if a package exists in archlinux community repo. +-- See 'HasMyName'. +isInCommunity :: (HasMyName n, Member CommunityEnv r) => n -> Sem r Bool +isInCommunity name = ask @CommunityDB >>= \db -> return $ toArchLinuxName name `Map.member` db + +-- | 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 = + ask @CommunityDB >>= \db -> case db Map.!? toArchLinuxName name of + Just x -> return x + _ -> throw $ PkgNotFound name 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 @@ -3,7 +3,7 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT --- Maintainer: berberman <1793913507@qq.com> +-- Maintainer: berberman -- Stability: experimental -- Portability: portable -- The core functions of @arch-hs@. @@ -16,6 +16,7 @@ import qualified Algebra.Graph.Labelled.AdjacencyMap as G import Data.Bifunctor (second) +import Data.Containers.ListUtils (nubOrd) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set @@ -93,7 +94,7 @@ Maybe PackageName -> -- | Target PackageName -> - Sem r (G.AdjacencyMap (Set DependencyType) PackageName, Set PackageName) + Sem r (G.AdjacencyMap (Set DependencyType) PackageName, Set PackageName, Map.Map PackageName [SystemDependency]) getDependencies skip parent name = do resolved <- get @(Set PackageName) modify' $ Set.insert name @@ -101,10 +102,11 @@ trace' $ "Already resolved: " <> show resolved traceCallStack cabal <- getLatestCabal name - (libDeps, libToolsDeps) <- collectLibDeps cabal - (subLibDeps, subLibToolsDeps) <- collectSubLibDeps cabal skip - (exeDeps, exeToolsDeps) <- collectExeDeps cabal skip - (testDeps, testToolsDeps) <- collectTestDeps cabal skip + (libDeps, libToolsDeps, libSysDeps) <- collectLibDeps cabal + (subLibDeps, subLibToolsDeps, subLibSysDeps) <- collectSubLibDeps cabal skip + (exeDeps, exeToolsDeps, exeSysDeps) <- collectExeDeps cabal skip + (testDeps, testToolsDeps, testSysDeps) <- collectTestDeps cabal skip + setupDeps <- collectSetupDeps cabal -- Ignore benchmarks -- (benchDeps, benchToolsDeps) <- collectBenchMarkDeps cabal skip let uname :: (UnqualComponentName -> DependencyType) -> ComponentPkgList -> [(DependencyType, PkgList)] @@ -128,13 +130,15 @@ filteredTestToolsDeps = ignoreFlatten CTest testToolsDeps filteredSubLibDeps = ignoreFlatten CSubLibs subLibDeps filteredSubLibToolsDeps = ignoreFlatten CSubLibsBuildTools subLibToolsDeps + filteredSetupDeps = ignore setupDeps filteredSubLibDepsNames = fmap (unqualComponentNameToPackageName . fst) subLibDeps ignoreSubLibs = filter (`notElem` filteredSubLibDepsNames) ignoreResolved = filter (`notElem` resolved) currentLib = G.edges $ zip3 (repeat $ Set.singleton CLib) (repeat name) filteredLibDeps - currentLibDeps = G.edges $ zip3 (repeat $ Set.singleton CLibBuildTools) (repeat name) filteredLibToolsDeps + currentLibToolDeps = G.edges $ zip3 (repeat $ Set.singleton CLibBuildTools) (repeat name) filteredLibToolsDeps + currentSetupDeps = G.edges $ zip3 (repeat $ Set.singleton CSetup) (repeat name) filteredSetupDeps componentialEdges = G.edges @@ -150,19 +154,24 @@ -- currentBench = componentialEdges Types.Benchmark benchDeps -- currentBenchTools = componentialEdges BenchmarkBuildTools benchToolsDeps + + currentSysDeps = nubOrd $ libSysDeps <> subLibSysDeps <> exeSysDeps <> testSysDeps processNext = mapM (getDependencies skip (Just name)) . ignoreResolved . ignoreSubLibs (<+>) = G.overlay nextLib <- processNext filteredLibDeps + nextSetup <- processNext filteredSetupDeps nextExe <- processNext $ fmap snd filteredExeDeps -- TODO: maybe unstable nextTest <- processNext $ fmap snd filteredTestDeps nextSubLibs <- mapM (getDependencies skip (Just name)) $ fmap snd filteredSubLibDeps - let temp = [nextLib, nextExe, nextTest, nextSubLibs] + let temp = [nextLib, nextSetup, nextExe, nextTest, nextSubLibs] nexts = G.overlays $ temp ^. each ^.. each . _1 subsubs = temp ^. each ^.. each . _2 ^. each + nextSys = temp ^. each ^.. each . _3 ^. each return ( currentLib - <+> currentLibDeps + <+> currentLibToolDeps + <+> currentSetupDeps <+> currentExe <+> currentExeTools <+> currentTest @@ -172,10 +181,11 @@ -- <+> currentBench -- <+> currentBenchTools <+> nexts, - Set.fromList filteredSubLibDepsNames <> subsubs + Set.fromList filteredSubLibDepsNames <> subsubs, + (if null currentSysDeps then Map.empty else Map.singleton name currentSysDeps) <> nextSys ) -collectLibDeps :: Members [FlagAssignmentsEnv, DependencyRecord, Trace] r => GenericPackageDescription -> Sem r (PkgList, PkgList) +collectLibDeps :: Members [FlagAssignmentsEnv, DependencyRecord, Trace] r => GenericPackageDescription -> Sem r (PkgList, PkgList, [SystemDependency]) collectLibDeps cabal = do case cabal & condLibrary of Just lib -> do @@ -184,13 +194,14 @@ info <- evalConditionTree cabal lib let libDeps = unDepV <$> buildDependsIfBuild info toolDeps = unBuildTools $ buildToolsAndbuildToolDependsIfBuild info + systemDeps = unSystemDependency $ pkgconfigDependsAndExtraLibsIfBuild info mapM_ (uncurry updateDependencyRecord) libDeps mapM_ (uncurry updateDependencyRecord) toolDeps - let result = (fmap fst libDeps, fmap fst toolDeps) + let result = (fmap fst libDeps, fmap fst toolDeps, systemDeps) trace' $ "Found: " <> show result traceCallStack return result - Nothing -> return ([], []) + Nothing -> return ([], [], []) collectComponentialDeps :: (HasCallStack, Semigroup k, L.HasBuildInfo k, Members [FlagAssignmentsEnv, DependencyRecord, Trace] r) => @@ -198,7 +209,7 @@ (GenericPackageDescription -> [(UnqualComponentName, CondTree ConfVar [Dependency] k)]) -> GenericPackageDescription -> [UnqualComponentName] -> - Sem r (ComponentPkgList, ComponentPkgList) + Sem r (ComponentPkgList, ComponentPkgList, [SystemDependency]) collectComponentialDeps tag f cabal skip = do let conds = cabal & f name = getPkgName' cabal @@ -206,23 +217,35 @@ info <- filter (not . (`elem` skip) . fst) . zip (conds <&> fst) <$> mapM (evalConditionTree cabal . snd) conds let deps = info <&> _2 %~ (fmap unDepV . buildDependsIfBuild) toolDeps = info <&> _2 %~ (unBuildTools . buildToolsAndbuildToolDependsIfBuild) + sysDeps = info <&> _2 %~ (unSystemDependency . pkgconfigDependsAndExtraLibsIfBuild) k = fmap (second $ fmap fst) mapM_ (uncurry updateDependencyRecord) $ deps ^.. each . _2 ^. each mapM_ (uncurry updateDependencyRecord) $ toolDeps ^.. each . _2 ^. each - let result = (k deps, k toolDeps) + let result = (k deps, k toolDeps, mconcat $ fmap snd sysDeps) trace' $ "Found: " <> show result traceCallStack return result -collectExeDeps :: (HasCallStack, Members [FlagAssignmentsEnv, DependencyRecord, Trace] r) => GenericPackageDescription -> [UnqualComponentName] -> Sem r (ComponentPkgList, ComponentPkgList) +collectExeDeps :: (HasCallStack, Members [FlagAssignmentsEnv, DependencyRecord, Trace] r) => GenericPackageDescription -> [UnqualComponentName] -> Sem r (ComponentPkgList, ComponentPkgList, [SystemDependency]) collectExeDeps = collectComponentialDeps "exe" condExecutables -collectTestDeps :: (HasCallStack, Members [FlagAssignmentsEnv, DependencyRecord, Trace] r) => GenericPackageDescription -> [UnqualComponentName] -> Sem r (ComponentPkgList, ComponentPkgList) +collectTestDeps :: (HasCallStack, Members [FlagAssignmentsEnv, DependencyRecord, Trace] r) => GenericPackageDescription -> [UnqualComponentName] -> Sem r (ComponentPkgList, ComponentPkgList, [SystemDependency]) collectTestDeps = collectComponentialDeps "test" condTestSuites -collectSubLibDeps :: (HasCallStack, Members [FlagAssignmentsEnv, DependencyRecord, Trace] r) => GenericPackageDescription -> [UnqualComponentName] -> Sem r (ComponentPkgList, ComponentPkgList) +collectSubLibDeps :: (HasCallStack, Members [FlagAssignmentsEnv, DependencyRecord, Trace] r) => GenericPackageDescription -> [UnqualComponentName] -> Sem r (ComponentPkgList, ComponentPkgList, [SystemDependency]) collectSubLibDeps = collectComponentialDeps "sublib" condSubLibraries +collectSetupDeps :: Member Trace r => GenericPackageDescription -> Sem r PkgList +collectSetupDeps cabal = do + let name = getPkgName' cabal + trace' $ "Getting setup dependencies of " <> show name + case setupBuildInfo $ packageDescription cabal of + Just (SetupBuildInfo deps _) -> do + let result = fst . unDepV <$> deps + trace' $ "Found: " <> show result + return result + _ -> return [] + updateDependencyRecord :: Member DependencyRecord r => PackageName -> VersionRange -> Sem r () updateDependencyRecord name range = modify' $ Map.insertWith (<>) name [range] @@ -232,13 +255,13 @@ ----------------------------------------------------------------------------- -- | Generate 'PkgBuild' for a 'SolvedPackage'. -cabalToPkgBuild :: Members [HackageEnv, FlagAssignmentsEnv, WithMyErr] r => SolvedPackage -> Bool -> Sem r PkgBuild -cabalToPkgBuild pkg uusi = do +cabalToPkgBuild :: Members [HackageEnv, FlagAssignmentsEnv, WithMyErr] r => SolvedPackage -> Bool -> [ArchLinuxName] -> Sem r PkgBuild +cabalToPkgBuild pkg uusi sysDeps = do let name = pkg ^. pkgName cabal <- packageDescription <$> getLatestCabal name _sha256sums <- (\case Just s -> "'" <> s <> "'"; Nothing -> "'SKIP'") <$> tryMaybe (getLatestSHA256 name) let _hkgName = pkg ^. pkgName & unPackageName - _pkgName = unCommunityName . toCommunityName $ pkg ^. pkgName + _pkgName = unArchLinuxName . toArchLinuxName $ pkg ^. pkgName _pkgVer = prettyShow $ getPkgVersion cabal _pkgDesc = fromShortText $ synopsis cabal getL NONE = "" @@ -276,11 +299,12 @@ || depIsKind Test x || depIsKind TestBuildTools x || depIsKind SubLibsBuildTools x + || depIsKind Setup x ) ) - depsToString deps = deps <&> (wrap . unCommunityName . toCommunityName . _depName) & mconcat - _depends = depsToString depends - _makeDepends = (if uusi then " 'uusi'" else "") <> depsToString makeDepends + depsToString k deps = deps <&> (wrap . unArchLinuxName . toArchLinuxName . k) & mconcat + _depends = depsToString _depName depends <> depsToString id sysDeps + _makeDepends = (if uusi then " 'uusi'" else "") <> depsToString _depName makeDepends _url = getUrl cabal wrap s = " '" <> s <> "'" _licenseFile = licenseFiles cabal ^? ix 0 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 @@ -5,7 +5,7 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT --- Maintainer: berberman <1793913507@qq.com> +-- Maintainer: berberman -- Stability: experimental -- Portability: portable -- Exceptions used in this project. @@ -19,11 +19,11 @@ ) where -import qualified Colourista as C import qualified Control.Exception as CE import qualified Data.Text as T import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Name +import Distribution.ArchHs.PP (printError, printSuccess) import Distribution.ArchHs.Types import Network.HTTP.Req (HttpException (..)) @@ -46,18 +46,18 @@ show (CyclicExist c) = "Graph contains a cycle \"" <> show (fmap unPackageName c) <> "\"" show (NetworkException (JsonHttpException s)) = "Failed to parse response " <> s show (NetworkException (VanillaHttpException e)) = show e - show (TargetDisappearException name)= "Target \"" <> unPackageName name <> "\" is discarded during the dependency resolving" + show (TargetDisappearException name) = "Target \"" <> unPackageName name <> "\" is discarded during the dependency resolving" -- | Catch 'CE.IOException' and print it. printHandledIOException :: IO () -> IO () -printHandledIOException = CE.handle @CE.IOException (\e -> C.errorMessage $ "IOException: " <> (T.pack . show $ e)) +printHandledIOException = CE.handle @CE.IOException (\e -> printError $ "IOException: " <> (T.pack . show $ e)) -- | Print the result of 'errorToIOFinal'. printAppResult :: IO (Either MyException ()) -> IO () printAppResult io = io >>= \case - Left x -> C.errorMessage $ "Runtime Exception: " <> (T.pack . show $ x) - _ -> C.successMessage "Success!" + Left x -> printError $ "Runtime Exception: " <> (T.pack . show $ x) + _ -> printSuccess "Success!" -- | Catch the 'HttpException' thrown in 'IO' monad, then re-throw it with 'NetworkException'. interceptHttpException :: Members [WithMyErr, Embed IO] r => IO a -> Sem r a diff --git a/src/Distribution/ArchHs/FilesDB.hs b/src/Distribution/ArchHs/FilesDB.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/ArchHs/FilesDB.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +-- | Copyright: (c) 2020 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman +-- Stability: experimental +-- Portability: portable +-- This module provides functions operating with 'FilesDB' of pacman. +module Distribution.ArchHs.FilesDB + ( defaultFilesDBDir, + loadFilesDB, +#ifdef ALPM + loadFilesDBFFI, +#endif + lookupPkg, + DBKind (..), + File, + FilesDB, + ) +where + +import Conduit +import qualified Data.Conduit.Tar as Tar +import qualified Data.Conduit.Zlib as Zlib +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.PkgDesc (runDescFieldsParser) +import Distribution.ArchHs.Types + +#ifdef ALPM +{-# LANGUAGE ForeignFunctionInterface #-} +import qualified Data.Sequence as Seq +import Data.Foldable (toList) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Foreign.C.String (newCString, CString, peekCString) +import Foreign.Ptr (FunPtr, freeHaskellFunPtr) + +foreign import ccall "wrapper" + wrap :: (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ())) + +foreign import ccall "clib.h query_files" + query_files :: CString -> FunPtr (CString -> CString -> IO ()) -> IO () + +callback :: IORef (Seq.Seq (ArchLinuxName, FilePath)) -> CString -> CString -> IO () +callback ref x y = do + x' <- peekCString x + y' <- peekCString y + modifyIORef' ref (Seq.|> (ArchLinuxName x', y')) + +-- | The same purpose as 'loadFilesDB' but use alpm to query files db instead. +loadFilesDBFFI :: DBKind -> IO FilesDB +loadFilesDBFFI (show -> db) = do + ref <- newIORef Seq.empty + db' <- newCString db + callbackW <- wrap $ callback ref + query_files db' callbackW + freeHaskellFunPtr callbackW + list <- toList <$> readIORef ref + return $ foldr (\(k,v)-> Map.insertWith (<>) k [v]) Map.empty list +#endif + +-- | Default directory containing files dbs (@/var/lib/pacman/sync@). +defaultFilesDBDir :: FilePath +defaultFilesDBDir = "/" "var" "lib" "pacman" "sync" + +loadFilesDBC :: + (MonadResource m, PrimMonad m, MonadThrow m) => + DBKind -> + FilePath -> + ConduitT i Result m () +loadFilesDBC db dir = do + sourceFileBS (dir show db <> ".files") .| Zlib.ungzip .| Tar.untarChunks .| Tar.withEntries action + where + action header + | Tar.FTNormal <- Tar.headerFileType header, + [fp, t] <- splitOn "/" $ Tar.headerFilePath header = + do + x <- mconcat <$> sinkList + let txt = decodeUtf8 x + case t of + "files" -> yield . Files fp $ [T.unpack fname | (extract -> Just fname) <- tail $ T.lines txt] + "desc" -> case runDescFieldsParser fp (T.unpack txt) of + Right r | [name] <- r Map.! "NAME" -> yield . Desc fp $ ArchLinuxName name + _ -> return () + _ -> return () + | otherwise = return () + extract :: T.Text -> Maybe T.Text + extract s + | Just x <- T.stripPrefix "usr/lib/" s, + T.isSuffixOf ".so" x || T.isSuffixOf ".pc" x = + Just $ T.takeWhileEnd (/= '/') x + | otherwise = Nothing + +mergeResult :: Monad m => ConduitT Result (ArchLinuxName, [File]) m () +mergeResult = do + rName <- await + rFiles <- await + case () of + () + | Just (Desc fpd name) <- rName, + Just (Files fpf files) <- rFiles, + fpd == fpf -> + when (files /= []) (yield (name, files)) >> mergeResult + _ -> return () + +-- | Load a @db@ from @dir@ +loadFilesDB :: DBKind -> FilePath -> IO FilesDB +loadFilesDB db dir = Map.fromList <$> runConduitRes (loadFilesDBC db dir .| mergeResult .| sinkList) + +-- | Lookup which Arch Linux package contains this @file@ from given files db. +-- This query is bad in performance, since it traverses the entire db. +lookupPkg :: File -> FilesDB -> [ArchLinuxName] +lookupPkg file = Map.foldrWithKey (\k v acc -> if file `elem` v then k : acc else acc) [] + +data Result = Files FilePath [File] | Desc FilePath ArchLinuxName + deriving stock (Show) + +-- | Three files repos: @core@, @community@, and @extra@ +data DBKind = Core | Community | Extra + +instance Show DBKind where + show Core = "core" + show Community = "community" + show Extra = "extra" + +-- | A file's name +type File = String + +-- | Representation of @repo.db@. +type FilesDB = Map.Map ArchLinuxName [File] diff --git a/src/Distribution/ArchHs/Hackage.hs b/src/Distribution/ArchHs/Hackage.hs --- a/src/Distribution/ArchHs/Hackage.hs +++ b/src/Distribution/ArchHs/Hackage.hs @@ -2,7 +2,7 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT --- Maintainer: berberman <1793913507@qq.com> +-- Maintainer: berberman -- Stability: experimental -- Portability: portable -- This module provides functions operating with 'HackageDB' and 'GenericPackageDescription'. diff --git a/src/Distribution/ArchHs/Internal/Prelude.hs b/src/Distribution/ArchHs/Internal/Prelude.hs --- a/src/Distribution/ArchHs/Internal/Prelude.hs +++ b/src/Distribution/ArchHs/Internal/Prelude.hs @@ -1,6 +1,6 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT --- Maintainer: berberman <1793913507@qq.com> +-- Maintainer: berberman -- Stability: experimental -- Portability: portable -- A re-export list. 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 @@ -1,6 +1,6 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT --- Maintainer: berberman <1793913507@qq.com> +-- Maintainer: berberman -- Stability: experimental -- Portability: portable -- This module maintains names of packages which are need special treatments during dependency resolving or PKGBUILD generating. @@ -28,7 +28,6 @@ "integer", "unsupported-ghc-version", "base", - "ghc", "ghc-prim", "ghc-bignum", "hans", diff --git a/src/Distribution/ArchHs/Name.hs b/src/Distribution/ArchHs/Name.hs --- a/src/Distribution/ArchHs/Name.hs +++ b/src/Distribution/ArchHs/Name.hs @@ -7,7 +7,7 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT --- Maintainer: berberman <1793913507@qq.com> +-- Maintainer: berberman -- Stability: experimental -- Portability: portable -- @@ -27,12 +27,12 @@ -- -- @NAME_PRESET.json@ will be loaded during the compilation, generating haskell code to be called in runtime. -- --- Converting a community name to hackage name following these steps: +-- Converting a archlinux community name to hackage name following these steps: -- -- (1) Find if the name preset contains this rule -- (2) If it contains, then use it; or remove the @haskell-@ prefix -- --- Converting a hackage name to community name following these steps: +-- Converting a hackage name to archlinux community name following these steps: -- -- (1) Find if the name preset contains this rule -- (2) If it contains, then use it; or add the @haskell-@ prefix @@ -40,12 +40,9 @@ -- For details, see the type 'MyName' and type class 'HasMyName' with its instances. module Distribution.ArchHs.Name ( MyName, - unMyName, - HasMyName (..), + HasMyName, NameRep (..), - mToCommunityName, - mToHackageName, - toCommunityName, + toArchLinuxName, toHackageName, isHaskellPackage, ) @@ -60,7 +57,7 @@ -- | The representation of a package name. data NameRep = -- | archlinx community style - CommunityRep + ArchLinuxRep | -- | hackage style HackageRep @@ -69,35 +66,35 @@ -- | Convert a name from community representation to hackage representation, according to the name preset. -- If the preset doesn't contain this mapping rule, the function will return 'Nothing'. -- This function is generated from @NAME_PRESET.json@ -communityToHackageP :: MyName 'CommunityRep -> Maybe (MyName 'HackageRep) +communityToHackageP :: MyName 'ArchLinuxRep -> Maybe (MyName 'HackageRep) --- | Convert a name from hackage representation to community representation, according to the name preset. +-- | Convert a name from hackage representation to archlinux community representation, according to the name preset. -- If the preset doesn't contain this mapping rule, the function will return 'Nothing'. -- -- This function is generated from @NAME_PRESET.json@ -hackageToCommunityP :: MyName 'HackageRep -> Maybe (MyName 'CommunityRep) +hackageToCommunityP :: MyName 'HackageRep -> Maybe (MyName 'ArchLinuxRep) --- | Special haskell packages in community reop, which should be ignored in the process. +-- | Special haskell packages in community repo, which should be ignored in the process. -- -- This function is generated from @NAME_PRESET.json@ -falseListP :: [MyName 'CommunityRep] +falseListP :: [MyName 'ArchLinuxRep] -- | Community haskell packages of in the name preset. -- -- This function is generated from @NAME_PRESET.json@ -communityListP :: [MyName 'CommunityRep] +communityListP :: [MyName 'ArchLinuxRep] -- | A general package name representation. -- It has a phantom @a@, which indexes this name. -- Normally, the index should be the data kinds of 'NameRep'. -- -- In Cabal API, packages' names are represented by the type 'PackageName'; --- in arch-hs, names parsed from @community.db@ are represented by the type 'CommunityName'. +-- in arch-hs, names parsed from @community.db@ are represented by the type 'ArchLinuxName'. -- It would be tedious to use two converting functions everywhere, so here comes a intermediate data type -- to unify them, with type level constraints as bonus. newtype MyName a = MyName { -- | Unwrap the value. - unMyName :: String + unsafeUnMyName :: String } deriving stock (Show, Read, Eq, Ord, Generic) deriving anyclass (NFData) @@ -112,19 +109,19 @@ toHackageRep :: a -> MyName 'HackageRep -- | To 'MyName' in community style. - toCommunityRep :: a -> MyName 'CommunityRep + toArchLinuxRep :: a -> MyName 'ArchLinuxRep -instance HasMyName (MyName 'CommunityRep) where - toHackageRep = toHackageRep . CommunityName . unMyName - toCommunityRep = id +instance HasMyName (MyName 'ArchLinuxRep) where + toHackageRep = toHackageRep . ArchLinuxName . unsafeUnMyName + toArchLinuxRep = id instance HasMyName (MyName 'HackageRep) where toHackageRep = id - toCommunityRep = toCommunityRep . mkPackageName . unMyName + toArchLinuxRep = toArchLinuxRep . mkPackageName . unsafeUnMyName instance HasMyName PackageName where toHackageRep = MyName . unPackageName - toCommunityRep = go . unPackageName + toArchLinuxRep = go . unPackageName where go s = case hackageToCommunityP (MyName s) of Just x -> x @@ -135,25 +132,25 @@ else "haskell-" <> s ) -instance HasMyName CommunityName where - toHackageRep = go . unCommunityName +instance HasMyName ArchLinuxName where + toHackageRep = go . unArchLinuxName where go s = case communityToHackageP (MyName s) of Just x -> x _ -> MyName $ drop 8 s - toCommunityRep = MyName . unCommunityName + toArchLinuxRep = MyName . unArchLinuxName --- | Back to 'CommunityName'. -mToCommunityName :: MyName 'CommunityRep -> CommunityName -mToCommunityName = CommunityName . unMyName +-- | Back to 'ArchLinuxName'. +mToArchLinuxName :: MyName 'ArchLinuxRep -> ArchLinuxName +mToArchLinuxName = ArchLinuxName . unsafeUnMyName -- | Back to 'PackageName'. mToHackageName :: MyName 'HackageRep -> PackageName -mToHackageName = mkPackageName . unMyName +mToHackageName = mkPackageName . unsafeUnMyName --- | Convert @n@ to 'CommunityName'. -toCommunityName :: HasMyName n => n -> CommunityName -toCommunityName = mToCommunityName . toCommunityRep +-- | Convert @n@ to 'ArchLinuxName'. +toArchLinuxName :: HasMyName n => n -> ArchLinuxName +toArchLinuxName = mToArchLinuxName . toArchLinuxRep -- | Convert @n@ to 'PackageName'. toHackageName :: HasMyName n => n -> PackageName @@ -162,7 +159,7 @@ -- | Judge if a package in archlinux community repo is haskell package. -- -- i.e. it is in @preset@ or have @haskell-@ prefix, and is not present in @falseList@ of @NAME_PRESET.json@. -isHaskellPackage :: CommunityName -> Bool +isHaskellPackage :: ArchLinuxName -> Bool isHaskellPackage name = - let rep = toCommunityRep name - in (rep `elem` communityListP || "haskell-" `isPrefixOf` unMyName rep) && rep `notElem` falseListP + let rep = toArchLinuxRep name + in (rep `elem` communityListP || "haskell-" `isPrefixOf` unsafeUnMyName rep) && rep `notElem` falseListP diff --git a/src/Distribution/ArchHs/OptionReader.hs b/src/Distribution/ArchHs/OptionReader.hs --- a/src/Distribution/ArchHs/OptionReader.hs +++ b/src/Distribution/ArchHs/OptionReader.hs @@ -2,7 +2,7 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT --- Maintainer: berberman <1793913507@qq.com> +-- Maintainer: berberman -- Stability: experimental -- Portability: portable -- This module defines input patterns used in executables' cli. diff --git a/src/Distribution/ArchHs/PP.hs b/src/Distribution/ArchHs/PP.hs --- a/src/Distribution/ArchHs/PP.hs +++ b/src/Distribution/ArchHs/PP.hs @@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT --- Maintainer: berberman <1793913507@qq.com> +-- Maintainer: berberman -- Stability: experimental -- Portability: portable -- This module provides simple pretty-printing functions work with the cli program. @@ -13,63 +14,162 @@ prettyFlags, prettySolvedPkgs, prettyDeps, + ppSysDependencies, + ppDiffColored, + align2col, + dui, + cuo, + ppCommunity, + annYellow, + annGreen, + annMagneta, + annRed, + annBold, + annCyan, + annBlue, + render, + viaPretty, + splitLine, + ppFromTo, + printInfo, + printWarn, + printError, + printSuccess, + module Prettyprinter, + module Prettyprinter.Render.Terminal, ) where -import qualified Colourista as C +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Algorithm.Diff import qualified Data.Map.Strict as Map import qualified Data.Text as T import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Types +import qualified Distribution.Pretty as DPretty +import Prettyprinter +import Prettyprinter.Render.Terminal -prettySkip :: [String] -> String -prettySkip = C.formatWith [C.magenta] . intercalate ", " +annYellow :: Doc AnsiStyle -> Doc AnsiStyle +annYellow = annotate (color Yellow) -prettyFlagAssignments :: Map.Map PackageName FlagAssignment -> String +annCyan :: Doc AnsiStyle -> Doc AnsiStyle +annCyan = annotate (color Cyan) + +annMagneta :: Doc AnsiStyle -> Doc AnsiStyle +annMagneta = annotate (color Magenta) + +annRed :: Doc AnsiStyle -> Doc AnsiStyle +annRed = annotate (color Red) + +annGreen :: Doc AnsiStyle -> Doc AnsiStyle +annGreen = annotate (color Green) + +annBold :: Doc AnsiStyle -> Doc AnsiStyle +annBold = annotate bold + +annBlue :: Doc AnsiStyle -> Doc AnsiStyle +annBlue = annotate (color Blue) + +cuo :: Doc AnsiStyle +cuo = annRed "✘" + +dui :: Doc AnsiStyle +dui = annGreen "✔" + +prettySkip :: [String] -> Doc AnsiStyle +prettySkip = hsep . punctuate comma . fmap (annotate (color Magenta) . pretty) + +prettyFlagAssignments :: Map.Map PackageName FlagAssignment -> Doc AnsiStyle prettyFlagAssignments m = - mconcat $ - fmap (fmap (\(n, a) -> C.formatWith [C.magenta] (unPackageName n) <> "\n" <> prettyFlagAssignment a)) Map.toList m + vsep $ + fmap (fmap (\(n, a) -> annMagneta (viaPretty n) <> line <> indent 2 (prettyFlagAssignment a))) Map.toList m -prettyFlagAssignment :: FlagAssignment -> String -prettyFlagAssignment m = - mconcat $ - (\(n, v) -> " ⚐ " <> C.formatWith [C.yellow] (unFlagName n) <> " : " <> C.formatWith [C.cyan] (show v) <> "\n") <$> unFlagAssignment m +prettyFlagAssignment :: FlagAssignment -> Doc AnsiStyle +prettyFlagAssignment = vsep . fmap (\(n, v) -> "⚐" <+> annotate (color Yellow) (viaPretty n) <> colon <+> annotate (color Cyan) (pretty v)) . unFlagAssignment -prettyDeps :: [PackageName] -> String +prettyDeps :: [PackageName] -> Doc AnsiStyle prettyDeps = - mconcat - . fmap (\(i, n) -> show (i :: Int) <> ". " <> unPackageName n <> "\n") + vsep + . fmap (\(i :: Int, n) -> pretty i <> dot <+> viaPretty n) . zip [1 ..] -prettyFlags :: [(PackageName, [Flag])] -> String -prettyFlags = mconcat . fmap (\(name, flags) -> C.formatWith [C.magenta] (unPackageName name <> "\n") <> mconcat (C.formatWith [C.indent 4] . prettyFlag <$> flags)) +prettyFlags :: [(PackageName, [Flag])] -> Doc AnsiStyle +prettyFlags = vsep . fmap (\(name, flags) -> annMagneta (viaPretty name) <> line <> indent 2 (vsep (prettyFlag <$> flags))) -prettyFlag :: Flag -> String -prettyFlag f = "⚐ " <> C.formatWith [C.yellow] name <> ":\n" <> mconcat (C.formatWith [C.indent 6] <$> ["description:\n" <> desc, "default: " <> def <> "\n", "isManual: " <> manual <> "\n"]) +prettyFlag :: Flag -> Doc AnsiStyle +prettyFlag f = + "⚐" <+> annYellow name <> colon <> line + <> indent + 4 + ( vsep + [ "description" <> colon <> line <> indent 2 desc, + "default" <> colon <+> def, + "isManual" <> colon <+> manual + ] + ) where - name = unFlagName . flagName $ f - desc = unlines . fmap (C.formatWith [C.indent 8]) . lines $ flagDescription f - def = show $ flagDefault f - manual = show $ flagManual f + name = viaPretty . flagName $ f + desc = pretty $ flagDescription f + def = viaShow $ flagDefault f + manual = viaShow $ flagManual f -prettySolvedPkgs :: [SolvedPackage] -> String -prettySolvedPkgs = con . mconcat . fmap prettySolvedPkg +prettySolvedPkgs :: [SolvedPackage] -> T.Text +prettySolvedPkgs = align2col . mconcat . fmap prettySolvedPkg -prettySolvedPkg :: SolvedPackage -> [(String, String)] +prettySolvedPkg :: SolvedPackage -> [(Doc AnsiStyle, Doc AnsiStyle)] prettySolvedPkg SolvedPackage {..} = - (C.formatWith [C.bold, C.yellow] (unPackageName _pkgName), C.formatWith [C.red] " ✘") : + (annYellow . annBold . viaPretty $ _pkgName, indent 16 cuo) : fmap ( \(i :: Int, SolvedDependency {..}) -> let prefix = if i == length _pkgDeps then " └─" else " ├─" in case _depProvider of - (Just x) -> (C.formatWith [C.green] $ T.unpack prefix <> unPackageName _depName <> " " <> show _depType, C.formatWith [C.green] "✔ " <> C.formatWith [C.cyan] (show x)) - _ -> (C.formatWith [C.bold, C.yellow] $ T.unpack prefix <> unPackageName _depName <> " " <> show _depType, C.formatWith [C.red] " ✘") + (Just x) -> (annGreen $ prefix <> viaPretty _depName <+> viaShow _depType, dui <+> annCyan (viaShow x)) + _ -> (annYellow . annBold $ prefix <> viaPretty _depName <+> viaShow _depType, indent 16 cuo) ) (zip [1 ..] _pkgDeps) -prettySolvedPkg ProvidedPackage {..} = [(C.formatWith [C.green] (unPackageName _pkgName), C.formatWith [C.green] "✔ " <> C.formatWith [C.cyan] (show _pkgProvider))] +prettySolvedPkg ProvidedPackage {..} = [(annGreen $ viaPretty _pkgName, dui <+> annCyan (viaShow _pkgProvider))] -con :: [(String, String)] -> String -con l = mconcat complemented +render :: Doc AnsiStyle -> T.Text +render = renderStrict . layoutPretty defaultLayoutOptions + +viaPretty :: DPretty.Pretty a => a -> Doc AnsiStyle +viaPretty = pretty . prettyShow + +align2col :: [(Doc AnsiStyle, Doc AnsiStyle)] -> T.Text +align2col (fmap (both %~ render) -> l) = T.concat complemented where - maxL = maximum $ fmap (length . fst) l - complemented = (\(x, y) -> x <> replicate (maxL - length x) ' ' <> y <> "\n") <$> l + maxL = maximum $ fmap (T.length . fst) l + complemented = (\(x, y) -> x <> T.replicate (maxL - T.length x) " " <> y <> "\n") <$> l + +ppSysDependencies :: Map.Map PackageName [SystemDependency] -> T.Text +ppSysDependencies m = align2col $ uncurry ppSysDependency <$> Map.toList m + +ppSysDependency :: PackageName -> [SystemDependency] -> (Doc AnsiStyle, Doc AnsiStyle) +ppSysDependency name deps = ((annBold . annYellow $ viaPretty name) <> colon, hsep $ punctuate comma (fmap (\(SystemDependency x) -> pretty x) deps)) + +ppDiffColored :: Diff [String] -> [Doc AnsiStyle] +ppDiffColored (First x) = annRed . pretty <$> x +ppDiffColored (Second x) = annGreen . pretty <$> x +ppDiffColored (Both x _) = pretty <$> x + +splitLine :: Doc AnsiStyle +splitLine = line <> pretty (replicate 38 '-') <> line + +ppFromTo :: Int -> Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle +ppFromTo i a b = a <> hcat (replicate i space) <> "⇒" <> hcat (replicate i space) <> b + +printInfo :: (MonadIO m) => T.Text -> m () +printInfo msg = liftIO . putDoc . annBlue $ "ⓘ" <+> pretty msg <> line + +ppCommunity :: Doc AnsiStyle +ppCommunity = annCyan $ viaShow ByCommunity + +printWarn :: (MonadIO m) => T.Text -> m () +printWarn msg = liftIO . putDoc . annYellow $ "⚠" <+> pretty msg <> line + +printError :: (MonadIO m) => T.Text -> m () +printError msg = liftIO . putDoc . annYellow $ "🛑" <+> pretty msg <> line + +printSuccess :: (MonadIO m) => T.Text -> m () +printSuccess msg = liftIO . putDoc . annGreen $ dui <+> pretty msg <> line 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 @@ -4,7 +4,7 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT --- Maintainer: berberman <1793913507@qq.com> +-- Maintainer: berberman -- Stability: experimental -- Portability: portable -- Template of PKGBUILD file. 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 @@ -5,7 +5,7 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT --- Maintainer: berberman <1793913507@qq.com> +-- Maintainer: berberman -- Stability: experimental -- Portability: portable -- This module provides parser of @desc@ file in pacman db. 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 @@ -8,15 +8,16 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT --- Maintainer: berberman <1793913507@qq.com> +-- Maintainer: berberman -- Stability: experimental -- Portability : portable -- Types used in this project. module Distribution.ArchHs.Types ( PkgList, ComponentPkgList, - CommunityName (..), - CommunityVersion, + ArchLinuxName (..), + SystemDependency (..), + ArchLinuxVersion, CommunityDB, HackageEnv, CommunityEnv, @@ -48,19 +49,25 @@ -- | A list of component represented by 'UnqualComponentName' and its dependencies collected in a 'PkgList' type ComponentPkgList = [(UnqualComponentName, PkgList)] --- | Name of packages in archlinux community repo, a wrapper of 'String'. -newtype CommunityName = CommunityName +-- | Name of packages in archlinux repo, a wrapper of 'String'. +newtype ArchLinuxName = ArchLinuxName { -- | Unwrap the value - unCommunityName :: String + unArchLinuxName :: String } deriving stock (Show, Read, Eq, Ord, Generic) deriving anyclass (NFData) +-- | A external dependency provided by system, +-- which is converted from package config (.pc) or extra lib (.so). +newtype SystemDependency = SystemDependency String + deriving stock (Show, Read, Eq, Ord, Generic) + deriving anyclass (NFData) + -- | Version of packages in archlinux community repo -type CommunityVersion = String +type ArchLinuxVersion = String -- | Representation of @cummunity.db@ -type CommunityDB = Map CommunityName CommunityVersion +type CommunityDB = Map ArchLinuxName ArchLinuxVersion -- | Reader effect of 'HackageDB' type HackageEnv = Reader HackageDB @@ -85,6 +92,8 @@ CExeBuildTools UnqualComponentName | -- | By a /library/ CLib + | -- By a /custom setup/ + CSetup | -- | By a /test suit/ CTest UnqualComponentName | -- | By a /benchmark/ @@ -107,6 +116,7 @@ = Exe | ExeBuildTools | Lib + | Setup | Test | Benchmark | LibBuildTools @@ -127,6 +137,7 @@ show (CSubLibsBuildTools x) = unUnqualComponentName x <> " :: SubLibsBuildTools" show CLib = "Lib" show CLibBuildTools = "LibBuildTools" + show CSetup = "Setup" -- | Provider of a dependency. data DependencyProvider = ByCommunity | ByAur diff --git a/src/Distribution/ArchHs/Utils.hs b/src/Distribution/ArchHs/Utils.hs --- a/src/Distribution/ArchHs/Utils.hs +++ b/src/Distribution/ArchHs/Utils.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE ViewPatterns #-} + -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT --- Maintainer: berberman <1793913507@qq.com> +-- Maintainer: berberman -- Stability: experimental -- Portability: portable -- Miscellaneous functions used crossing modules. @@ -13,11 +15,13 @@ unExeV, unLegacyExeV, unBuildTools, + unSystemDependency, unDepV, getUrl, getTwo, buildDependsIfBuild, buildToolsAndbuildToolDependsIfBuild, + pkgconfigDependsAndExtraLibsIfBuild, traceCallStack, trace', depNotInGHCLib, @@ -25,10 +29,18 @@ depIsKind, extractFromEVR, isProvided, + filterFirstDiff, + filterFirstAndBothDiff, + filterSecondDiff, + filterSecondAndBothDiff, + noDiff, + mapDiff, + unDiff, ) where import Control.Monad ((<=<)) +import Data.Algorithm.Diff import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Local (ghcLibList) import Distribution.ArchHs.Types @@ -38,6 +50,8 @@ import Distribution.Types.ExeDependency (ExeDependency (..)) import Distribution.Types.LegacyExeDependency import qualified Distribution.Types.PackageId as I +import Distribution.Types.PkgconfigDependency +import Distribution.Types.PkgconfigName import Distribution.Utils.ShortText (fromShortText) import GHC.Stack (callStack, prettyCallStack) @@ -57,6 +71,12 @@ unBuildTools :: ([LegacyExeDependency], [ExeDependency]) -> [(PackageName, VersionRange)] unBuildTools (l, e) = (unLegacyExeV <$> l) <> (unExeV <$> e) +-- | Extract dependency names from '[PkgconfigDependency]' and '[SystemDependency]'. +-- >>> (PkgconfigDependency "foo" _ver) --> (SystemDependency "foo.pc") +-- >>> "foo" --> (SystemDependency "libfoo.so") +unSystemDependency :: ([PkgconfigDependency], [String]) -> [SystemDependency] +unSystemDependency (p, s) = [SystemDependency $ name <> ".pc" | (PkgconfigDependency (unPkgconfigName -> name) _) <- p] <> [SystemDependency $ "lib" <> name <> ".so" | name <- s] + -- | Extract the 'PackageName' and 'VersionRange' of a 'Dependency'. unDepV :: Dependency -> (PackageName, VersionRange) unDepV dep = (depPkgName dep, depVerRange dep) @@ -98,6 +118,7 @@ dependencyTypeToKind (CBenchmarkBuildTools _) = BenchmarkBuildTools dependencyTypeToKind (CSubLibs _) = SubLibs dependencyTypeToKind (CSubLibsBuildTools _) = SubLibsBuildTools +dependencyTypeToKind CSetup = Setup -- | Apply a 'Getting' to two values respectively, and get the result as a pair. getTwo :: Getting b s b -> s -> s -> (b, b) @@ -105,13 +126,22 @@ -- | Same as 'targetBuildDepends', but check if this is 'buildable'. buildDependsIfBuild :: BuildInfo -> [Dependency] -buildDependsIfBuild info = if buildable info then targetBuildDepends info else [] +buildDependsIfBuild info = whenBuildable [] info targetBuildDepends -- | 'buildToolDepends' combined with 'buildTools', and check if this is 'buildable'. -- Actually, we should avoid accessing these two fields directly, in in favor of 'Distribution.Simple.BuildToolDepends.getAllToolDependencies' buildToolsAndbuildToolDependsIfBuild :: BuildInfo -> ([LegacyExeDependency], [ExeDependency]) -buildToolsAndbuildToolDependsIfBuild info = if buildable info then (buildTools info, buildToolDepends info) else ([], []) +buildToolsAndbuildToolDependsIfBuild info = whenBuildable ([], []) info $ \i -> (buildTools i, buildToolDepends i) +-- | 'pkgconfigDepends' combined with 'extraLibs', and check if this is 'buildable'. +pkgconfigDependsAndExtraLibsIfBuild :: BuildInfo -> ([PkgconfigDependency], [String]) +pkgconfigDependsAndExtraLibsIfBuild info = whenBuildable ([], []) info $ \i -> (pkgconfigDepends i, extraLibs i) + +whenBuildable :: a -> BuildInfo -> (BuildInfo -> a) -> a +whenBuildable def info f + | buildable info = f info + | otherwise = def + -- | Trace with prefix @[TRACE]@. trace' :: MemberWithError Trace r => String -> Sem r () trace' s = trace $ "[TRACE] " <> s @@ -141,7 +171,7 @@ -- "8.10.2" -- >>> extractFromEVR "3:2.4.11-19" -- "2.4.11" -extractFromEVR :: String -> CommunityVersion +extractFromEVR :: String -> ArchLinuxVersion extractFromEVR evr = let ev = head $ splitOn "-" evr in if ':' `elem` ev then tail $ dropWhile (/= ':') ev else ev @@ -150,3 +180,35 @@ isProvided :: SolvedPackage -> Bool isProvided (ProvidedPackage _ _) = True isProvided _ = False + +-- | Filter values from only 'First' list +filterFirstDiff :: [Diff a] -> [Diff a] +filterFirstDiff = filter (\case First _ -> True; _ -> False) + +-- | Filter values from only 'Second' list +filterSecondDiff :: [Diff a] -> [Diff a] +filterSecondDiff = filter (\case Second _ -> True; _ -> False) + +-- | Filter values from 'First' and 'Both' list +filterFirstAndBothDiff :: [Diff a] -> [Diff a] +filterFirstAndBothDiff = filter (\case Second _ -> False; _ -> True) + +-- | Filter values from 'Second' and 'Both' list +filterSecondAndBothDiff :: [Diff a] -> [Diff a] +filterSecondAndBothDiff = filter (\case First _ -> False; _ -> True) + +-- | Whether it only has 'Both' +noDiff :: [Diff a] -> Bool +noDiff = all (\case Both _ _ -> True; _ -> False) + +-- | Map value of diff +mapDiff :: (a -> b) -> Diff a -> Diff b +mapDiff f (First x) = First $ f x +mapDiff f (Second x) = Second $ f x +mapDiff f (Both x y) = Both (f x) (f y) + +-- | Extract value from diff +unDiff :: Diff a -> a +unDiff (First x) = x +unDiff (Second x) = x +unDiff (Both x _) = x diff --git a/submit/Main.hs b/submit/Main.hs --- a/submit/Main.hs +++ b/submit/Main.hs @@ -4,13 +4,13 @@ module Main (main) where -import qualified Colourista as C import Control.Monad (unless) import qualified Data.Text as T -import Distribution.ArchHs.Community +import Distribution.ArchHs.CommunityDB import Distribution.ArchHs.Exception import Distribution.ArchHs.Hackage import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.PP import Distribution.ArchHs.Types import Submit import System.Directory (doesFileExist) @@ -21,39 +21,37 @@ do Options {..} <- runArgsParser - let useDefaultHackage = "YOUR_HACKAGE_MIRROR" `isInfixOf` optHackagePath - when useDefaultHackage $ C.skipMessage "You didn't pass -h, use hackage index file from default path." - -#ifndef ALPM - let useDefaultCommunity = "/var/lib/pacman/sync/community.db" == optCommunityPath - when useDefaultCommunity $ C.skipMessage "You didn't pass -c, use community db file from default path." -#endif - token <- lookupEnv "HACKAGE_API_TOKEN" - when (null token) $ C.warningMessage "You didn't set HACKAGE_API_TOKEN, dry run only." + when (null token) $ + printWarn "You didn't set HACKAGE_API_TOKEN, dry run only." let hasOutput = not $ null optOutput when hasOutput $ do - C.infoMessage $ "Output will be dumped to " <> T.pack optOutput <> "." + printInfo $ "Output will be dumped to " <> T.pack optOutput <> "." exist <- doesFileExist optOutput when exist $ - C.warningMessage $ "File " <> T.pack optOutput <> " already existed, overwrite it." - C.infoMessage "Start running..." + printWarn $ "File " <> T.pack optOutput <> " already existed, overwrite it." + printInfo "Start running..." unless (optUpload || hasOutput) $ - C.warningMessage "Run diff and check only." + printWarn "Run diff and check only." #ifdef ALPM - when optAlpm $ C.infoMessage "Using alpm." - community <- if optAlpm then loadCommunityFFI else loadProcessedCommunity defaultCommunityPath + let src = T.pack $ if optAlpm then "libalpm" else defaultCommunityDBPath + printInfo $ "Loading community.db from " <> src + community <- if optAlpm then loadCommunityDBFFI else loadCommunityDB defaultCommunityDBPath #else - community <- loadProcessedCommunity $ if useDefaultCommunity then defaultCommunityPath else optCommunityPath + printInfo $ "Loading community.db from " <> T.pack optCommunityDBPath + community <- loadCommunityDB optCommunityDBPath #endif - C.infoMessage "Loading community.db..." + printInfo "Loading community.db..." - hackage <- loadHackageDB =<< if useDefaultHackage then lookupHackagePath else return optHackagePath - C.infoMessage "Loading hackage..." + hackagePath <- if null optHackagePath then lookupHackagePath else return optHackagePath + + printInfo $ "Loading hackage from " <> T.pack hackagePath + + hackage <- loadHackageDB hackagePath runSubmit community hackage (submit token optOutput optUpload) & printAppResult diff --git a/submit/Submit.hs b/submit/Submit.hs --- a/submit/Submit.hs +++ b/submit/Submit.hs @@ -9,8 +9,8 @@ ) where -import qualified Colourista as C import Control.Monad (unless) +import Data.Algorithm.Diff (getGroupedDiff) import qualified Data.ByteString.Char8 as BS import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromJust) @@ -21,17 +21,23 @@ import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Local import Distribution.ArchHs.Name +import Distribution.ArchHs.PP import Distribution.ArchHs.Types +import Distribution.ArchHs.Utils (filterFirstDiff, filterSecondDiff, mapDiff, noDiff) import Network.HTTP.Req import Options.Applicative hiding (header) import qualified Options.Applicative import qualified Text.Megaparsec as M import Text.Megaparsec.Char as M +#ifndef ALPM +import Distribution.ArchHs.CommunityDB (defaultCommunityDBPath) +#endif + data Options = Options { optHackagePath :: FilePath, #ifndef ALPM - optCommunityPath :: FilePath, + optCommunityDBPath :: FilePath, #else optAlpm :: Bool, #endif @@ -48,7 +54,7 @@ <> short 'h' <> help "Path to hackage index tarball" <> showDefault - <> value "~/.cabal/packages/YOUR_HACKAGE_MIRROR/01-index.tar | 00-index.tar" + <> value "" ) #ifndef ALPM <*> strOption @@ -57,7 +63,7 @@ <> short 'c' <> help "Path to community.db" <> showDefault - <> value "/var/lib/pacman/sync/community.db" + <> value defaultCommunityDBPath ) #else <*> switch @@ -124,12 +130,12 @@ <&> (_1 <<%~ toHackageName) & sortBy (\x y -> (x ^. _2 . _1) `compare` (y ^. _2 . _1)) prefix = "https://www.archlinux.org/packages/community/x86_64/" - processField (communityName, (hackageName, version)) = - let communityName' = + processField (archLinuxName, (hackageName, version)) = + let archLinuxName' = if hackageName `elem` ghcLibList || hackageName == "ghc" then "ghc" - else unCommunityName communityName - in (unPackageName hackageName, version, prefix <> communityName') + else unArchLinuxName archLinuxName + in (unPackageName hackageName, version, prefix <> archLinuxName') return $ processField <$> fields submit :: Members [HackageEnv, CommunityEnv, WithMyErr, Embed IO] r => Maybe String -> FilePath -> Bool -> Sem r () @@ -138,54 +144,64 @@ let v = renderDistroCSV csv embed $ unless (null output) $ do - C.infoMessage $ "Write file: " <> T.pack output + printInfo $ "Write file: " <> T.pack output writeFile output v check csv interceptHttpException $ when ((not . null) token && upload) $ do - C.infoMessage "Uploading..." + printInfo "Uploading..." let api = https "hackage.haskell.org" /: "distro" /: "Arch" /: "packages" r = req PUT api (ReqBodyBs . BS.pack $ v) bsResponse $ header "Authorization" (BS.pack $ "X-ApiKey " <> fromJust token) <> header "Content-Type" "text/csv" result <- runReq defaultHttpConfig r - C.infoMessage $ "StatusCode: " <> (T.pack . show $ responseStatusCode result) - C.infoMessage $ "ResponseMessage: " <> decodeUtf8 (responseStatusMessage result) - C.infoMessage "ResponseBody:" + printInfo $ "StatusCode: " <> (T.pack . show $ responseStatusCode result) + printInfo $ "ResponseMessage: " <> decodeUtf8 (responseStatusMessage result) + printInfo "ResponseBody:" putStrLn . BS.unpack $ responseBody result check :: Members [HackageEnv, WithMyErr, Embed IO] r => DistroCSV -> Sem r () check community = do - embed $ C.infoMessage "Checking generated csv file..." + printInfo "Checking generated csv file..." let hackageNames = fmap (\(a, _, _) -> a) community - pipe = fmap (\case Left (PkgNotFound x) -> Just (unCommunityName $ toCommunityName x); _ -> Nothing) + f = fmap (\case Left (PkgNotFound x) -> Just (unArchLinuxName $ toArchLinuxName x); _ -> Nothing) - failed <- catMaybes . pipe <$> mapM (\x -> try @MyException (getLatestCabal $ mkPackageName x)) hackageNames + failed <- catMaybes . f <$> mapM (\x -> try @MyException (getLatestCabal $ mkPackageName x)) hackageNames - embed $ - unless (null failed) $ - C.warningMessage "Following packages in community are not linked to hackage:" + unless (null failed) $ + printWarn "Following packages in community are not linked to hackage:" embed . putStrLn . unlines $ failed let api = https "hackage.haskell.org" /: "distro" /: "Arch" /: "packages.csv" r = req GET api NoReqBody bsResponse mempty - embed $ C.infoMessage "Downloading csv from hackage..." + printInfo "Downloading csv from hackage..." result <- interceptHttpException $ runReq defaultHttpConfig r let bs = responseBody result hackage = parseDistroCSV . T.unpack $ decodeUtf8 bs - let diffOld = hackage \\ community - diffNew = community \\ hackage - ppRecord b (name, version, url) = (if b then C.formatWith [C.green] else C.formatWith [C.red]) $ "(" <> name <> ", " <> version <> ", " <> url <> ")" + let diff = getGroupedDiff hackage community + diffOld = mconcat . ppDiffColored . mapDiff (fmap ppRecord) <$> filterFirstDiff diff + diffNew = mconcat . ppDiffColored . mapDiff (fmap ppRecord) <$> filterSecondDiff diff + ppRecord (name, version, url) = "(" <> name <> ", " <> version <> ", " <> url <> ")\n" + j g x = if null x then "[]" else g x - embed . putStrLn $ C.formatWith [C.magenta] "Diff:" - embed $ case diffNew <> diffOld of - [] -> putStrLn "[]" - _ -> do - putStr . unlines $ fmap (ppRecord False) diffOld - putStrLn $ replicate 68 '-' - putStr . unlines $ fmap (ppRecord True) diffNew + embed . putDoc . annMagneta $ "Diff" <> colon <> line + embed . putDoc . indent 2 $ + if noDiff diff + then "[]" + else + j hsep diffOld + <> splitLine + <> j hsep diffNew - embed . putStrLn $ "Found " <> show (length hackage) <> " packages with submitted distribution information in hackage, and " <> show (length community) <> " haskell packages in [community]." + embed . putDoc $ + "Found" + <+> pretty (length hackage) + <+> "packages with submitted distribution information in hackage, and" + <+> pretty (length community) + <+> "haskell packages in" + <+> ppCommunity + <> dot + <> line