diff --git a/package.yaml b/package.yaml index 14843a4..6e9d272 100644 --- a/package.yaml +++ b/package.yaml @@ -42,6 +42,7 @@ dependencies: - filepath - github - hex + - http-client-tls - http-conduit - iso8601-time - lifted-base @@ -54,6 +55,8 @@ dependencies: - polysemy - polysemy-plugin - regex-applicative-text + - servant + - servant-client - sqlite-simple - template-haskell - temporary @@ -62,6 +65,7 @@ dependencies: - transformers - typed-process - unix + - unordered-containers - vector - versions - xdg-basedir diff --git a/src/Main.hs b/src/Main.hs index f687b09..3f7bac3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -5,8 +5,6 @@ module Main where -import OurPrelude - import Control.Applicative ((<**>)) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -14,17 +12,19 @@ import DeleteMerged (deleteDone) import NVD (withVulnDB) import qualified Nix import qualified Options.Applicative as O -import System.IO (BufferMode(..), hSetBuffering, stderr, stdout) +import OurPrelude +import qualified Repology +import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) import System.Posix.Env (setEnv) import Update (cveAll, cveReport, sourceGithubAll, updateAll) -import Utils (Options(..), UpdateEnv(..), setupNixpkgs) +import Utils (Options (..), UpdateEnv (..), setupNixpkgs) default (T.Text) -newtype UpdateOptions = - UpdateOptions - { dry :: Bool - } +newtype UpdateOptions + = UpdateOptions + { dry :: Bool + } data Command = Update UpdateOptions @@ -33,63 +33,75 @@ data Command | UpdateVulnDB | CheckAllVulnerable | SourceGithub + | FetchRepology | CheckVulnerable Text Text Text updateOptionsParser :: O.Parser Command updateOptionsParser = - Update . UpdateOptions <$> - O.switch - (O.long "dry-run" <> - O.help - "Do everything except actually pushing the updates to the remote repository") + Update . UpdateOptions + <$> O.switch + ( O.long "dry-run" + <> O.help + "Do everything except actually pushing the updates to the remote repository" + ) commandParser :: O.Parser Command commandParser = O.hsubparser - (O.command - "update" - (O.info updateOptionsParser (O.progDesc "Update packages")) <> - O.command - "delete-done" - (O.info - (pure DeleteDone) - (O.progDesc "Deletes branches from PRs that were merged or closed")) <> - O.command - "version" - (O.info - (pure Version) - (O.progDesc - "Displays version information for nixpkgs-update and dependencies")) <> - O.command - "update-vulnerability-db" - (O.info - (pure UpdateVulnDB) - (O.progDesc "Updates the vulnerability database")) <> - O.command - "check-vulnerable" - (O.info checkVulnerable (O.progDesc "checks if something is vulnerable")) <> - O.command - "check-all-vulnerable" - (O.info - (pure CheckAllVulnerable) - (O.progDesc "checks all packages to update for vulnerabilities")) <> - O.command - "source-github" - (O.info (pure SourceGithub) (O.progDesc "looks for updates on GitHub"))) + ( O.command + "update" + (O.info updateOptionsParser (O.progDesc "Update packages")) + <> O.command + "delete-done" + ( O.info + (pure DeleteDone) + (O.progDesc "Deletes branches from PRs that were merged or closed") + ) + <> O.command + "version" + ( O.info + (pure Version) + ( O.progDesc + "Displays version information for nixpkgs-update and dependencies" + ) + ) + <> O.command + "update-vulnerability-db" + ( O.info + (pure UpdateVulnDB) + (O.progDesc "Updates the vulnerability database") + ) + <> O.command + "check-vulnerable" + (O.info checkVulnerable (O.progDesc "checks if something is vulnerable")) + <> O.command + "check-all-vulnerable" + ( O.info + (pure CheckAllVulnerable) + (O.progDesc "checks all packages to update for vulnerabilities") + ) + <> O.command + "source-github" + (O.info (pure SourceGithub) (O.progDesc "looks for updates on GitHub")) + <> O.command + "fetch-repology" + (O.info (pure FetchRepology) (O.progDesc "fetches update from Repology and prints them to stdout")) + ) checkVulnerable :: O.Parser Command checkVulnerable = - CheckVulnerable <$> O.strArgument (O.metavar "PRODUCT_ID") <*> - O.strArgument (O.metavar "OLD_VERSION") <*> - O.strArgument (O.metavar "NEW_VERSION") + CheckVulnerable <$> O.strArgument (O.metavar "PRODUCT_ID") + <*> O.strArgument (O.metavar "OLD_VERSION") + <*> O.strArgument (O.metavar "NEW_VERSION") programInfo :: O.ParserInfo Command programInfo = O.info (commandParser <**> O.helper) - (O.fullDesc <> - O.progDesc "Update packages in the Nixpkgs repository" <> - O.header "nixpkgs-update") + ( O.fullDesc + <> O.progDesc "Update packages in the Nixpkgs repository" + <> O.header "nixpkgs-update" + ) getGithubToken :: IO Text getGithubToken = T.strip <$> T.readFile "github_token.txt" @@ -135,3 +147,4 @@ main = do setupNixpkgs token setEnv "GITHUB_TOKEN" (T.unpack token) True sourceGithubAll (Options False token) updates + FetchRepology -> Repology.fetch diff --git a/src/Repology.hs b/src/Repology.hs new file mode 100644 index 0000000..cdf2602 --- /dev/null +++ b/src/Repology.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Repology where + +import Control.Category ((>>>)) +import Control.Error +import Control.Monad.IO.Class +import Data.Aeson +import Data.HashMap.Strict +import Data.List +import Data.Maybe +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text.IO +import Data.Vector (Vector) +import qualified Data.Vector as V +import GHC.Generics +import Network.HTTP.Client.TLS (newTlsManager) +import Servant.API +import Servant.Client (ClientEnv (ClientEnv), ClientM, runClientM, BaseUrl(..), Scheme(..), client) +import System.IO + +baseUrl :: BaseUrl +baseUrl = BaseUrl Https "repology.org" 443 "/api/v1" + +type Metapackage = Vector Package + +compareMetapackage :: Metapackage -> Metapackage -> Ordering +compareMetapackage ps1 ps2 = compareMetapackage' (ps1 V.!? 0) (ps2 V.!? 0) + where + compareMetapackage' (Just p1) (Just p2) = compare (name p1) (name p2) + compareMetapackage' Nothing (Just _) = LT + compareMetapackage' (Just _) Nothing = GT + compareMetapackage' _ _ = EQ + +type Metapackages = HashMap Text Metapackage + +type API = + "metapackage" :> Capture "metapackage_name" Text :> Get '[JSON] Metapackage :<|> "metapackages" :> QueryParam "search" Text :> QueryParam "maintainers" Text :> QueryParam "category" Text :> QueryParam "inrepo" Text :> QueryParam "outdated" Bool :> QueryParam "notinrepo" Text :> QueryParam "minspread" Integer :> QueryParam "maxspread" Integer :> Get '[JSON] Metapackages :<|> "metapackages" :> Capture "name" Text :> QueryParam "search" Text :> QueryParam "maintainers" Text :> QueryParam "category" Text :> QueryParam "inrepo" Text :> QueryParam "outdated" Bool :> QueryParam "notinrepo" Text :> QueryParam "minspread" Integer :> QueryParam "maxspread" Integer :> Get '[JSON] Metapackages + +data Package + = Package + { repo :: Text, + name :: Maybe Text, + version :: Text, + origversion :: Maybe Text, + status :: Maybe Text, + summary :: Maybe Text, + categories :: Maybe (Vector Text), + licenses :: Maybe (Vector Text), + www :: Maybe (Vector Text), + downloads :: Maybe (Vector Text) + } + deriving (Eq, Show, Generic, FromJSON) + +api :: Proxy API +api = Proxy + +metapackage :: Text -> ClientM (Vector Package) + +metapackages :: + Maybe Text -> + Maybe Text -> + Maybe Text -> + Maybe Text -> + Maybe Bool -> + Maybe Text -> + Maybe Integer -> + Maybe Integer -> + ClientM Metapackages + +metapackages' :: + Text -> + Maybe Text -> + Maybe Text -> + Maybe Text -> + Maybe Text -> + Maybe Bool -> + Maybe Text -> + Maybe Integer -> + Maybe Integer -> + ClientM Metapackages +metapackage :<|> metapackages :<|> metapackages' = client api + +-- type PagingResult = PagingResult (Vector Metapackage, ClientM PagingResult) +-- metapackages :: Text -> ClientM PagingResult +-- metapackages n = do +-- m <- ms n +-- return (lastMetapackageName m, sortedMetapackages m) +lastMetapackageName :: Metapackages -> Maybe Text +lastMetapackageName = keys >>> sort >>> Prelude.reverse >>> headMay + +sortedMetapackages :: Metapackages -> Vector Metapackage +sortedMetapackages = elems >>> sortBy compareMetapackage >>> V.fromList + +nixRepo :: Text +nixRepo = "nix_unstable" + +nixOutdated :: ClientM Metapackages +nixOutdated = + metapackages + Nothing + Nothing + Nothing + (Just nixRepo) + (Just True) + Nothing + Nothing + Nothing + +nextNixOutdated :: Text -> ClientM Metapackages +nextNixOutdated n = + metapackages' + n + Nothing + Nothing + Nothing + (Just nixRepo) + (Just True) + Nothing + Nothing + Nothing + +outdatedForRepo :: Text -> Vector Package -> Maybe Package +outdatedForRepo r = + V.find (\p -> (status p) == Just "outdated" && (repo p) == r) + +newest :: Vector Package -> Maybe Package +newest = V.find (\p -> (status p) == Just "newest") + +dropMaybes :: [(Maybe Package, Maybe Package)] -> [(Package, Package)] +dropMaybes = Data.List.foldl' twoJusts [] + where + twoJusts a (Just o, Just n) = (o, n) : a + twoJusts a _ = a + +getUpdateInfo :: ClientM (Maybe Text, Bool, Vector (Package, Package)) +getUpdateInfo = do + outdated <- nixOutdated + let ms = elems outdated + let nixPackages = fmap (outdatedForRepo nixRepo) ms + let newestPackages = fmap newest ms + let nixNew = dropMaybes (zip nixPackages newestPackages) + let mLastName = lastMetapackageName outdated + liftIO $ hPutStrLn stderr $ show mLastName + liftIO $ hPutStrLn stderr $ show (length ms) + return (mLastName, length ms /= 1, V.fromList nixNew) + +-- let sorted = sortBy (\(p1,_) (p2,_) -> compare (name p1) (name p2)) nixNew +getNextUpdateInfo :: + Text -> ClientM (Maybe Text, Bool, Vector (Package, Package)) +getNextUpdateInfo n = do + outdated <- nextNixOutdated n + let ms = elems outdated + let nixPackages = fmap (outdatedForRepo nixRepo) ms + let newestPackages = fmap newest ms + let nixNew = dropMaybes (zip nixPackages newestPackages) + let mLastName = lastMetapackageName outdated + liftIO $ hPutStrLn stderr $ show mLastName + liftIO $ hPutStrLn stderr $ show (length ms) + return (mLastName, length ms /= 1, V.fromList nixNew) + +-- let sorted = sortBy (\(p1,_) (p2,_) -> compare (name p1) (name p2)) nixNew +updateInfo :: (Package, Package) -> Maybe Text +updateInfo (outdated, newestP) + | isJust (name outdated) = + Just $ + fromJust (name outdated) <> " " <> version outdated <> " " <> version newestP +updateInfo _ = Nothing + +justs :: Vector (Maybe a) -> Vector a +justs = V.concatMap (maybeToList >>> V.fromList) + +moreNixUpdateInfo :: + (Maybe Text, Vector (Package, Package)) -> + ClientM (Vector (Package, Package)) +moreNixUpdateInfo (Nothing, acc) = do + (mLastName, moreWork, newNix) <- getUpdateInfo + liftIO + $ V.sequence_ + $ fmap Data.Text.IO.putStrLn + $ justs + $ fmap updateInfo newNix + if moreWork + then moreNixUpdateInfo (mLastName, newNix V.++ acc) + else return acc +moreNixUpdateInfo (Just pname, acc) = do + (mLastName, moreWork, newNix) <- getNextUpdateInfo pname + liftIO + $ V.sequence_ + $ fmap Data.Text.IO.putStrLn + $ justs + $ fmap updateInfo newNix + if moreWork + then moreNixUpdateInfo (mLastName, newNix V.++ acc) + else return acc + +allNixUpdateInfo :: ClientM (Vector (Package, Package)) +allNixUpdateInfo = moreNixUpdateInfo (Nothing, V.empty) + +fetch :: IO () +fetch = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + liftIO $ hPutStrLn stderr "starting" + manager' <- newTlsManager + e <- runClientM allNixUpdateInfo (ClientEnv manager' baseUrl Nothing) + case e of + Left ce -> liftIO $ hPutStrLn stderr $ show ce + Right _ -> liftIO $ hPutStrLn stderr $ "done" + return ()