Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-26 02:11:53 +00:00
Code Issues Packages Projects Releases Wiki Activity

adds list-unindexed

Browse Source
This commit is contained in:
Keagan McClelland
2022-05-26 17:27:13 -06:00
parent 6a2a5f72fe
commit 73372e8e75
4 changed files with 92 additions and 4 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
config/routes
View File

@@ -20,4 +20,4 @@
-- ADMIN API V0 -- ADMIN API V0
/admin/v0/upload PkgUploadR POST !admin /admin/v0/upload PkgUploadR POST !admin
/admin/v0/index PkgIndexR POST !admin /admin/v0/index PkgIndexR POST !admin
/admin/v0/deindex PkgDeindexR POST !admin /admin/v0/deindex PkgDeindexR GET POST !admin

37
src/Cli/Cli.hs
View File

@@ -4,6 +4,8 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE UndecidableInstances #-}
module Cli.Cli module Cli.Cli
( cliMain ( cliMain
@@ -23,7 +25,9 @@ import Control.Monad.Logger ( LogLevel(..)
import Crypto.Hash ( SHA256(SHA256) import Crypto.Hash ( SHA256(SHA256)
, hashWith , hashWith
) )
import Data.Aeson ( eitherDecodeStrict ) import Data.Aeson ( FromJSON
, eitherDecodeStrict
)
import Data.ByteArray.Encoding ( Base(..) import Data.ByteArray.Encoding ( Base(..)
, convertToBase , convertToBase
) )
@@ -40,7 +44,9 @@ import Data.HashMap.Internal.Strict ( HashMap
) )
import Dhall hiding ( void ) import Dhall hiding ( void )
import Dhall.Core ( pretty ) import Dhall.Core ( pretty )
import Handler.Admin ( IndexPkgReq(IndexPkgReq) ) import Handler.Admin ( IndexPkgReq(IndexPkgReq)
, PackageList(..)
)
import Lib.External.AppMgr ( sourceManifest ) import Lib.External.AppMgr ( sourceManifest )
import Lib.Types.AppIndex ( PackageManifest import Lib.Types.AppIndex ( PackageManifest
( PackageManifest ( PackageManifest
@@ -58,6 +64,7 @@ import Network.HTTP.Client.Conduit ( StreamFileStatus(StreamFileSta
) )
import Network.HTTP.Client.TLS ( newTlsManager ) import Network.HTTP.Client.TLS ( newTlsManager )
import Network.HTTP.Simple ( getResponseBody import Network.HTTP.Simple ( getResponseBody
, httpJSON
, httpLBS , httpLBS
, setRequestBody , setRequestBody
, setRequestBodyJSON , setRequestBodyJSON
@@ -105,6 +112,8 @@ import Startlude ( ($)
, decodeUtf8 , decodeUtf8
, exitWith , exitWith
, filter , filter
, flip
, fmap
, for_ , for_
, fromIntegral , fromIntegral
, fromMaybe , fromMaybe
@@ -135,6 +144,7 @@ import System.ProgressBar ( Progress(..)
import Yesod ( logError import Yesod ( logError
, logWarn , logWarn
) )
import Yesod.Core ( FromJSON(parseJSON) )
data Upload = Upload data Upload = Upload
{ publishRepoName :: String { publishRepoName :: String
@@ -178,6 +188,7 @@ data Command
| CmdRegList | CmdRegList
| CmdUpload Upload | CmdUpload Upload
| CmdIndex String String Version Bool | CmdIndex String String Version Bool
| CmdListUnindexed String
deriving Show deriving Show
cfgLocation :: IO FilePath cfgLocation :: IO FilePath
@@ -251,6 +262,13 @@ parseIndexHelper b =
<*> strArgument (metavar "VERSION") <*> strArgument (metavar "VERSION")
<*> pure b <*> 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 :: Parser Command
parseCommand = parseCommand =
(parseInit $> CmdInit) (parseInit $> CmdInit)
@@ -258,6 +276,7 @@ parseCommand =
<|> subparser (command "reg" (info reg $ progDesc "Manage configured registries") <> metavar "reg") <|> subparser (command "reg" (info reg $ progDesc "Manage configured registries") <> metavar "reg")
<|> parseIndex <|> parseIndex
<|> parseDeindex <|> parseDeindex
<|> (CmdListUnindexed <$> parseListUnindexed)
where reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList) where reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList)
opts :: ParserInfo Command opts :: ParserInfo Command
@@ -273,6 +292,7 @@ cliMain =
CmdRegList -> regLs CmdRegList -> regLs
CmdUpload up -> upload up CmdUpload up -> upload up
CmdIndex name pkg v shouldIndex -> if shouldIndex then index name pkg v else deindex name pkg v CmdIndex name pkg v shouldIndex -> if shouldIndex then index name pkg v else deindex name pkg v
CmdListUnindexed name -> listUnindexed name
) )
init :: IO () init :: IO ()
@@ -388,6 +408,19 @@ deindex name pkg v = do
res <- getResponseBody <$> httpLBS withBody res <- getResponseBody <$> httpLBS withBody
if LB.null res then pure () else $logError (decodeUtf8 $ LB.toStrict res) *> exitWith (ExitFailure 1) 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 :: String -> IO PublishCfgRepo
findNameInCfg name = do findNameInCfg name = do
loc <- cfgLocation loc <- cfgLocation

50
src/Handler/Admin.hs
View File

@@ -19,15 +19,29 @@ import Data.Aeson ( (.:)
, object , object
, withObject , withObject
) )
import Data.HashMap.Internal.Strict ( HashMap
, differenceWith
, filter
, fromListWith
)
import Data.List ( (\\)
, null
)
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
( i ) ( i )
import Database.Persist ( insert_ ) import Database.Persist ( entityKey
, entityVal
, insert_
, selectList
)
import Database.Persist.Postgresql ( runSqlPoolNoTransaction ) import Database.Persist.Postgresql ( runSqlPoolNoTransaction )
import Database.Queries ( upsertPackageVersion ) import Database.Queries ( upsertPackageVersion )
import Foundation import Foundation
import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot) import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot)
, extractPkg , extractPkg
, getManifestLocation , getManifestLocation
, getPackages
, getVersionsFor
) )
import Lib.Types.AppIndex ( PackageManifest(..) import Lib.Types.AppIndex ( PackageManifest(..)
, PkgId(unPkgId) , PkgId(unPkgId)
@@ -35,13 +49,18 @@ import Lib.Types.AppIndex ( PackageManifest(..)
import Lib.Types.Emver ( Version(..) ) import Lib.Types.Emver ( Version(..) )
import Model ( Key(AdminKey, PkgRecordKey, VersionRecordKey) import Model ( Key(AdminKey, PkgRecordKey, VersionRecordKey)
, Upload(..) , Upload(..)
, VersionRecord(versionRecordNumber, versionRecordPkgId)
, unPkgRecordKey
) )
import Network.HTTP.Types ( status404 import Network.HTTP.Types ( status404
, status500 , status500
) )
import Startlude ( ($) import Startlude ( ($)
, (&&&)
, (.) , (.)
, (<$>) , (<$>)
, (<<$>>)
, (<>)
, Applicative(pure) , Applicative(pure)
, Bool(..) , Bool(..)
, Eq , Eq
@@ -50,15 +69,22 @@ import Startlude ( ($)
, Show , Show
, SomeException(..) , SomeException(..)
, asum , asum
, fmap
, getCurrentTime , getCurrentTime
, guard
, guarded
, hush , hush
, isNothing , isNothing
, liftIO , liftIO
, not
, panic
, replicate , replicate
, show , show
, throwIO , throwIO
, toS , toS
, traverse
, when , when
, zip
) )
import System.FilePath ( (<.>) import System.FilePath ( (<.>)
, (</>) , (</>)
@@ -83,6 +109,7 @@ import Yesod ( ToJSON(..)
, runDB , runDB
) )
import Yesod.Auth ( YesodAuth(maybeAuthId) ) import Yesod.Auth ( YesodAuth(maybeAuthId) )
import Yesod.Core.Types ( JSONResponse(JSONResponse) )
postPkgUploadR :: Handler () postPkgUploadR :: Handler ()
postPkgUploadR = do postPkgUploadR = do
@@ -141,3 +168,24 @@ postPkgDeindexR :: Handler ()
postPkgDeindexR = do postPkgDeindexR = do
IndexPkgReq {..} <- requireCheckJsonBody IndexPkgReq {..} <- requireCheckJsonBody
runDB $ delete (VersionRecordKey (PkgRecordKey indexPkgReqId) indexPkgReqVersion) 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
(.*) = (.) . (.)

7
src/Lib/PkgRepository.hs
View File

@@ -108,6 +108,7 @@ import Startlude ( ($)
, snd , snd
, sortBy , sortBy
, throwIO , throwIO
, toS
, void , void
) )
import System.FSNotify ( ActionPredicate import System.FSNotify ( ActionPredicate
@@ -163,6 +164,12 @@ newtype EosRepo = EosRepo
{ eosRepoFileRoot :: FilePath { 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 :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> m [Version]
getVersionsFor pkg = do getVersionsFor pkg = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot