diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,16 @@ `arch-hs` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.13 + +- Speed up the internal pacman database parser and restore the original explicit `--alpm` opt-in model for ALPM-enabled builds + +- Make `arch-hs-diff` read revision 0 cabal files from the local Hackage index by default, with `--online` for Hackage downloads + +- Include `--enable-debug-info` in generated PKGBUILD templates + +- Update README documentation and remove the broken hackage-deps badge + ## 0.12.3 - Teach `arch-hs-rdepcheck` to validate a candidate version against reverse dependency ranges diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,6 @@ # arch-hs [![Hackage](https://img.shields.io/hackage/v/arch-hs.svg?logo=haskell)](https://hackage.haskell.org/package/arch-hs) -[![Dependency](https://img.shields.io/hackage-deps/v/arch-hs)](https://packdeps.haskellers.com/feed?needle=arch-hs) [![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE) | Env | CI | @@ -33,7 +32,7 @@ ## Installation `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, +However, `arch-hs` can optionally use libalpm to load pacman database on Arch Linux, and if you want to run on other systems, you have to build it from source. ### Install the latest release @@ -82,9 +81,9 @@ ``` -$ arch-hs -o ~/test --alpm gi-gdk +$ arch-hs -o ~/test gi-gdk ⓘ Loading hackage from /home/berberman/.cabal/packages/hackage.haskell.org/01-index.tar -ⓘ Loading extra.db from libalpm +ⓘ Loading extra.db from /var/lib/pacman/sync/extra.db ⓘ Start running... ⓘ Solved: ... @@ -189,8 +188,8 @@ gi-pango: pango.pc ⓘ Now finding corresponding system package(s) using files db: -ⓘ Loading [core] files from libalpm -ⓘ Loading [extra] files from libalpm +ⓘ Loading [core] files from /var/lib/pacman/sync +ⓘ Loading [extra] files from /var/lib/pacman/sync ⓘ Done: gtk4.pc ⇒ gtk4 gdk-pixbuf-2.0.pc ⇒ gdk-pixbuf2 @@ -415,14 +414,18 @@ `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 extra repo can't satisfy the version constraints, or they are non-existent. +By default, `arch-hs-diff` reads revision 0 cabal files from the local Hackage index. +`-h`/`--hackage` can be used to specify the index tarball path. +Use `--online` to download revision 0 cabal files from Hackage instead. This is useful in the subsequent maintenance of a package. For example: ``` -$ arch-hs-diff --alpm comonad 5.0.6 5.0.7 -ⓘ Loading extra.db from libalpm +$ arch-hs-diff comonad 5.0.6 5.0.7 +ⓘ Loading extra.db from /var/lib/pacman/sync/extra.db +ⓘ Loading hackage from /home/berberman/.cabal/packages/hackage.haskell.org/01-index.tar ⓘ 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... +ⓘ Reading revision 0 cabal file from /home/berberman/.cabal/packages/hackage.haskell.org/01-index.tar: comonad/5.0.6/comonad.cabal +ⓘ Reading revision 0 cabal file from /home/berberman/.cabal/packages/hackage.haskell.org/01-index.tar: comonad/5.0.7/comonad.cabal Package: comonad Version: 5.0.6 ⇒ 5.0.7 Synopsis: Comonads @@ -511,8 +514,6 @@ ✔ Success! ``` -`arch-hs-diff` does not require hackage db, it downloads cabal files from hackage server instead. - ## Reverse dependency checks `arch-hs-rdepcheck` lists Haskell reverse dependencies in [extra] and the Cabal version ranges they require: @@ -553,17 +554,24 @@ ## Alpm Support [alpm](https://www.archlinux.org/pacman/libalpm.3.html) is Arch Linux Package Management library. -When running on Arch Linux, loading `extra.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: +When running on Arch Linux, `arch-hs` can load `extra.db` and files dbs through this library instead of using its internal parser. +`arch-hs` provides a Cabal flag `alpm` to build this feature: ``` cabal build -f alpm ``` This flag is enabled by default in `arch-hs` Arch Linux package. -Compiled with `alpm`, `arch-hs` uses alpm to load pacman databases by default. -In this case, the CLI flag `--no-alpm-extra` and `--no-alpm-files` can be used to disable this feature. -> When `alpm` is enabled, `arch-hs` will lose the capability of specifying the path of `extra.db` and directory of files db. +Compiled with `alpm`, `arch-hs` still reads pacman databases from `/var/lib/pacman/sync` by default. +Pass `--alpm` to load pacman databases through libalpm explicitly: + +``` +arch-hs --alpm -o ~/test gi-gdk +``` + +For commands that load only `extra.db`, such as `arch-hs-diff`, `arch-hs-sync`, and `arch-hs-rdepcheck`, `--alpm` applies to `extra.db`. +For `arch-hs`, `--alpm` applies to both `extra.db` and files dbs. +When `--alpm` is used, explicit `--extra` and `--files` paths are ignored. ## Contributing diff --git a/app/Args.hs b/app/Args.hs --- a/app/Args.hs +++ b/app/Args.hs @@ -33,10 +33,9 @@ cmdOptions :: Parser Options cmdOptions = - Options + mkOptions <$> hackageDBOptionsParser - <*> extraDBOptionsParser - <*> filesDBOptionsParser + <*> pacmanDBOptionsParser <*> strOption ( long "output" <> metavar "PATH" @@ -99,6 +98,9 @@ <> help "Try to package if the dependent of this package exist whereas this package does not" ) <*> argument optPackageNameReader (metavar "TARGET") + where + mkOptions hackage (extra, files) = + Options hackage extra files runArgsParser :: IO Options runArgsParser = do 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.12.3 +version: 0.13 synopsis: Distribute hackage packages to archlinux description: @arch-hs@ is a command-line program, which simplifies the process of producing diff --git a/diff/Args.hs b/diff/Args.hs --- a/diff/Args.hs +++ b/diff/Args.hs @@ -13,6 +13,8 @@ data Options = Options { optFlags :: FlagAssignments, optExtraDB :: ExtraDBOptions, + optHackagePath :: FilePath, + optOnline :: Bool, optPackageName :: PackageName, optVersionA :: Version, optVersionB :: Version @@ -23,6 +25,18 @@ Options <$> optFlagAssignmentParser <*> extraDBOptionsParser + <*> strOption + ( long "hackage" + <> metavar "PATH" + <> short 'h' + <> help "Path to hackage index tarball" + <> showDefault + <> value "" + ) + <*> switch + ( long "online" + <> help "Download cabal files from Hackage instead of reading the local Hackage index" + ) <*> argument optPackageNameReader (metavar "TARGET") <*> argument optVersionReader (metavar "VERSION_A") <*> argument optVersionReader (metavar "VERSION_B") diff --git a/diff/Diff.hs b/diff/Diff.hs --- a/diff/Diff.hs +++ b/diff/Diff.hs @@ -2,16 +2,23 @@ {-# LANGUAGE TypeApplications #-} module Diff - ( diffCabal, + ( CabalSource (..), + diffCabal, ) where import Data.Algorithm.Diff +import Control.Monad (unless) +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS +import qualified Data.Conduit.Tar as Tar +import Data.IORef (modifyIORef', newIORef, readIORef) +import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromJust) -import Distribution.ArchHs.ExtraDB (versionInExtra) +import Conduit import Distribution.ArchHs.Core import Distribution.ArchHs.Exception +import Distribution.ArchHs.ExtraDB (versionInExtra) import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.PP import Distribution.ArchHs.Types @@ -22,20 +29,71 @@ type VersionedList = [(PackageName, VersionRange)] +data CabalSource + = Online Manager + | Offline FilePath + ----------------------------------------------------------------------------- -getCabalFromHackage :: Members [Embed IO, WithMyErr, Reader Manager] r => PackageName -> Version -> Sem r GenericPackageDescription -getCabalFromHackage name version = do +getCabalFromHackage :: Members [Embed IO, WithMyErr] r => Manager -> PackageName -> Version -> Sem r GenericPackageDescription +getCabalFromHackage manager name version = do let urlPath = unPackageName name <> "-" <> prettyShow version s = "https://hackage.haskell.org/package/" <> urlPath <> "/revision/0.cabal" req <- interceptHttpException $ parseRequest s printInfo $ "Downloading cabal file from" <+> pretty s - manager <- ask @Manager response <- interceptHttpException $ httpLbs req manager case parseGenericPackageDescriptionMaybe . LBS.toStrict $ responseBody response of Just x -> return x _ -> error "Failed to parse .cabal file" +getCabalsFromIndex :: Members [Embed IO, WithMyErr] r => FilePath -> PackageName -> [Version] -> Sem r (Map.Map Version GenericPackageDescription) +getCabalsFromIndex hackagePath name versions = do + let pkg = unPackageName name + cabalPaths = Map.fromList [(pkg prettyShow version (pkg <> ".cabal"), version) | version <- nub versions] + mapM_ (\cabalPath -> printInfo $ "Reading revision 0 cabal file from" <+> pretty hackagePath <> colon <+> pretty cabalPath) $ Map.keys cabalPaths + cabalFiles <- embed $ findCabalFilesInIndex hackagePath cabalPaths + Map.fromList <$> traverse (parseCabal cabalFiles) (nub versions) + where + parseCabal cabalFiles version = + case parseGenericPackageDescriptionMaybe =<< Map.lookup version cabalFiles of + Just cabal -> return (version, cabal) + Nothing -> throw $ VersionNotFound name version + +findCabalFilesInIndex :: FilePath -> Map.Map FilePath Version -> IO (Map.Map Version BS.ByteString) +findCabalFilesInIndex hackagePath cabalPaths = do + foundRef <- newIORef Map.empty + Map.fromList + <$> runConduitRes + ( sourceFileBS hackagePath + .| Tar.untarChunks + .| Tar.withEntries (action foundRef) + .| takeC (Map.size cabalPaths) + .| sinkList + ) + where + action foundRef header + | Tar.FTNormal <- Tar.headerFileType header, + Just version <- Map.lookup (Tar.headerFilePath header) cabalPaths = do + found <- liftIO $ readIORef foundRef + unless (Map.member version found) $ do + cabalFile <- mconcat <$> sinkList + liftIO $ modifyIORef' foundRef (Map.insert version ()) + yield (version, cabalFile) + | otherwise = return () + +getCabalsFromSource :: Members [Embed IO, WithMyErr, Reader CabalSource] r => PackageName -> Version -> Version -> Sem r (GenericPackageDescription, GenericPackageDescription) +getCabalsFromSource name a b = + ask @CabalSource >>= \case + Online manager -> (,) <$> getCabalFromHackage manager name a <*> getCabalFromHackage manager name b + Offline hackagePath -> do + cabals <- getCabalsFromIndex hackagePath name [a, b] + (,) <$> lookupCabal cabals a <*> lookupCabal cabals b + where + lookupCabal cabals version = + case Map.lookup version cabals of + Just cabal -> return cabal + Nothing -> throw $ VersionNotFound name version + directDependencies :: Members [KnownGHCVersion, FlagAssignmentsEnv, Trace, DependencyRecord] r => GenericPackageDescription -> @@ -65,10 +123,9 @@ ----------------------------------------------------------------------------- -diffCabal :: Members [KnownGHCVersion, ExtraEnv, FlagAssignmentsEnv, WithMyErr, Trace, DependencyRecord, Reader Manager, Embed IO] r => PackageName -> Version -> Version -> Sem r () +diffCabal :: Members [KnownGHCVersion, ExtraEnv, FlagAssignmentsEnv, WithMyErr, Trace, DependencyRecord, Reader CabalSource, Embed IO] r => PackageName -> Version -> Version -> Sem r () diffCabal name a b = do - ga <- getCabalFromHackage name a - gb <- getCabalFromHackage name b + (ga, gb) <- getCabalsFromSource name a b let pa = packageDescription ga pb = packageDescription gb fa = genPackageFlags ga diff --git a/diff/Main.hs b/diff/Main.hs --- a/diff/Main.hs +++ b/diff/Main.hs @@ -10,12 +10,12 @@ import Diff import Distribution.ArchHs.Core (subsumeGHCVersion) import Distribution.ArchHs.Exception +import Distribution.ArchHs.Hackage (lookupHackagePath) import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Options import Distribution.ArchHs.PP import Distribution.ArchHs.Types import GHC.IO.Encoding (setLocaleEncoding, utf8) -import Network.HTTP.Client (Manager) import Network.HTTP.Client.TLS (newTlsManager) main :: IO () @@ -31,23 +31,29 @@ extra <- loadExtraDBFromOptions optExtraDB - manager <- newTlsManager + cabalSource <- + if optOnline + then Online <$> newTlsManager + else do + hackagePath <- if null optHackagePath then lookupHackagePath else pure optHackagePath + printInfo $ "Loading hackage from" <+> pretty hackagePath + pure $ Offline hackagePath printInfo "Start running..." - runDiff extra optFlags manager (subsumeGHCVersion $ diffCabal optPackageName optVersionA optVersionB) & printAppResult + runDiff extra optFlags cabalSource (subsumeGHCVersion $ diffCabal optPackageName optVersionA optVersionB) & printAppResult runDiff :: ExtraDB -> FlagAssignments -> - Manager -> - Sem '[ExtraEnv, FlagAssignmentsEnv, Reader Manager, Trace, DependencyRecord, WithMyErr, Embed IO, Final IO] a -> + CabalSource -> + Sem '[ExtraEnv, FlagAssignmentsEnv, Reader CabalSource, Trace, DependencyRecord, WithMyErr, Embed IO, Final IO] a -> IO (Either MyException a) -runDiff extra flags manager = +runDiff extra flags cabalSource = runFinal . embedToFinal . errorToIOFinal . evalState Map.empty . ignoreTrace - . runReader manager + . runReader cabalSource . runReader flags . runReader extra diff --git a/src/Distribution/ArchHs/ExtraDB.hs b/src/Distribution/ArchHs/ExtraDB.hs --- a/src/Distribution/ArchHs/ExtraDB.hs +++ b/src/Distribution/ArchHs/ExtraDB.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} @@ -24,19 +25,16 @@ 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 Data.Maybe (mapMaybe) import Distribution.ArchHs.Exception import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Name import Distribution.ArchHs.PkgDesc import Distribution.ArchHs.Types -import Data.Maybe (mapMaybe) ----------------------------------------------------------------------------- #ifdef ALPM -{-# LANGUAGE ForeignFunctionInterface #-} - import Data.IORef (IORef, modifyIORef', newIORef, readIORef) import Distribution.ArchHs.Utils (extractFromEVR) import Foreign.C.String (CString, peekCString) @@ -120,10 +118,8 @@ action header = when (Tar.headerFileType header == Tar.FTNormal) $ do x <- mconcat <$> sinkList - let txt = T.unpack . decodeUtf8 $ x - parsed = runDescParser (Tar.headerFilePath header) txt - result = case parsed of - Right desc -> + let result = case parseDescEntry . decodeUtf8 $ x of + Just desc -> desc : ( if _name desc == ArchLinuxName "ghc" || _name desc == ArchLinuxName "ghc-libs" @@ -131,11 +127,11 @@ else [] ) -- Drop it if failed to parse - Left _ -> [] + Nothing -> [] yieldMany $ (\desc -> (_name desc, desc)) <$> result -- | Load @extra.db@ from @path@. --- @desc@ files in the db will be parsed by @descParser@. +-- @desc@ files in the db will be parsed by 'parseDescEntry'. loadExtraDB :: FilePath -> IO ExtraDB loadExtraDB path = Map.fromList <$> runConduitRes (loadExtraDBC path .| sinkList) diff --git a/src/Distribution/ArchHs/FilesDB.hs b/src/Distribution/ArchHs/FilesDB.hs --- a/src/Distribution/ArchHs/FilesDB.hs +++ b/src/Distribution/ArchHs/FilesDB.hs @@ -28,7 +28,7 @@ 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.PkgDesc (parseDescFields) import Distribution.ArchHs.Types #ifdef ALPM @@ -83,8 +83,8 @@ 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 + "desc" -> case parseDescFields txt Map.!? "NAME" of + Just [name] -> yield . Desc fp $ ArchLinuxName $ T.unpack name _ -> return () _ -> return () | otherwise = return () diff --git a/src/Distribution/ArchHs/Options.hs b/src/Distribution/ArchHs/Options.hs --- a/src/Distribution/ArchHs/Options.hs +++ b/src/Distribution/ArchHs/Options.hs @@ -16,6 +16,7 @@ -- * Load files DB FilesDBOptions (..), filesDBOptionsParser, + pacmanDBOptionsParser, -- * Load Hackage DB HackageDBOptions (..), @@ -50,47 +51,35 @@ -- | CLI options parser of 'ExtraDBOptions' -- --- When alpm is enabled, it reads a flag @no-alpm-extra@; --- otherwise it reads a string option @extra@. +-- When alpm is enabled, it also reads a flag @alpm@. extraDBOptionsParser :: Parser ExtraDBOptions - -#ifndef ALPM extraDBOptionsParser = + mkExtraDBOptions <$> alpmOptionsParser <*> extraDBPathParser + +extraDBPathParser :: Parser FilePath +extraDBPathParser = + strOption $ + long "extra" + <> metavar "PATH" + <> short 'c' + <> help "Path to extra.db" + <> showDefault + <> value defaultExtraDBPath + +mkExtraDBOptions :: Bool -> FilePath -> ExtraDBOptions +mkExtraDBOptions useAlpm path = ExtraDBOptions - <$> fmap - ( \s -> - do - printInfo $ "Loading extra.db from" <+> pretty s - loadExtraDB s - ) - ( strOption $ - long "extra" - <> metavar "PATH" - <> short 'c' - <> help "Path to extra.db" - <> showDefault - <> value defaultExtraDBPath - ) + ( do + let src = if useAlpm then "libalpm" else path + printInfo $ "Loading extra.db from" <+> pretty src +#ifdef ALPM + if useAlpm + then loadExtraDBFFI + else loadExtraDB path #else -extraDBOptionsParser = - ExtraDBOptions - <$> fmap - ( \b -> - do - let src = if b then "libalpm" else defaultExtraDBPath - printInfo $ "Loading extra.db from" <+> pretty src - if b - then loadExtraDBFFI - else loadExtraDB defaultExtraDBPath - ) - ( flag - True - False - ( long "no-alpm-extra" - <> help "Do not use libalpm to parse extra db" - ) - ) + loadExtraDB path #endif + ) ----------------------------------------------------------------------------- -- | Parsed options for loading 'FilesDB' @@ -100,47 +89,58 @@ -- | CLI options parser of 'ExtraDBOptions' -- --- When alpm is enabled, it reads a flag @no-alpm-files@; --- otherwise it reads a string option @files@. +-- When alpm is enabled, it also reads a flag @alpm@. filesDBOptionsParser :: Parser FilesDBOptions - -#ifndef ALPM filesDBOptionsParser = + mkFilesDBOptions <$> alpmOptionsParser <*> filesDBPathParser + +filesDBPathParser :: Parser FilePath +filesDBPathParser = + strOption $ + long "files" + <> metavar "PATH" + <> short 'f' + <> help + "Path of dir that includes core.files, extra.files and extra.files" + <> showDefault + <> value defaultFilesDBDir + +mkFilesDBOptions :: Bool -> FilePath -> FilesDBOptions +mkFilesDBOptions useAlpm path = FilesDBOptions - <$> fmap - ( \s db -> - do - printInfo $ - "Loading" <+> ppDBKind db <+> "files from" <+> pretty s - loadFilesDB db s - ) - ( strOption $ - long "files" - <> metavar "PATH" - <> short 'f' - <> help - "Path of dir that includes core.files, extra.files and extra.files" - <> showDefault - <> value defaultFilesDBDir - ) + ( \db -> + do + let src = if useAlpm then "libalpm" else path + printInfo $ + "Loading" <+> ppDBKind db <+> "files from" <+> pretty src +#ifdef ALPM + if useAlpm then loadFilesDBFFI db else loadFilesDB db path #else -filesDBOptionsParser = - FilesDBOptions - <$> fmap - ( \b db -> - do - let src = if b then "libalpm" else defaultFilesDBDir - printInfo $ - "Loading" <+> ppDBKind db <+> "files from" <+> pretty src - if b then loadFilesDBFFI db else loadFilesDB db defaultFilesDBDir - ) - ( flag - True - False - ( long "no-alpm-files" - <> help "Do not use libalpm to parse files db" - ) - ) + loadFilesDB db path +#endif + ) + +-- | CLI options parser for commands that need both pacman database loaders. +-- +-- When alpm is enabled, it reads @alpm@ once and applies it to both loaders. +pacmanDBOptionsParser :: Parser (ExtraDBOptions, FilesDBOptions) +pacmanDBOptionsParser = + mkPacmanDBOptions + <$> alpmOptionsParser + <*> extraDBPathParser + <*> filesDBPathParser + where + mkPacmanDBOptions useAlpm extraPath filesPath = + (mkExtraDBOptions useAlpm extraPath, mkFilesDBOptions useAlpm filesPath) + +alpmOptionsParser :: Parser Bool +#ifndef ALPM +alpmOptionsParser = pure False +#else +alpmOptionsParser = + switch $ + long "alpm" + <> help "Use libalpm to load pacman databases" #endif ----------------------------------------------------------------------------- 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 @@ -589,7 +589,7 @@ build() { cd $$_hkgname-$$pkgver - runhaskell Setup configure -O --enable-shared --enable-executable-dynamic --disable-library-vanilla \ + runhaskell Setup configure -O --enable-shared --enable-debug-info --enable-executable-dynamic --disable-library-vanilla \ --prefix=/usr --docdir=/usr/share/doc/$$pkgname --datasubdir=$$pkgname --enable-tests \ --dynlibdir=/usr/lib --libsubdir=\$$compiler/site-local/\$$pkgid \ --ghc-option=-optl-Wl\,-z\,relro\,-z\,now \ diff --git a/src/Distribution/ArchHs/PkgDesc.hs b/src/Distribution/ArchHs/PkgDesc.hs --- a/src/Distribution/ArchHs/PkgDesc.hs +++ b/src/Distribution/ArchHs/PkgDesc.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- | Copyright: (c) 2020-2021 berberman @@ -9,28 +10,20 @@ -- This module provides parser of @desc@ file in pacman db. module Distribution.ArchHs.PkgDesc ( PkgDesc (..), - DescParser, - descParser, - descFieldsParser, - runDescFieldsParser, - runDescParser, + parseDescEntry, + parseDescFields, promoteDependent, containsDep, ) where -import Control.Monad (void) import qualified Data.Map.Strict as Map -import Data.Void (Void) +import Data.Maybe (isJust) +import qualified Data.Text as T import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Types import Distribution.ArchHs.Utils (extractFromEVR) -import Text.Megaparsec -import Text.Megaparsec.Char --- | A parser takes 'String' as input, without user state. -type DescParser = Parsec Void String - -- Common fields {- fieldList = [ "FILENAME", @@ -77,63 +70,52 @@ containsDep :: PkgDependentList -> ArchLinuxName -> Bool containsDep deps name = name `elem` (_pdName <$> deps) --- | Parse fields of @desc@. -descFieldsParser :: DescParser (Map.Map String [String]) -descFieldsParser = - Map.fromList - <$> ( do - sep - field <- manyTill anySingle sep - _ <- newline - content <- manyTill line (lookAhead sep <|> eof) - return (field, filter (/= "") content) - ) - `manyTill` eof +-- | Parse fields of a pacman @desc@ file. +parseDescFields :: T.Text -> Map.Map T.Text [T.Text] +parseDescFields = go Map.empty . dropWhile T.null . T.lines where - sep = void $ char '%' - line = manyTill anySingle newline + go acc [] = acc + go acc (line : rest) + | Just field <- fieldName line = + let (content, rest') = break (isJust . fieldName) rest + in go (Map.insert field (filter (not . T.null) content) acc) (dropWhile T.null rest') + | otherwise = go acc rest --- | Parse a desc file. -descParser :: DescParser PkgDesc -descParser = - descFieldsParser - >>= ( \fields -> do - _name <- ArchLinuxName <$> lookupSingle fields "NAME" - _version <- extractFromEVR <$> lookupSingle fields "VERSION" - _desc <- lookupSingle fields "DESC" - _url <- lookupSingleMaybe fields "URL" - _depends <- toDepList =<< lookupList fields "DEPENDS" - _makeDepends <- toDepList =<< lookupList fields "MAKEDEPENDS" - _provides <- toDepList =<< lookupList fields "PROVIDES" - _optDepends <- toDepList =<< lookupList fields "OPTDEPENDS" - _replaces <- toDepList =<< lookupList fields "REPLACES" - _conflicts <- toDepList =<< lookupList fields "CONFLICTS" - _checkDepends <- toDepList =<< lookupList fields "CHECKDEPENDS" - return PkgDesc {..} - ) + fieldName line + | Just rest <- T.stripPrefix "%" line, + Just field <- T.stripSuffix "%" rest = + Just field + | otherwise = Nothing + +-- | Parse a pacman @desc@ file into a package description. +parseDescEntry :: T.Text -> Maybe PkgDesc +parseDescEntry txt = do + _name <- ArchLinuxName . T.unpack <$> lookupSingle "NAME" + _version <- extractFromEVR . T.unpack <$> lookupSingle "VERSION" + _desc <- T.unpack <$> lookupSingle "DESC" + _depends <- toDepList $ lookupList "DEPENDS" + _makeDepends <- toDepList $ lookupList "MAKEDEPENDS" + _provides <- toDepList $ lookupList "PROVIDES" + _optDepends <- toDepList $ lookupList "OPTDEPENDS" + _replaces <- toDepList $ lookupList "REPLACES" + _conflicts <- toDepList $ lookupList "CONFLICTS" + _checkDepends <- toDepList $ lookupList "CHECKDEPENDS" + let _url = T.unpack <$> lookupSingleMaybe "URL" + pure PkgDesc {..} where - toDepList = mapM $ \t -> case splitOn "=" t of - [name, version] -> pure $ PkgDependent (ArchLinuxName name) (Just version) - [name] -> pure $ PkgDependent (ArchLinuxName name) Nothing - _ -> fail $ "Unable to parse dep list " <> t - lookupSingle fields f = case Map.lookup f fields of - (Just x) -> case x of - (e : _) -> return e - _ -> fail $ "Expect a singleton " <> f - _ -> fail $ "Unable to find field " <> f - lookupSingleMaybe fields f = return $ case Map.lookup f fields of - (Just x) -> case x of - (e : _) -> Just e - _ -> Nothing + fields = parseDescFields txt + + lookupSingle field = case Map.lookup field fields of + Just (x : _) -> Just x _ -> Nothing - lookupList fields f = return $ case Map.lookup f fields of - (Just x) -> x - _ -> [] --- | Run the desc fields parser. -runDescFieldsParser :: String -> String -> Either (ParseErrorBundle String Void) (Map.Map String [String]) -runDescFieldsParser = parse descFieldsParser + lookupSingleMaybe field = case Map.lookup field fields of + Just (x : _) -> Just x + _ -> Nothing --- | Run the desc parser. -runDescParser :: String -> String -> Either (ParseErrorBundle String Void) PkgDesc -runDescParser = parse descParser + lookupList field = Map.findWithDefault [] field fields + + toDepList = traverse $ \t -> case splitOn "=" $ T.unpack t of + [name, version] -> Just $ PkgDependent (ArchLinuxName name) (Just version) + [name] -> Just $ PkgDependent (ArchLinuxName name) Nothing + _ -> Nothing