integrate Repology fetching code

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

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

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 ()