diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,22 @@ `arch-hs` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.5.0.0 + +* Add `TargetDisappearException` to complain if target is clearly not reachable + +* Warn abnormal dependencies + +* Clear trace file if is not empty + +* Collect test dependencies recursively + +* Drop meaningless `alpm_errno_t` + +* Update name preset ([#30](https://github.com/berberman/arch-hs/pull/30) [#32](https://github.com/berberman/arch-hs/pull/32)) + +* Fix a typo ([#29](https://github.com/berberman/arch-hs/pull/29)) + ## 0.4.0.0 * [Alpm](https://www.archlinux.org/pacman/libalpm.3.html) support diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,7 +13,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. @@ -38,7 +38,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 +46,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 @@ -93,7 +93,7 @@ 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. +whereas they are not present in archlinux \[community\] repo. ``` $ tree ~/test @@ -344,13 +344,15 @@ ## Limitations -* The dependency solver will **ONLY** expand the dependencies of *executables* , *libraries* and *sub-libraries* recursively, because -circular dependency lies ubiquitously involving *test suites* and their *buildTools*. `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. +* `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. +Nevertheless, if the target introduces new cycle or it dependens on a package in an unknown cycle, `arch-hs` will throw `CyclicExist` exception. -* Currently, `arch-hs`'s functionality is limited to dependency processing, whereas necessary procedures like -file patches, loose of version constraints, etc. are need to be done manually, so **DO NOT** give too much trust in generated PKGBUILD files. +* `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. +* `arch-hs`'s functionality is limited to dependency processing, whereas necessary procedures like +file patches, version range processes, etc. They need to be done manually, so **DO NOT** give too much trust in generated PKGBUILD files. + ## Alpm Support [alpm](https://www.archlinux.org/pacman/libalpm.3.html) is Arch Linux Package Management library. @@ -362,7 +364,7 @@ ``` This flag is enabled by default in `arch-hs` Arch Linux package. -Compiled with `alpm`, `arch-hs` can accpet runtime flag `--alpm`. +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`. @@ -373,8 +375,6 @@ - [x] AUR support. - [x] Working with given `.cabal` files which haven't been released to hackage. - -- [ ] Using `hackage-security` to manage hackage index tarball. ## Contributing diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} module Main (main) where @@ -10,12 +11,12 @@ import qualified Algebra.Graph.Labelled.AdjacencyMap as GL import Args import qualified Colourista as C -import Conduit -import Control.Monad (filterM, unless) +import Control.Monad (filterM, forM_, unless) import Data.Containers.ListUtils (nubOrd) import Data.IORef (IORef, newIORef) import Data.List.NonEmpty (toList) import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) import qualified Data.Set as Set import qualified Data.Text as T import Distribution.ArchHs.Aur (Aur, aurToIO, isInAur) @@ -30,9 +31,7 @@ import qualified Distribution.ArchHs.PkgBuild as N import Distribution.ArchHs.Types import Distribution.ArchHs.Utils -import System.Directory - ( createDirectoryIfMissing, - ) +import System.Directory (createDirectoryIfMissing) import System.FilePath (takeFileName) app :: @@ -46,50 +45,58 @@ Sem r () app target path aurSupport skip uusi metaPath = do (deps, sublibs) <- getDependencies (fmap mkUnqualComponentName skip) Nothing target + inCommunity <- isInCommunity target + when inCommunity $ throw $ TargetExist target ByCommunity when aurSupport $ do inAur <- isInAur target when inAur $ 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))) + list ^.. 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 - let fillProvidedPkgs provideList provider = mapC (\x -> if (x ^. pkgName) `elem` provideList then ProvidedPackage (x ^. pkgName) provider else x) - fillProvidedDeps provideList provider = mapC (pkgDeps %~ each %~ (\y -> if y ^. depName `elem` provideList then y & depProvider ?~ provider else y)) - filledByCommunity = - runConduitPure $ - yieldMany grouped - .| fillProvidedPkgs communityProvideList ByCommunity - .| fillProvidedDeps communityProvideList ByCommunity - .| sinkList - toBePacked1 = filledByCommunity ^.. each . filtered (\case ProvidedPackage _ _ -> False; _ -> True) + + 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) + ) + providedPackages + + embed $ + forM_ abnormalDependencies $ \(T.pack . unPackageName -> parent, childs) -> do + C.warningMessage $ "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) + fillProvidedDeps provideList provider = map (pkgDeps %~ each %~ (\y -> if y ^. depName `elem` provideList then y & depProvider ?~ provider else y)) + 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..." - aurProvideList <- if aurSupport then filterM (\n -> do embed $ C.infoMessage ("Searching " <> T.pack (unPackageName n)); isInAur n) $ toBePacked1 ^.. each . pkgName else return [] - let filledByBoth = - if aurSupport - then - runConduitPure $ - yieldMany filledByCommunity - .| fillProvidedPkgs aurProvideList ByAur - .| fillProvidedDeps aurProvideList ByAur - .| sinkList - else filledByCommunity - toBePacked2 = - if aurSupport - then filledByBoth ^.. each . filtered (\case ProvidedPackage _ _ -> False; _ -> True) - else toBePacked1 - return (filledByBoth, toBePacked2) + aurProvideList <- + if aurSupport + then filterM (\n -> do embed $ C.infoMessage ("Searching " <> T.pack (unPackageName n)); isInAur n) $ toBePacked1 ^.. each . pkgName + else return [] + let a = fillProvidedPkgs aurProvideList ByAur . fillProvidedDeps aurProvideList ByAur $ filledByCommunity + b = a ^.. each . filtered (not . isProvided) + return (a, b) + when (null filledByBoth) $ + throw $ TargetDisappearException target + embed $ C.infoMessage "Solved:" embed $ putStrLn . prettySolvedPkgs $ filledByBoth embed $ C.infoMessage "Recommended package order:" - let vertexesToBeRemoved = filledByBoth ^.. each . filtered (\case ProvidedPackage _ _ -> True; _ -> False) ^.. each . pkgName + 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 @@ -111,9 +118,10 @@ dir = path pName fileName = dir "PKGBUILD" txt = N.applyTemplate pkgBuild - embed $ createDirectoryIfMissing True dir - embed $ writeFile fileName txt - embed $ C.infoMessage $ "Write file: " <> T.pack fileName + embed $ do + createDirectoryIfMissing True dir + writeFile fileName txt + C.infoMessage $ "Write file: " <> T.pack fileName ) toBePacked2 @@ -127,20 +135,21 @@ ^.. each . filtered (\x -> depNotMyself (pkg ^. pkgName) x && depNotInGHCLib x && x ^. depProvider == Just ByCommunity) toStr x = "'" <> (unCommunityName . toCommunityName . _depName) x <> "'" - depends = case intercalate " " . nubOrd . fmap toStr . mconcat $ providedDepends <$> toBePacked2 of + depends = case unwords . nubOrd . fmap toStr . mconcat $ providedDepends <$> toBePacked2 of [] -> "" xs -> " " <> xs flattened' = filter (/= target) flattened comment = case flattened' of [] -> "\n" [x] -> "# The following dependency is missing in community: " <> unPackageName x - _ -> "# Following dependencies are missing in community:" <> (intercalate ", " $ unPackageName <$> flattened') + _ -> "# Following dependencies are missing in community:" <> intercalate ", " (unPackageName <$> flattened') txt = template (T.pack comment) (T.pack depends) dir = metaPath "haskell-" <> name <> "-meta" fileName = dir "PKGBUILD" - embed $ createDirectoryIfMissing True dir - embed $ writeFile fileName (T.unpack txt) - embed $ C.infoMessage $ "Write file: " <> T.pack fileName + embed $ do + createDirectoryIfMissing True dir + writeFile fileName (T.unpack txt) + C.infoMessage $ "Write file: " <> T.pack fileName ----------------------------------------------------------------------------- @@ -178,8 +187,9 @@ do Options {..} <- runArgsParser - unless (null optFileTrace) $ + unless (null optFileTrace) $ do C.infoMessage $ "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." 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.4.0.0 +version: 0.5.0.0 synopsis: Distribute hackage packages to archlinux description: @arch-hs@ is a command-line program, which simplifies the process of producing @@ -53,9 +53,9 @@ , microlens ^>=0.4.11 , microlens-th ^>=0.4.3 , neat-interpolation ^>=0.5.1 - , optparse-applicative ^>=0.15.1 - , polysemy ^>=1.3.0 || ^>=1.4.0 - , req ^>=3.6.0 || ^>=3.7.0 + , optparse-applicative ^>=0.16.0 + , polysemy + , req ^>=3.8.0 , split ^>=0.2.3 , tar-conduit ^>=0.3.2 , template-haskell ^>=2.16.0 diff --git a/cbits/clib.c b/cbits/clib.c --- a/cbits/clib.c +++ b/cbits/clib.c @@ -4,7 +4,7 @@ #include #include -int query_community(callback_t callback) { +void query_community(callback_t callback) { alpm_errno_t err; alpm_handle_t *handle; handle = alpm_initialize("/", "/var/lib/pacman", &err); @@ -30,5 +30,4 @@ callback(name, ver); } alpm_release(handle); - return err; } diff --git a/cbits/clib.h b/cbits/clib.h --- a/cbits/clib.h +++ b/cbits/clib.h @@ -3,6 +3,6 @@ typedef void callback_t(const char *, const char *); -int query_community(callback_t callback); +void query_community(callback_t callback); #endif diff --git a/data/NAME_PRESET.json b/data/NAME_PRESET.json --- a/data/NAME_PRESET.json +++ b/data/NAME_PRESET.json @@ -1,7 +1,5 @@ { "falseList": [ - "haskell-network2.8", - "haskell-sbv8.7", "haskell-ghc-heap", "haskell-libiserv", "haskell-tamarin-prover-sapic" @@ -67,7 +65,6 @@ "haskell-quickcheck": "QuickCheck", "haskell-ranged-sets": "Ranged-sets", "haskell-safesemaphore": "SafeSemaphore", - "haskell-sbv8.7": "haskell-sbv8.7", "haskell-sha": "SHA", "haskell-smtlib": "smtLib", "haskell-src-exts": "haskell-src-exts", diff --git a/src/Distribution/ArchHs/Community.hs b/src/Distribution/ArchHs/Community.hs --- a/src/Distribution/ArchHs/Community.hs +++ b/src/Distribution/ArchHs/Community.hs @@ -40,17 +40,13 @@ import Data.Foldable (toList) import Data.IORef (IORef, modifyIORef', newIORef, readIORef) import Foreign.C.String (CString, peekCString) -import Foreign.C.Types (CInt(..)) 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 CInt - -foreign import ccall "alpm.h alpm_strerror" - alpm_strerror :: CInt -> IO CString + query_community :: FunPtr (CString -> CString -> IO ()) -> IO () callback :: IORef (Seq.Seq (CommunityName, CommunityVersion)) -> CString -> CString -> IO () callback ref x y = do @@ -63,12 +59,8 @@ loadCommunityFFI = do ref <- newIORef Seq.empty callbackW <- wrap $ callback ref - errno <- query_community callbackW + query_community callbackW freeHaskellFunPtr callbackW - when (errno /= 0) $ do - msg <- peekCString =<< alpm_strerror errno - -- TODO: why? :( - putStrLn $ "warn: unexpected return code from libalpm: " <> show errno <> " (" <> msg <> ")" Map.fromList . toList <$> readIORef ref #endif diff --git a/src/Distribution/ArchHs/Core.hs b/src/Distribution/ArchHs/Core.hs --- a/src/Distribution/ArchHs/Core.hs +++ b/src/Distribution/ArchHs/Core.hs @@ -36,10 +36,7 @@ import Distribution.Compiler (CompilerFlavor (..)) import Distribution.PackageDescription import Distribution.SPDX -import Distribution.System - ( Arch (X86_64), - OS (Linux), - ) +import Distribution.System (Arch (X86_64), OS (Linux)) import qualified Distribution.Types.BuildInfo.Lens as L import Distribution.Types.CondTree (simplifyCondTree) import Distribution.Types.Dependency (Dependency) @@ -153,13 +150,14 @@ -- currentBench = componentialEdges Types.Benchmark benchDeps -- currentBenchTools = componentialEdges BenchmarkBuildTools benchToolsDeps - + processNext = mapM (getDependencies skip (Just name)) . ignoreResolved . ignoreSubLibs (<+>) = G.overlay - -- Only solve lib & exe deps recursively. - nextLib <- mapM (getDependencies skip (Just name)) . ignoreResolved . ignoreSubLibs $ filteredLibDeps - nextExe <- mapM (getDependencies skip (Just name)) . ignoreResolved . ignoreSubLibs $ fmap snd filteredExeDeps + nextLib <- processNext filteredLibDeps + 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, nextSubLibs] + let temp = [nextLib, nextExe, nextTest, nextSubLibs] nexts = G.overlays $ temp ^. each ^.. each . _1 subsubs = temp ^. each ^.. each . _2 ^. each return 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 @@ -37,6 +37,7 @@ | TargetExist PackageName DependencyProvider | CyclicExist [PackageName] | NetworkException HttpException + | TargetDisappearException PackageName instance Show MyException where show (PkgNotFound name) = "Unable to find \"" <> unPackageName (toHackageName name) <> "\"" @@ -45,6 +46,7 @@ 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" -- | Catch 'CE.IOException' and print it. printHandledIOException :: IO () -> IO () 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 @@ -26,22 +26,10 @@ import Distribution.ArchHs.Exception import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Types -import Distribution.ArchHs.Utils - ( getPkgName, - getPkgVersion, - ) -import Distribution.Hackage.DB - ( HackageDB, - VersionData (VersionData, cabalFile), - readTarball, - tarballHashes, - ) +import Distribution.ArchHs.Utils (getPkgName, getPkgVersion) +import Distribution.Hackage.DB (HackageDB, VersionData (VersionData, cabalFile), readTarball, tarballHashes) import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) -import System.Directory - ( findFile, - getHomeDirectory, - listDirectory, - ) +import System.Directory (findFile, getHomeDirectory, listDirectory) -- | Look up hackage tarball path from @~/.cabal@. -- Arbitrary hackage mirror is potential to be selected. 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 @@ -25,7 +25,6 @@ "bytestring-builder", "nats", "old-time", - "old-locale", "integer", "unsupported-ghc-version", "base", 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 @@ -52,10 +52,7 @@ where import Data.Char (toLower) -import Data.String - ( IsString, - fromString, - ) +import Data.String (IsString, fromString) import Distribution.ArchHs.Internal.NamePresetLoader import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Types 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 @@ -24,6 +24,7 @@ depNotMyself, depIsKind, extractFromEVR, + isProvided, ) where @@ -33,19 +34,12 @@ import Distribution.ArchHs.Types import Distribution.PackageDescription (repoLocation) import Distribution.Types.BuildInfo (BuildInfo (..)) -import Distribution.Types.Dependency - ( Dependency, - depPkgName, - depVerRange, - ) +import Distribution.Types.Dependency (Dependency, depPkgName, depVerRange) import Distribution.Types.ExeDependency (ExeDependency (..)) import Distribution.Types.LegacyExeDependency import qualified Distribution.Types.PackageId as I import Distribution.Utils.ShortText (fromShortText) -import GHC.Stack - ( callStack, - prettyCallStack, - ) +import GHC.Stack (callStack, prettyCallStack) -- | Extract the package name from a 'ExeDependency'. unExe :: ExeDependency -> PackageName @@ -151,3 +145,8 @@ extractFromEVR evr = let ev = head $ splitOn "-" evr in if ':' `elem` ev then tail $ dropWhile (/= ':') ev else ev + +-- | Whether a 'SolvedPackage' is provided +isProvided :: SolvedPackage -> Bool +isProvided (ProvidedPackage _ _) = True +isProvided _ = False diff --git a/submit/Submit.hs b/submit/Submit.hs --- a/submit/Submit.hs +++ b/submit/Submit.hs @@ -116,17 +116,13 @@ genCSV = do db <- ask @CommunityDB - {-# HLINT ignore "Use <&>" #-} let communityPackages = Map.toList db fields = communityPackages ^.. each - . filtered (\(name, _) -> isHaskellPackage name) - & mapped - %~ _1 - <<%~ toHackageName - & sortBy (\x y -> (x ^. _2 . _1) `compare` (y ^. _2 . _1)) - + . filtered (isHaskellPackage . (^. _1)) + <&> (_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' =