From db3beadd6c6072c8abace61351c952a8fe905e89 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Thu, 26 May 2022 17:27:13 -0600 Subject: [PATCH] adds list-unindexed --- config/routes | 2 +- src/Cli/Cli.hs | 37 +++++++++++++++++++++++++++-- src/Handler/Admin.hs | 50 +++++++++++++++++++++++++++++++++++++++- src/Lib/PkgRepository.hs | 7 ++++++ 4 files changed, 92 insertions(+), 4 deletions(-) diff --git a/config/routes b/config/routes index 421c6b9..f9fe684 100644 --- a/config/routes +++ b/config/routes @@ -20,4 +20,4 @@ -- ADMIN API V0 /admin/v0/upload PkgUploadR POST !admin /admin/v0/index PkgIndexR POST !admin -/admin/v0/deindex PkgDeindexR POST !admin \ No newline at end of file +/admin/v0/deindex PkgDeindexR GET POST !admin \ No newline at end of file diff --git a/src/Cli/Cli.hs b/src/Cli/Cli.hs index a0aa16a..7537003 100644 --- a/src/Cli/Cli.hs +++ b/src/Cli/Cli.hs @@ -4,6 +4,8 @@ {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE UndecidableInstances #-} module Cli.Cli ( cliMain @@ -23,7 +25,9 @@ import Control.Monad.Logger ( LogLevel(..) import Crypto.Hash ( SHA256(SHA256) , hashWith ) -import Data.Aeson ( eitherDecodeStrict ) +import Data.Aeson ( FromJSON + , eitherDecodeStrict + ) import Data.ByteArray.Encoding ( Base(..) , convertToBase ) @@ -40,7 +44,9 @@ import Data.HashMap.Internal.Strict ( HashMap ) import Dhall hiding ( void ) import Dhall.Core ( pretty ) -import Handler.Admin ( IndexPkgReq(IndexPkgReq) ) +import Handler.Admin ( IndexPkgReq(IndexPkgReq) + , PackageList(..) + ) import Lib.External.AppMgr ( sourceManifest ) import Lib.Types.AppIndex ( PackageManifest ( PackageManifest @@ -58,6 +64,7 @@ import Network.HTTP.Client.Conduit ( StreamFileStatus(StreamFileSta ) import Network.HTTP.Client.TLS ( newTlsManager ) import Network.HTTP.Simple ( getResponseBody + , httpJSON , httpLBS , setRequestBody , setRequestBodyJSON @@ -105,6 +112,8 @@ import Startlude ( ($) , decodeUtf8 , exitWith , filter + , flip + , fmap , for_ , fromIntegral , fromMaybe @@ -135,6 +144,7 @@ import System.ProgressBar ( Progress(..) import Yesod ( logError , logWarn ) +import Yesod.Core ( FromJSON(parseJSON) ) data Upload = Upload { publishRepoName :: String @@ -178,6 +188,7 @@ data Command | CmdRegList | CmdUpload Upload | CmdIndex String String Version Bool + | CmdListUnindexed String deriving Show cfgLocation :: IO FilePath @@ -251,6 +262,13 @@ parseIndexHelper b = <*> strArgument (metavar "VERSION") <*> pure b +parseListUnindexed :: Parser String +parseListUnindexed = subparser $ command + "list-unindexed" + ( info (strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")) + $ progDesc "Lists unindexed package versions on target registry" + ) + parseCommand :: Parser Command parseCommand = (parseInit $> CmdInit) @@ -258,6 +276,7 @@ parseCommand = <|> subparser (command "reg" (info reg $ progDesc "Manage configured registries") <> metavar "reg") <|> parseIndex <|> parseDeindex + <|> (CmdListUnindexed <$> parseListUnindexed) where reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList) opts :: ParserInfo Command @@ -273,6 +292,7 @@ cliMain = CmdRegList -> regLs CmdUpload up -> upload up CmdIndex name pkg v shouldIndex -> if shouldIndex then index name pkg v else deindex name pkg v + CmdListUnindexed name -> listUnindexed name ) init :: IO () @@ -388,6 +408,19 @@ deindex name pkg v = do res <- getResponseBody <$> httpLBS withBody if LB.null res then pure () else $logError (decodeUtf8 $ LB.toStrict res) *> exitWith (ExitFailure 1) + +listUnindexed :: String -> IO () +listUnindexed name = do + PublishCfgRepo {..} <- findNameInCfg name + noBody <- + parseRequest (show publishCfgRepoLocation <> "/admin/v0/deindex") + <&> setRequestHeaders [("accept", "application/json")] + <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) + PackageList {..} <- getResponseBody <$> httpJSON noBody + void $ flip traverseWithKey unPackageList $ \k v -> do + putChunk (chunk (unPkgId k <> ": ") & fore blue) + putChunkLn $ chunk (show v) & fore yellow + findNameInCfg :: String -> IO PublishCfgRepo findNameInCfg name = do loc <- cfgLocation diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 32646e9..9045126 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -19,15 +19,29 @@ import Data.Aeson ( (.:) , object , withObject ) +import Data.HashMap.Internal.Strict ( HashMap + , differenceWith + , filter + , fromListWith + ) +import Data.List ( (\\) + , null + ) import Data.String.Interpolate.IsString ( i ) -import Database.Persist ( insert_ ) +import Database.Persist ( entityKey + , entityVal + , insert_ + , selectList + ) import Database.Persist.Postgresql ( runSqlPoolNoTransaction ) import Database.Queries ( upsertPackageVersion ) import Foundation import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot) , extractPkg , getManifestLocation + , getPackages + , getVersionsFor ) import Lib.Types.AppIndex ( PackageManifest(..) , PkgId(unPkgId) @@ -35,13 +49,18 @@ import Lib.Types.AppIndex ( PackageManifest(..) import Lib.Types.Emver ( Version(..) ) import Model ( Key(AdminKey, PkgRecordKey, VersionRecordKey) , Upload(..) + , VersionRecord(versionRecordNumber, versionRecordPkgId) + , unPkgRecordKey ) import Network.HTTP.Types ( status404 , status500 ) import Startlude ( ($) + , (&&&) , (.) , (<$>) + , (<<$>>) + , (<>) , Applicative(pure) , Bool(..) , Eq @@ -50,15 +69,22 @@ import Startlude ( ($) , Show , SomeException(..) , asum + , fmap , getCurrentTime + , guard + , guarded , hush , isNothing , liftIO + , not + , panic , replicate , show , throwIO , toS + , traverse , when + , zip ) import System.FilePath ( (<.>) , () @@ -83,6 +109,7 @@ import Yesod ( ToJSON(..) , runDB ) import Yesod.Auth ( YesodAuth(maybeAuthId) ) +import Yesod.Core.Types ( JSONResponse(JSONResponse) ) postPkgUploadR :: Handler () postPkgUploadR = do @@ -141,3 +168,24 @@ postPkgDeindexR :: Handler () postPkgDeindexR = do IndexPkgReq {..} <- requireCheckJsonBody runDB $ delete (VersionRecordKey (PkgRecordKey indexPkgReqId) indexPkgReqVersion) + +newtype PackageList = PackageList { unPackageList :: HashMap PkgId [Version] } +instance FromJSON PackageList where + parseJSON = fmap PackageList . parseJSON +instance ToJSON PackageList where + toJSON = toJSON . unPackageList + +getPkgDeindexR :: Handler (JSONResponse PackageList) +getPkgDeindexR = do + dbList <- + runDB + $ (unPkgRecordKey . versionRecordPkgId &&& (: []) . versionRecordNumber) + . entityVal + <<$>> selectList [] [] + let inDb = fromListWith (<>) dbList + pkgsOnDisk <- getPackages + onDisk <- fromListWith (<>) . zip pkgsOnDisk <$> traverse getVersionsFor pkgsOnDisk + pure . JSONResponse . PackageList $ filter (not . null) $ differenceWith (guarded null .* (\\)) onDisk inDb + +(.*) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c +(.*) = (.) . (.) diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index 1d9a056..9d21ca2 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -108,6 +108,7 @@ import Startlude ( ($) , snd , sortBy , throwIO + , toS , void ) import System.FSNotify ( ActionPredicate @@ -163,6 +164,12 @@ newtype EosRepo = EosRepo { eosRepoFileRoot :: FilePath } +getPackages :: (MonadIO m, MonadReader r m, Has PkgRepo r) => m [PkgId] +getPackages = do + root <- asks pkgRepoFileRoot + paths <- listDirectory root + pure $ PkgId . toS <$> paths + getVersionsFor :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> m [Version] getVersionsFor pkg = do root <- asks pkgRepoFileRoot