diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for nvfetcher +## 0.6.2.0 + +* Rework config parsing with toml-reader + ## 0.6.1.0 * Replace `nix-prefetch` with `nix-prefetch-git` and `nix-prefetch-url` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -224,6 +224,8 @@ - `passthru = { k1 = "v1", k2 = "v2", ... }` +Note: currently the values can only be strings + #### Pinned If a package is pinned, we call nvchecker to check the new version iff there's no existing version. diff --git a/app/Config.hs b/app/Config.hs --- a/app/Config.hs +++ b/app/Config.hs @@ -1,142 +1,155 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -module Config where +module Config (prettyPackageConfigParseError, parseConfig, PackageConfigValidateError (..)) where import Config.PackageFetcher import Config.VersionSource -import Data.Coerce (coerce) -import Data.Either.Extra (mapLeft) +import Control.Monad.Trans.Except import qualified Data.HashMap.Strict as HMap -import Data.List (intersect) -import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NE +import Data.List (foldl', intersect) +import qualified Data.Map.Strict as Map import Data.Text (Text) import qualified Data.Text as T import NvFetcher.Types -import Toml -import Validation (validationToEither) +import TOML +import TOML.Decode -data PackageConfigParseError = TomlErrors [TomlDecodeError] | KeyConflicts [[Key]] +-- should be NE +newtype MyKey = MyKey {unMyKey :: [Text]} -instance Semigroup PackageConfigParseError where - TomlErrors e <> _ = TomlErrors e - _ <> TomlErrors e = TomlErrors e - KeyConflicts xs <> KeyConflicts ys = KeyConflicts $ xs <> ys +myKeyToText :: MyKey -> Text +myKeyToText = T.intercalate "." . unMyKey -prettyPackageConfigParseError :: PackageConfigParseError -> Text -prettyPackageConfigParseError (TomlErrors e) = prettyTomlDecodeErrors e -prettyPackageConfigParseError (KeyConflicts xs) = "Skip parsing!\n" <> T.unlines ["Key conflict: " <> T.intercalate ", " [prettyKey k | k <- ks] | ks <- xs] +data PackageConfigValidateError + = TomlError TOMLError + | KeyConflicts PackageName [[Text]] + | KeyUnexpected PackageName [Text] -parseConfig :: TOML -> Either PackageConfigParseError [Package] -parseConfig toml = go tables Nothing [] - where - go (Left errs : xs) (Just se) sp = go xs (Just (se <> errs)) sp - go (Left errs : xs) Nothing sp = go xs (Just errs) sp - go (Right x : xs) se sp = go xs se (x : sp) - go [] Nothing sp = Right sp - go [] (Just se) _ = Left se - tables = - [ fmap (toPackage (coerce k)) $ validateKeys v >> mapLeft TomlErrors (validationToEither (Toml.runTomlCodec packageConfigCodec v)) - | (Toml.unKey -> (Toml.unPiece -> k) :| _, v) <- Toml.toList $ Toml.tomlTables toml - ] +prettyPackageConfigParseError :: PackageConfigValidateError -> Text +prettyPackageConfigParseError (TomlError e) = "Failed to parse config file: " <> renderTOMLError e +prettyPackageConfigParseError (KeyConflicts pkg xs) = T.unlines ["In [" <> pkg <> "], key conflicts occurred: " <> T.intercalate ", " ks | ks <- xs] +prettyPackageConfigParseError (KeyUnexpected pkg xs) = T.unlines ["In [" <> pkg <> "], unexpected keys found: " <> k | k <- xs] -validateKeys :: TOML -> Either PackageConfigParseError () -validateKeys toml = if null e then Right () else Left $ foldl1 (<>) e +parseConfig :: Text -> Either [PackageConfigValidateError] [Package] +parseConfig raw = runExcept $ case decodeWith tableDecoder raw of + Right (Map.toList -> x) -> mapM (uncurry eachP) x + Left err -> throwE [TomlError err] where - allKeys = HMap.keys $ Toml.tomlPairs toml - go xs = let intersection = xs `intersect` allKeys in if length intersection > 1 then intersection else [] - e = [KeyConflicts [t] | k <- [versionSourceKeys, fetcherKeys], let t = go k, not $ null t] + tableDecoder = + makeDecoder $ \case + (Table t) -> pure t + v -> typeMismatch v + eachP pkg v@(Table _) = do + let keys = myKeyToText <$> allKeys [] v + checkConflicts pkg keys + checkUnexpected pkg keys + case unDecodeM (runDecoder (packageConfigDecoder pkg) v) [] of + Left e -> throwE [TomlError $ uncurry DecodeError e] + Right x -> pure x + eachP pkg _ = throwE [KeyUnexpected pkg [pkg]] + allKeys prefix (Table t) = + mconcat + [ case x of + (Table _) -> [] + _ -> [MyKey $ prefix <> [k]] + | (k, x) <- Map.toList t + ] + <> Map.foldrWithKey (\k v acc -> allKeys (prefix <> [k]) v <> acc) [] t + allKeys _ _ = [] + checkConflicts pkg keys = + throwN + [ KeyConflicts pkg [intersection] + | k <- + [ ("src." <>) <$> versionSourceKeys, + ("fetch." <>) <$> fetcherKeys + ], + let intersection = keys `intersect` k, + length intersection > 1 + ] + checkUnexpected pkg keys = + throwN $ + -- git + [ KeyUnexpected pkg gk + | let gk = filter (T.isPrefixOf "git.") keys, + not $ null gk, + "fetch.git" `notElem` keys && "fetch.github" `notElem` keys + ] + -- docker + <> [ KeyUnexpected pkg dk + | let dk = filter (T.isPrefixOf "docker.") keys, + not $ null dk, + "fetch.docker" `notElem` keys + ] + -- list options + <> [ KeyUnexpected pkg lk + | let lk = listOptionsKeys `intersect` keys, + not $ null lk, + "src.docker" `notElem` keys + && "src.httpheader" `notElem` keys + && "src.container" `notElem` keys + && "src.github_tag" `notElem` keys + ] + throwN [] = pure () + throwN xs = throwE xs -------------------------------------------------------------------------------- -data PackageConfig = PackageConfig - { pcVersionSource :: VersionSource, - pcFetcher :: PackageFetcher, - pcExtractFiles :: Maybe PackageExtractSrc, - pcCargoLockFiles :: Maybe PackageCargoLockFiles, - pcNvcheckerOptions :: NvcheckerOptions, - pcPassthru :: PackagePassthru, - pcUseStale :: UseStaleVersion, - pcGitDateFormat :: DateFormat, - pcForceFetch :: ForceFetch - } - -toPackage :: PackageKey -> PackageConfig -> Package -toPackage k PackageConfig {..} = - Package - (coerce k) - (CheckVersion pcVersionSource pcNvcheckerOptions) - pcFetcher - pcExtractFiles - pcCargoLockFiles - pcPassthru - pcUseStale - pcGitDateFormat - pcForceFetch - -packageConfigCodec :: TomlCodec PackageConfig -packageConfigCodec = - PackageConfig - <$> versionSourceCodec .= pcVersionSource - <*> fetcherCodec .= pcFetcher - <*> extractFilesCodec .= pcExtractFiles - <*> cargoLockPathCodec .= pcCargoLockFiles - <*> nvcheckerOptionsCodec .= pcNvcheckerOptions - <*> passthruCodec .= pcPassthru - <*> pinnedCodec .= pcUseStale - <*> gitDateFormatCodec .= pcGitDateFormat - <*> forceFetchCodec .= pcForceFetch +packageConfigDecoder :: PackageName -> Decoder Package +packageConfigDecoder name = + Package name + <$> (CheckVersion <$> versionSourceDecoder <*> nvcheckerOptionsDecoder) + <*> fetcherDecoder + <*> extractFilesDecoder + <*> cargoLockPathDecoder + <*> passthruDecoder + <*> pinnedDecoder + <*> gitDateFormatDecoder + <*> forceFetchDecoder -------------------------------------------------------------------------------- -extractFilesCodec :: TomlCodec (Maybe PackageExtractSrc) -extractFilesCodec = - dimap - (fmap (NE.toList . coerce)) - (\mxs -> coerce <$> (mxs >>= NE.nonEmpty)) - $ dioptional $ arrayOf _String "extract" +extractFilesDecoder :: Decoder (Maybe PackageExtractSrc) +extractFilesDecoder = fmap PackageExtractSrc <$> getFieldOpt "extract" -cargoLockPathCodec :: TomlCodec (Maybe PackageCargoLockFiles) -cargoLockPathCodec = - dimap - (fmap (NE.toList . coerce)) - (\mxs -> coerce <$> (mxs >>= NE.nonEmpty)) - $ dioptional $ arrayOf _String "cargo_locks" +cargoLockPathDecoder :: Decoder (Maybe PackageCargoLockFiles) +cargoLockPathDecoder = fmap PackageCargoLockFiles <$> getFieldOpt "cargo_locks" -nvcheckerOptionsCodec :: TomlCodec NvcheckerOptions -nvcheckerOptionsCodec = +nvcheckerOptionsDecoder :: Decoder NvcheckerOptions +nvcheckerOptionsDecoder = NvcheckerOptions - <$> dioptional (text "src.prefix") .= _stripPrefix - <*> dioptional (text "src.from_pattern") .= _fromPattern - <*> dioptional (text "src.to_pattern") .= _toPattern + <$> getFieldsOpt ["src", "prefix"] + <*> getFieldsOpt ["src", "from_pattern"] + <*> getFieldsOpt ["src", "to_pattern"] -passthruCodec :: TomlCodec PackagePassthru -passthruCodec = diwrap $ tableHashMap _KeyText text "passthru" +passthruDecoder :: Decoder PackagePassthru +passthruDecoder = + getFieldOpt @Value "passthru" >>= \case + Just (Table t) -> go [] t >>= \(mconcat -> fs) -> pure $ PackagePassthru $ foldl' (flip ($)) HMap.empty fs + Just _ -> makeDecoder typeMismatch + Nothing -> pure $ PackagePassthru HMap.empty + where + go prefix x = + sequenceA + [ case v of + (String text) -> pure [HMap.insert (myKeyToText $ MyKey $ prefix <> [k]) text] + Table t -> mconcat <$> go (prefix <> [k]) t + _ -> makeDecoder (\_ -> invalidValue "passthru value must be string for now" v) + | (k, v) <- Map.toList x + ] -pinnedCodec :: TomlCodec UseStaleVersion -pinnedCodec = - dimap - ( \case - PermanentStale -> Just True - TemporaryStale -> error "Impossible!" - NoStale -> Just False - ) - (maybe NoStale (\x -> if x then PermanentStale else NoStale)) - $ dioptional $ bool "pinned" +pinnedDecoder :: Decoder UseStaleVersion +pinnedDecoder = + maybe NoStale (\x -> if x then PermanentStale else NoStale) + <$> getFieldOpt "pinned" -gitDateFormatCodec :: TomlCodec DateFormat -gitDateFormatCodec = diwrap $ dioptional $ text "git.date_format" +gitDateFormatDecoder :: Decoder DateFormat +gitDateFormatDecoder = DateFormat <$> getFieldsOpt ["git", "date_format"] -forceFetchCodec :: TomlCodec ForceFetch -forceFetchCodec = - dimap - ( \case - ForceFetch -> Just True - NoForceFetch -> Just False - ) - (maybe NoForceFetch (\x -> if x then ForceFetch else NoForceFetch)) - $ dioptional $ bool "fetch.force" +forceFetchDecoder :: Decoder ForceFetch +forceFetchDecoder = + maybe NoForceFetch (\x -> if x then ForceFetch else NoForceFetch) + <$> getFieldsOpt ["fetch", "force"] diff --git a/app/Config/Common.hs b/app/Config/Common.hs new file mode 100644 --- /dev/null +++ b/app/Config/Common.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Config.Common where + +import Data.Text (Text) +import qualified Data.Text as T +import TOML + +githubDecoder :: Decoder (Text, Text) +githubDecoder = makeDecoder $ \case + v@(String s) -> case T.split (== '/') s of + [owner, repo] -> pure (owner, repo) + _ -> invalidValue "unexpected github format: it should be in the format of [owner]/[repo]" v + v -> typeMismatch v + +vscodeExtensionDecoder :: Decoder (Text, Text) +vscodeExtensionDecoder = makeDecoder $ \case + -- assume that we can't have '.' in extension's name + v@(String s) -> case T.split (== '.') s of + [publisher, extName] -> pure (publisher, extName) + _ -> invalidValue "unexpected vscode extension format: it should be in the format of [publisher].[extName]" v + v -> typeMismatch v diff --git a/app/Config/PackageFetcher.hs b/app/Config/PackageFetcher.hs --- a/app/Config/PackageFetcher.hs +++ b/app/Config/PackageFetcher.hs @@ -1,56 +1,48 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -module Config.PackageFetcher - ( fetcherCodec, - fetcherKeys, - ) -where +module Config.PackageFetcher (fetcherDecoder, fetcherKeys) where +import Config.Common import Data.Coerce (coerce) -import Data.Default (Default, def) import Data.Foldable (asum) import Data.Maybe (fromMaybe) +import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) import Lens.Micro -import Lens.Micro.Extras (view) import NvFetcher.NixFetcher import NvFetcher.Types import NvFetcher.Types.Lens -import Toml - -unsupportError :: a -unsupportError = error "serialization is unsupported" +import TOML -fetcherCodec :: TomlCodec PackageFetcher -fetcherCodec = +fetcherDecoder :: Decoder PackageFetcher +fetcherDecoder = asum - [ gitHubCodec, - pypiCodec, - openVsxCodec, - vscodeMarketplaceCodec, - gitCodec, - urlCodec, - tarballCodec, - dockerCodec + [ gitHubDecoder, + pypiDecoder, + openVsxDecoder, + vscodeMarketplaceDecoder, + gitDecoder, + urlDecoder, + tarballDecoder, + dockerDecoder ] -fetcherKeys :: [Key] +fetcherKeys :: [Text] fetcherKeys = - [ "fetch.github", - "fetch.pypi", - "fetch.openvsx", - "fetch.vsmarketplace", - "fetch.git", - "fetch.url", - "fetch.tarball", - "fetch.docker" + [ "github", + "pypi", + "openvsx", + "vsmarketplace", + "git", + "url", + "tarball", + "docker" ] -------------------------------------------------------------------------------- @@ -60,14 +52,14 @@ goFetchSubmodules :: Maybe Bool, goLeaveDotGit :: Maybe Bool } - deriving (Eq, Generic, Default) + deriving (Eq, Generic) -gitOptionsCodec :: TomlCodec GitOptions -gitOptionsCodec = +gitOptionsDecoder :: Decoder GitOptions +gitOptionsDecoder = GitOptions - <$> dioptional (bool "git.deepClone") .= goDeepClone - <*> dioptional (bool "git.fetchSubmodules") .= goFetchSubmodules - <*> dioptional (bool "git.leaveDotGit") .= goLeaveDotGit + <$> getFieldsOpt ["git", "deepClone"] + <*> getFieldsOpt ["git", "fetchSubmodules"] + <*> getFieldsOpt ["git", "leaveDotGit"] _GitOptions :: Traversal' (NixFetcher f) GitOptions _GitOptions f x@FetchGit {..} = @@ -90,108 +82,62 @@ -------------------------------------------------------------------------------- -gitHubICodec :: TomlCodec PackageFetcher -gitHubICodec = - textBy - unsupportError - ( \t -> case T.split (== '/') t of - [owner, repo] -> Right $ gitHubFetcher (owner, repo) - _ -> Left "unexpected github fetcher: it should be something like [owner]/[repo]" - ) - "fetch.github" - -gitHubCodec :: TomlCodec PackageFetcher -gitHubCodec = - dimap - ( \f -> let fake = f "$ver" in (f, fromMaybe def $ fake ^? _GitOptions) - ) - (\(f, g) v -> f v & _GitOptions .~ g) - $ (,) <$> gitHubICodec .= view _1 <*> gitOptionsCodec .= view _2 +gitHubDecoder :: Decoder PackageFetcher +gitHubDecoder = do + (owner, repo) <- getFieldsWith githubDecoder ["fetch", "github"] + gitOptions <- gitOptionsDecoder + pure $ \v -> gitHubFetcher (owner, repo) v & _GitOptions .~ gitOptions -------------------------------------------------------------------------------- -gitICodec :: TomlCodec PackageFetcher -gitICodec = - textBy - unsupportError - (Right . gitFetcher) - "fetch.git" -gitCodec :: TomlCodec PackageFetcher -gitCodec = - dimap - ( \f -> let fake = f "$ver" in (f, fromMaybe def $ fake ^? _GitOptions) - ) - (\(f, g) v -> f v & _GitOptions .~ g) - $ (,) <$> gitICodec .= view _1 <*> gitOptionsCodec .= view _2 +gitDecoder :: Decoder PackageFetcher +gitDecoder = do + url <- getFields ["fetch", "git"] + gitOptions <- gitOptionsDecoder + pure $ \v -> gitFetcher url v & _GitOptions .~ gitOptions -------------------------------------------------------------------------------- -pypiCodec :: TomlCodec PackageFetcher -pypiCodec = - Toml.textBy - unsupportError - (Right . pypiFetcher) - "fetch.pypi" +pypiDecoder :: Decoder PackageFetcher +pypiDecoder = pypiFetcher <$> getFields ["fetch", "pypi"] + -------------------------------------------------------------------------------- -openVsxCodec :: TomlCodec PackageFetcher -openVsxCodec = - textBy - unsupportError - ( \t -> case T.split (== '.') t of - -- assume we can't have '.' in extension's name - [publisher, extName] -> Right $ openVsxFetcher (publisher, extName) - _ -> Left "unexpected openvsx fetcher: it should be something like [publisher]/[extName]" - ) - "fetch.openvsx" +openVsxDecoder :: Decoder PackageFetcher +openVsxDecoder = openVsxFetcher <$> getFieldsWith vscodeExtensionDecoder ["fetch", "openvsx"] -------------------------------------------------------------------------------- -vscodeMarketplaceCodec :: TomlCodec PackageFetcher -vscodeMarketplaceCodec = - textBy - unsupportError - ( \t -> case T.split (== '.') t of - -- assume we can't have '.' in extension's name - [publisher, extName] -> Right $ vscodeMarketplaceFetcher (publisher, extName) - _ -> Left "unexpected vscode marketplace fetcher: it should be something like [publisher]/[extName]" - ) - "fetch.vsmarketplace" +vscodeMarketplaceDecoder :: Decoder PackageFetcher +vscodeMarketplaceDecoder = vscodeMarketplaceFetcher <$> getFieldsWith vscodeExtensionDecoder ["fetch", "vsmarketplace"] -------------------------------------------------------------------------------- -urlCodec :: TomlCodec PackageFetcher -urlCodec = - Toml.textBy - unsupportError - (\t -> Right $ \(coerce -> v) -> urlFetcher $ T.replace "$ver" v t) - "fetch.url" +urlDecoder :: Decoder PackageFetcher +urlDecoder = do + url <- getFields ["fetch", "url"] + pure $ \(coerce -> v) -> urlFetcher $ T.replace "$ver" v url + -------------------------------------------------------------------------------- -tarballCodec :: TomlCodec PackageFetcher -tarballCodec = - Toml.textBy - unsupportError - (\t -> Right $ \(coerce -> v) -> tarballFetcher $ T.replace "$ver" v t) - "fetch.tarball" +tarballDecoder :: Decoder PackageFetcher +tarballDecoder = do + url <- getFields ["fetch", "tarball"] + pure $ \(coerce -> v) -> tarballFetcher $ T.replace "$ver" v url -------------------------------------------------------------------------------- -dockerCodec :: TomlCodec PackageFetcher -dockerCodec = - dimap unsupportError setImageTag codec - where - setImageTag t (Version v) = t & imageTag .~ v - - codec :: TomlCodec (NixFetcher Fresh) - codec = - FetchDocker - <$> Toml.text "fetch.docker" .= _imageName - <*> pure "" -- will be set in setImageTag - <*> pure () .= _imageDigest - <*> pure () .= _sha256 - <*> dioptional (text "docker.os") .= _fos - <*> dioptional (text "docker.arch") .= _farch - <*> dioptional (text "docker.finalImageName") .= _finalImageName - <*> dioptional (text "docker.finalImageTag") .= _finalImageTag - <*> dioptional (bool "docker.tlsVerify") .= _tlsVerify +dockerDecoder :: Decoder PackageFetcher +dockerDecoder = + (\f (coerce -> v) -> f & imageTag .~ v) + <$> ( FetchDocker + <$> getFields ["fetch", "docker"] + <*> pure "" -- set in fmap + <*> pure () + <*> pure () + <*> getFieldsOpt ["docker", "os"] + <*> getFieldsOpt ["docker", "arch"] + <*> getFieldsOpt ["docker", "finalImageName"] + <*> getFieldsOpt ["docker", "finalImageTag"] + <*> getFieldsOpt ["docker", "tlsVerify"] + ) diff --git a/app/Config/VersionSource.hs b/app/Config/VersionSource.hs --- a/app/Config/VersionSource.hs +++ b/app/Config/VersionSource.hs @@ -1,258 +1,160 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} -module Config.VersionSource - ( versionSourceCodec, - versionSourceKeys, - ) -where +module Config.VersionSource (versionSourceDecoder, versionSourceKeys, listOptionsKeys) where +import Config.Common +import Data.Coerce (coerce) import Data.Foldable (asum) import Data.Text (Text) import qualified Data.Text as T -import Data.Tuple.Extra (uncurry3) -import Lens.Micro -import Lens.Micro.Extras (view) import NvFetcher.Types -import NvFetcher.Types.Lens -import Toml +import TOML -versionSourceCodec :: TomlCodec VersionSource -versionSourceCodec = - asum - [ gitHubReleaseCodec, - gitHubTagCodec, - gitCodec, - pypiCodec, - archLinuxCodec, - aurCodec, - manualCodec, - repologyCodec, - webpageCodec, - httpHeaderCodec, - openVsxCodec, - vscodeMarketplaceCodec, - cmdCodec, - containerCodec - ] +versionSourceDecoder :: Decoder VersionSource +versionSourceDecoder = + -- everything is in src table + flip getFieldWith "src" $ + asum + [ gitHubReleaseDecoder, + gitHubTagDecoder, + gitDecoder, + pypiDecoder, + archLinuxDecoder, + aurDecoder, + manualDecoder, + repologyDecoder, + webpageDecoder, + httpHeaderDecoder, + openVsxDecoder, + vscodeMarketplaceDecoder, + cmdDecoder, + containerDecoder + ] -versionSourceKeys :: [Key] +versionSourceKeys :: [Text] versionSourceKeys = - [ "src.github", - "src.github_tag", - "src.git", - "src.pypi", - "src.archpkg", - "src.aur", - "src.manual", - "src.webpage", - "src.httpheader", - "src.openvsx", - "src.vsmarketplace", - "src.cmd", - "src.container" + [ "github", + "github_tag", + "git", + "pypi", + "archpkg", + "aur", + "manual", + "webpage", + "httpheader", + "openvsx", + "vsmarketplace", + "cmd", + "container" ] --------------------------------------------------------------------------------- +listOptionsKeys :: [Text] +listOptionsKeys = + [ "include_regex", + "exclude_regex", + "sort_version_key", + "ignored" + ] -githubICodec :: Key -> TomlCodec (Text, Text) -githubICodec = - textBy - (\(owner, repo) -> owner <> "/" <> repo) - ( \t -> - case T.split (== '/') t of - [owner, repo] -> Right (owner, repo) - _ -> Left "unexpected github source format: it should be something like [owner]/[repo]" - ) +-------------------------------------------------------------------------------- -listOptionsCodec :: TomlCodec ListOptions -listOptionsCodec = +listOptionsDecoder :: Decoder ListOptions +listOptionsDecoder = ListOptions - <$> dioptional (text "src.include_regex") .= _includeRegex - <*> dioptional (text "src.exclude_regex") .= _excludeRegex - <*> dioptional - ( textBy - (T.pack . show) - ( \case - "parse_version" -> Right ParseVersion - "vercmp" -> Right Vercmp - _ -> Left "unexpected sort_version_key: it should be either parse_version or vercmp" - ) - "src.sort_version_key" - ) - .= _sortVersionKey - <*> dioptional (text "src.ignored") .= _ignored + <$> getFieldOpt "include_regex" + <*> getFieldOpt "exclude_regex" + <*> ( getFieldOpt @Text "sort_version_key" >>= \case + Just "parse_version" -> pure $ Just ParseVersion + Just "vercmp" -> pure $ Just Vercmp + Just _ -> makeDecoder $ invalidValue "unexpected sort_version_key: it should be either parse_version or vercmp" + Nothing -> pure Nothing + ) + <*> getFieldOpt "ignored" -------------------------------------------------------------------------------- -matchGitHubRelease :: VersionSource -> Maybe (Text, Text) -matchGitHubRelease x = (,) <$> x ^? owner <*> x ^? repo - -gitHubReleaseCodec :: TomlCodec VersionSource -gitHubReleaseCodec = dimatch matchGitHubRelease (uncurry GitHubRelease) $ githubICodec "src.github" +gitHubReleaseDecoder :: Decoder VersionSource +gitHubReleaseDecoder = uncurry GitHubRelease <$> getFieldWith githubDecoder "github" -------------------------------------------------------------------------------- -matchGitHubTag :: VersionSource -> Maybe ((Text, Text), ListOptions) -matchGitHubTag x = do - o <- x ^? owner - r <- x ^? repo - l <- x ^? listOptions - pure ((o, r), l) - -gitHubTagICodec :: TomlCodec ((Text, Text), ListOptions) -gitHubTagICodec = - (,) <$> githubICodec "src.github_tag" .= view _1 - <*> listOptionsCodec .= view _2 - -gitHubTagCodec :: TomlCodec VersionSource -gitHubTagCodec = dimatch matchGitHubTag (\((_owner, _repo), _listOptions) -> GitHubTag {..}) gitHubTagICodec +gitHubTagDecoder :: Decoder VersionSource +gitHubTagDecoder = do + (_owner, _repo) <- getFieldWith githubDecoder "github_tag" + _listOptions <- listOptionsDecoder + pure GitHubTag {..} -------------------------------------------------------------------------------- -matchGit :: VersionSource -> Maybe (Text, Branch) -matchGit x = (,) <$> x ^? vurl <*> x ^? vbranch - -gitICodec :: TomlCodec (Text, Branch) -gitICodec = (,) <$> text "src.git" .= view _1 <*> diwrap (dioptional (text "src.branch")) .= view _2 - -gitCodec :: TomlCodec VersionSource -gitCodec = dimatch matchGit (uncurry Git) gitICodec +gitDecoder :: Decoder VersionSource +gitDecoder = Git <$> getField "git" <*> (coerce @(Maybe Text) <$> getFieldOpt "branch") -------------------------------------------------------------------------------- -matchPypi :: VersionSource -> Maybe Text -matchPypi x = x ^? pypi - -pypiCodec :: TomlCodec VersionSource -pypiCodec = dimatch matchPypi Pypi (text "src.pypi") +pypiDecoder :: Decoder VersionSource +pypiDecoder = Pypi <$> getField "pypi" -------------------------------------------------------------------------------- -matchArchLinux :: VersionSource -> Maybe Text -matchArchLinux x = x ^? archpkg - -archLinuxCodec :: TomlCodec VersionSource -archLinuxCodec = dimatch matchArchLinux ArchLinux (text "src.archpkg") +archLinuxDecoder :: Decoder VersionSource +archLinuxDecoder = ArchLinux <$> getField "archpkg" -------------------------------------------------------------------------------- -matchAur :: VersionSource -> Maybe Text -matchAur x = x ^? aur - -aurCodec :: TomlCodec VersionSource -aurCodec = dimatch matchAur Aur (text "src.aur") +aurDecoder :: Decoder VersionSource +aurDecoder = Aur <$> getField "aur" -------------------------------------------------------------------------------- -matchManual :: VersionSource -> Maybe Text -matchManual x = x ^? manual - -manualCodec :: TomlCodec VersionSource -manualCodec = dimatch matchManual Manual (text "src.manual") +manualDecoder :: Decoder VersionSource +manualDecoder = Manual <$> getField "manual" -------------------------------------------------------------------------------- -matchRepology :: VersionSource -> Maybe (Text, Text) -matchRepology x = (,) <$> x ^? repology <*> x ^? repo - -repologyICodec :: TomlCodec (Text, Text) -repologyICodec = - textBy - (\(repology, repo) -> repology <> ":" <> repo) - ( \t -> - case T.split (== ':') t of - [owner, repo] -> Right (owner, repo) - _ -> Left "unexpected repology source format: it should be something like [repology]:[repo]" - ) - "src.repology" - -repologyCodec :: TomlCodec VersionSource -repologyCodec = dimatch matchRepology (uncurry Repology) repologyICodec +repologyDecoder :: Decoder VersionSource +repologyDecoder = makeDecoder $ \case + v@(String s) -> case T.split (== ':') s of + [_repology, _repo] -> pure Repology {..} + _ -> invalidValue "unexpected repology format: it should be in the format of [repology]:[repo]" v + v -> typeMismatch v ------------------------------------------------------------ -matchWebpage :: VersionSource -> Maybe (Text, Text, ListOptions) -matchWebpage x = (,,) <$> x ^? vurl <*> x ^? regex <*> x ^? listOptions - -webpageICodec :: TomlCodec (Text, Text, ListOptions) -webpageICodec = - (,,) <$> text "src.webpage" .= view _1 - <*> text "src.regex" .= view _2 - <*> listOptionsCodec .= view _3 - -webpageCodec :: TomlCodec VersionSource -webpageCodec = dimatch matchWebpage (uncurry3 Webpage) webpageICodec +webpageDecoder :: Decoder VersionSource +webpageDecoder = do + _vurl <- getField "webpage" + _regex <- getField "regex" + _listOptions <- listOptionsDecoder + pure Webpage {..} -------------------------------------------------------------------------------- -matchHttpHeader :: VersionSource -> Maybe (Text, Text, ListOptions) -matchHttpHeader x = (,,) <$> x ^? vurl <*> x ^? regex <*> x ^? listOptions - -httpHeaderICodec :: TomlCodec (Text, Text, ListOptions) -httpHeaderICodec = - (,,) <$> text "src.httpheader" .= view _1 - <*> text "src.regex" .= view _2 - <*> listOptionsCodec .= view _3 - -httpHeaderCodec :: TomlCodec VersionSource -httpHeaderCodec = dimatch matchHttpHeader (uncurry3 HttpHeader) httpHeaderICodec +httpHeaderDecoder :: Decoder VersionSource +httpHeaderDecoder = do + _vurl <- getField "httpheader" + _regex <- getField "regex" + _listOptions <- listOptionsDecoder + pure HttpHeader {..} -------------------------------------------------------------------------------- -matchOpenVsx :: VersionSource -> Maybe (Text, Text) -matchOpenVsx x = (,) <$> x ^? ovPublisher <*> x ^? ovExtName - -openVsxICodec :: TomlCodec (Text, Text) -openVsxICodec = - textBy - (\(publisher, extName) -> publisher <> "." <> extName) - ( \t -> - case T.split (== '.') t of - -- assume we can't have '.' in extension's name - [publisher, extName] -> Right (publisher, extName) - _ -> Left "unexpected openvsx source format: it should be something like [publisher].[extName]" - ) - "src.openvsx" - -openVsxCodec :: TomlCodec VersionSource -openVsxCodec = dimatch matchOpenVsx (uncurry OpenVsx) openVsxICodec +openVsxDecoder :: Decoder VersionSource +openVsxDecoder = uncurry OpenVsx <$> getFieldWith vscodeExtensionDecoder "openvsx" -------------------------------------------------------------------------------- -matchVscodeMarketplace :: VersionSource -> Maybe (Text, Text) -matchVscodeMarketplace x = (,) <$> x ^? vsmPublisher <*> x ^? vsmExtName - -vscodeMarketplaceICodec :: TomlCodec (Text, Text) -vscodeMarketplaceICodec = - textBy - (\(publisher, extName) -> publisher <> "." <> extName) - ( \t -> - case T.split (== '.') t of - -- assume we can't have '.' in extension's name - [publisher, extName] -> Right (publisher, extName) - _ -> Left "unexpected vscode marketplace source format: it should be something like [publisher].[extName]" - ) - "src.vsmarketplace" - -vscodeMarketplaceCodec :: TomlCodec VersionSource -vscodeMarketplaceCodec = dimatch matchVscodeMarketplace (uncurry VscodeMarketplace) vscodeMarketplaceICodec +vscodeMarketplaceDecoder :: Decoder VersionSource +vscodeMarketplaceDecoder = uncurry VscodeMarketplace <$> getFieldWith vscodeExtensionDecoder "vsmarketplace" -------------------------------------------------------------------------------- -matchCmd :: VersionSource -> Maybe Text -matchCmd x = x ^? vcmd - -cmdCodec :: TomlCodec VersionSource -cmdCodec = dimatch matchCmd Cmd (text "src.cmd") +cmdDecoder :: Decoder VersionSource +cmdDecoder = Cmd <$> getField "cmd" -------------------------------------------------------------------------------- -matchContainer :: VersionSource -> Maybe (Text, ListOptions) -matchContainer x = (,) <$> x ^? vcontainer <*> x ^? listOptions - -containerCodec :: TomlCodec VersionSource -containerCodec = - dimatch matchContainer (uncurry Container) $ - Toml.pair (text "src.container") listOptionsCodec +containerDecoder :: Decoder VersionSource +containerDecoder = Container <$> getField "container" <*> listOptionsDecoder diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -9,12 +9,12 @@ import NvFetcher import NvFetcher.Options import Options.Applicative.Simple -import qualified Toml getCLIOptionsWithConfig :: IO (CLIOptions, FilePath) getCLIOptionsWithConfig = getCLIOptions $ - (,) <$> cliOptionsParser + (,) + <$> cliOptionsParser <*> strOption ( long "config" <> short 'c' @@ -28,9 +28,7 @@ main :: IO () main = do (opt, configPath) <- getCLIOptionsWithConfig - toml <- Toml.parse <$> T.readFile configPath - case toml of - Left e -> error $ T.unpack $ Toml.prettyTomlDecodeError $ Toml.ParseError e - Right x -> case parseConfig x of - Left e -> error $ T.unpack $ prettyPackageConfigParseError e - Right pkgs -> applyCliOptions def opt >>= \o -> runNvFetcherNoCLI o (optTarget opt) $ purePackageSet pkgs + raw <- T.readFile configPath + case parseConfig raw of + Left e -> error $ T.unpack $ T.unlines $ prettyPackageConfigParseError <$> e + Right pkgs -> applyCliOptions def opt >>= \o -> runNvFetcherNoCLI o (optTarget opt) $ purePackageSet pkgs diff --git a/nvfetcher.cabal b/nvfetcher.cabal --- a/nvfetcher.cabal +++ b/nvfetcher.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: nvfetcher -version: 0.6.1.0 +version: 0.6.2.0 synopsis: Generate nix sources expr for the latest version of packages @@ -26,7 +26,7 @@ common common-options build-depends: - , aeson >=1.5.6 && <2.1 + , aeson >=1.5.6 && <2.3 , aeson-pretty , base >=4.8 && <5 , binary @@ -45,7 +45,7 @@ , regex-tdfa ^>=1.3.1.1 , shake ^>=0.19 , text - , tomland ^>=1.3.2 + , toml-reader ^>=0.2 , transformers , unordered-containers @@ -86,6 +86,7 @@ main-is: Main.hs other-modules: Config + Config.Common Config.PackageFetcher Config.VersionSource diff --git a/src/NvFetcher/FetchRustGitDeps.hs b/src/NvFetcher/FetchRustGitDeps.hs --- a/src/NvFetcher/FetchRustGitDeps.hs +++ b/src/NvFetcher/FetchRustGitDeps.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -- | Copyright: (c) 2021-2022 berberman @@ -36,10 +37,9 @@ import NvFetcher.NixFetcher import NvFetcher.Types import Prettyprinter (pretty, (<+>)) +import qualified TOML as Toml import Text.Parsec import Text.Parsec.Text -import Toml (TomlCodec, (.=)) -import qualified Toml -- | Rules of fetch rust git dependencies fetchRustGitDepsRule :: Rules () @@ -47,9 +47,9 @@ addOracleCache $ \key@(FetchRustGitDepsQ fetcher lockPath) -> do putInfo . show $ "#" <+> pretty key cargoLock <- head . HMap.elems <$> extractSrc fetcher lockPath - deps <- case Toml.decode (Toml.list rustDepCodec "package") cargoLock of + deps <- case Toml.decodeWith (Toml.getFieldWith (Toml.getArrayOf rustDepDecoder) "package") cargoLock of Right r -> pure $ nubOrdOn rrawSrc r - Left err -> fail $ "Failed to parse Cargo.lock: " <> T.unpack (Toml.prettyTomlDecodeErrors err) + Left err -> fail $ "Failed to parse Cargo.lock: " <> T.unpack (Toml.renderTOMLError err) r <- parallel [ case parse gitSrcParser (T.unpack rname) src of @@ -108,9 +108,9 @@ } deriving (Show, Eq, Ord) -rustDepCodec :: TomlCodec RustDep -rustDepCodec = +rustDepDecoder :: Toml.Decoder RustDep +rustDepDecoder = RustDep - <$> Toml.text "name" .= rname - <*> Toml.diwrap (Toml.text "version") .= rversion - <*> Toml.dioptional (Toml.text "source") .= rrawSrc + <$> Toml.getField "name" + <*> (coerce @Text <$> Toml.getField "version") + <*> Toml.getFieldOpt "source" diff --git a/src/NvFetcher/Nvchecker.hs b/src/NvFetcher/Nvchecker.hs --- a/src/NvFetcher/Nvchecker.hs +++ b/src/NvFetcher/Nvchecker.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -35,11 +36,12 @@ import Control.Monad (void) import Control.Monad.Extra (fromMaybeM) +import Control.Monad.Trans.Writer.CPS import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as BS import Data.Coerce (coerce) import Data.Maybe (fromJust) -import Data.String (fromString) +import Data.Text (Text) import qualified Data.Text as T import Development.Shake import Development.Shake.Rule @@ -47,9 +49,6 @@ import NvFetcher.Types.ShakeExtras import NvFetcher.Utils import Prettyprinter (pretty, (<+>)) -import Toml (Value (Bool, Text)) -import qualified Toml -import Toml.Type.Edsl -- | Rules of nvchecker nvcheckerRule :: Rules () @@ -105,7 +104,7 @@ runNvchecker :: PackageKey -> NvcheckerOptions -> VersionSource -> Action Version runNvchecker pkg options versionSource = withTempFile $ \config -> withRetry $ do mKeyfile <- getKeyfilePath - let nvcheckerConfig = T.unpack $ Toml.pretty $ mkToml $ genNvConfig pkg options mKeyfile versionSource + let nvcheckerConfig = T.unpack $ T.unlines $ execWriter $ genNvConfig pkg options mKeyfile versionSource putVerbose $ "Generated nvchecker config for " <> show pkg <> ":" <> nvcheckerConfig writeFile' config nvcheckerConfig (CmdTime t, Stdout out, CmdLine c) <- quietly . cmd $ "nvchecker --logger json -c " <> config @@ -116,77 +115,81 @@ NvcheckerError err -> fail $ "Failed to run nvchecker: " <> T.unpack err _ -> fail $ "Failed to parse output from nvchecker: " <> out -genNvConfig :: PackageKey -> NvcheckerOptions -> Maybe FilePath -> VersionSource -> TDSL +type BuildTOML = Writer [Text] () + +genNvConfig :: PackageKey -> NvcheckerOptions -> Maybe FilePath -> VersionSource -> BuildTOML genNvConfig pkg options mKeyfile versionSource = case mKeyfile of Just keyfile -> do table "__config__" $ - "keyfile" =: Text (T.pack keyfile) + "keyfile" =: T.pack keyfile _ -> pure () >> table - (fromString $ T.unpack $ coerce pkg) + (coerce pkg) ( do genVersionSource versionSource genOptions options ) where - key =:? (Just x) = key =: Text x + key =: x = tell [key <> " = " <> T.pack (show $ T.unpack x)] + key =:? (Just x) = key =: x _ =:? _ = pure () + table t m = tell ["[" <> t <> "]"] >> m >> tell [""] genVersionSource = \case GitHubRelease {..} -> do "source" =: "github" - "github" =: Text (_owner <> "/" <> _repo) - "use_latest_release" =: Bool True + "github" =: (_owner <> "/" <> _repo) + "use_latest_release" =: "true" GitHubTag {..} -> do "source" =: "github" - "github" =: Text (_owner <> "/" <> _repo) - "use_max_tag" =: Bool True + "github" =: (_owner <> "/" <> _repo) + "use_max_tag" =: "true" genListOptions _listOptions Git {..} -> do "source" =: "git" - "git" =: Text _vurl + "git" =: _vurl "branch" =:? coerce _vbranch - "use_commit" =: Bool True + "use_commit" =: "true" Aur {..} -> do "source" =: "aur" - "aur" =: Text _aur - "strip_release" =: Bool True + "aur" =: _aur + "strip_release" =: "true" ArchLinux {..} -> do "source" =: "archpkg" - "archpkg" =: Text _archpkg - "strip_release" =: Bool True + "archpkg" =: _archpkg + "strip_release" =: "true" Pypi {..} -> do "source" =: "pypi" - "pypi" =: Text _pypi + "pypi" =: _pypi Manual {..} -> do "source" =: "manual" - "manual" =: Text _manual + "manual" =: _manual Repology {..} -> do "source" =: "repology" - "repology" =: Text _repology - "repo" =: Text _repo + "repology" =: _repology + "repo" =: _repo Webpage {..} -> do "source" =: "regex" - "url" =: Text _vurl - "regex" =: Text _regex + "url" =: _vurl + "regex" =: _regex genListOptions _listOptions HttpHeader {..} -> do "source" =: "httpheader" - "url" =: Text _vurl - "regex" =: Text _regex + "url" =: _vurl + "regex" =: _regex genListOptions _listOptions OpenVsx {..} -> do "source" =: "openvsx" - "openvsx" =: Text (_ovPublisher <> "." <> _ovExtName) + "openvsx" =: (_ovPublisher <> "." <> _ovExtName) VscodeMarketplace {..} -> do "source" =: "vsmarketplace" - "vsmarketplace" =: Text (_vsmPublisher <> "." <> _vsmExtName) + "vsmarketplace" =: (_vsmPublisher <> "." <> _vsmExtName) Cmd {..} -> do "source" =: "cmd" - "cmd" =: Text _vcmd + "cmd" =: _vcmd Container {..} -> do "source" =: "container" - "container" =: Text _vcontainer + "container" =: _vcontainer genListOptions _listOptions genListOptions ListOptions {..} = do "include_regex" =:? _includeRegex