mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 02:11:53 +00:00
adds category managment to embassy-publish and admin API
This commit is contained in:
Keagan McClelland
@@ -20,4 +20,6 @@
|
||||
-- ADMIN API V0
|
||||
/admin/v0/upload PkgUploadR POST !admin
|
||||
/admin/v0/index PkgIndexR POST !admin
|
||||
/admin/v0/deindex PkgDeindexR GET POST !admin
|
||||
/admin/v0/deindex PkgDeindexR GET POST !admin
|
||||
/admin/v0/category/#Text CategoryR POST DELETE !admin
|
||||
/admin/v0/categorize/#Text/#PkgId PkgCategorizeR POST DELETE !admin
|
||||
@@ -151,29 +151,16 @@ import qualified Database.Persist.Migration.Postgres
|
||||
import Database.Persist.Sql ( SqlBackend )
|
||||
import Foundation ( Handler
|
||||
, RegistryCtx(..)
|
||||
, Route
|
||||
( AppManifestR
|
||||
, AppR
|
||||
, EosR
|
||||
, EosVersionR
|
||||
, ErrorLogsR
|
||||
, IconsR
|
||||
, InfoR
|
||||
, InstructionsR
|
||||
, LicenseR
|
||||
, PackageListR
|
||||
, PkgDeindexR
|
||||
, PkgIndexR
|
||||
, PkgUploadR
|
||||
, PkgVersionR
|
||||
, ReleaseNotesR
|
||||
, VersionLatestR
|
||||
)
|
||||
, Route(..)
|
||||
, resourcesRegistryCtx
|
||||
, setWebProcessThreadId
|
||||
, unsafeHandler
|
||||
)
|
||||
import Handler.Admin ( getPkgDeindexR
|
||||
import Handler.Admin ( deleteCategoryR
|
||||
, deletePkgCategorizeR
|
||||
, getPkgDeindexR
|
||||
, postCategoryR
|
||||
, postPkgCategorizeR
|
||||
, postPkgDeindexR
|
||||
, postPkgIndexR
|
||||
, postPkgUploadR
|
||||
|
||||
155
src/Cli/Cli.hs
155
src/Cli/Cli.hs
@@ -1,11 +1,12 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Cli.Cli
|
||||
( cliMain
|
||||
@@ -25,7 +26,9 @@ import Control.Monad.Logger ( LogLevel(..)
|
||||
import Crypto.Hash ( SHA256(SHA256)
|
||||
, hashWith
|
||||
)
|
||||
import Data.Aeson ( eitherDecodeStrict )
|
||||
import Data.Aeson ( ToJSON
|
||||
, eitherDecodeStrict
|
||||
)
|
||||
import Data.ByteArray.Encoding ( Base(..)
|
||||
, convertToBase
|
||||
)
|
||||
@@ -41,6 +44,8 @@ import Data.HashMap.Internal.Strict ( HashMap
|
||||
, lookup
|
||||
, traverseWithKey
|
||||
)
|
||||
import Data.String.Interpolate.IsString
|
||||
( i )
|
||||
import Data.Text ( toLower )
|
||||
import Dhall ( Encoder(embed)
|
||||
, FromDhall(..)
|
||||
@@ -51,7 +56,8 @@ import Dhall ( Encoder(embed)
|
||||
, inputFile
|
||||
)
|
||||
import Dhall.Core ( pretty )
|
||||
import Handler.Admin ( IndexPkgReq(IndexPkgReq)
|
||||
import Handler.Admin ( AddCategoryReq(AddCategoryReq)
|
||||
, IndexPkgReq(IndexPkgReq)
|
||||
, PackageList(..)
|
||||
)
|
||||
import Lib.External.AppMgr ( sourceManifest )
|
||||
@@ -88,6 +94,7 @@ import Options.Applicative ( (<$>)
|
||||
, Applicative((<*>), liftA2, pure)
|
||||
, Parser
|
||||
, ParserInfo
|
||||
, auto
|
||||
, command
|
||||
, execParser
|
||||
, fullDesc
|
||||
@@ -98,6 +105,7 @@ import Options.Applicative ( (<$>)
|
||||
, long
|
||||
, mappend
|
||||
, metavar
|
||||
, option
|
||||
, optional
|
||||
, progDesc
|
||||
, short
|
||||
@@ -131,6 +139,7 @@ import Startlude ( ($)
|
||||
, ExitCode(..)
|
||||
, FilePath
|
||||
, IO
|
||||
, Int
|
||||
, IsString(..)
|
||||
, Maybe(..)
|
||||
, Monad((>>=))
|
||||
@@ -151,6 +160,7 @@ import Startlude ( ($)
|
||||
, fromMaybe
|
||||
, fst
|
||||
, headMay
|
||||
, not
|
||||
, panic
|
||||
, show
|
||||
, snd
|
||||
@@ -224,6 +234,10 @@ data Command
|
||||
| CmdUpload !Upload
|
||||
| CmdIndex !String !String !Version !Bool
|
||||
| CmdListUnindexed !String
|
||||
| CmdCatAdd !String !String !(Maybe String) !(Maybe Int)
|
||||
| CmdCatDel !String !String
|
||||
| CmdPkgCatAdd !String !PkgId !String
|
||||
| CmdPkgCatDel !String !PkgId !String
|
||||
deriving Show
|
||||
|
||||
cfgLocation :: IO FilePath
|
||||
@@ -314,23 +328,62 @@ parseCommand =
|
||||
<|> parseIndex
|
||||
<|> parseDeindex
|
||||
<|> (CmdListUnindexed <$> parseListUnindexed)
|
||||
<|> parseCat
|
||||
<|> parsePkgCat
|
||||
where reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList)
|
||||
|
||||
parseCat :: Parser Command
|
||||
parseCat = subparser $ command "category" (info (add <|> del) $ progDesc "Manage categories")
|
||||
where
|
||||
add = subparser $ command
|
||||
"add"
|
||||
( info
|
||||
( CmdCatAdd
|
||||
<$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")
|
||||
<*> strArgument (metavar "CATEGORY")
|
||||
<*> optional (strOption (short 'd' <> long "description" <> metavar "DESCRIPTION"))
|
||||
<*> optional
|
||||
(option Options.Applicative.auto (short 'p' <> long "priority" <> metavar "PRIORITY"))
|
||||
)
|
||||
$ progDesc "Adds category to registry"
|
||||
)
|
||||
del = subparser $ command
|
||||
"rm"
|
||||
( info
|
||||
(CmdCatDel <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") <*> strArgument
|
||||
(metavar "CATEGORY")
|
||||
)
|
||||
$ progDesc "Removes category from registry"
|
||||
)
|
||||
|
||||
parsePkgCat :: Parser Command
|
||||
parsePkgCat = subparser $ command "categorize" (info cat $ progDesc "Add or remove package from category")
|
||||
where
|
||||
cat :: Parser Command
|
||||
cat =
|
||||
let cmd rm = if not rm then CmdPkgCatAdd else CmdPkgCatDel
|
||||
in cmd
|
||||
<$> switch (long "remove")
|
||||
<*> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")
|
||||
<*> strArgument (metavar "PACKAGE_ID")
|
||||
<*> strArgument (metavar "CATEGORY")
|
||||
|
||||
opts :: ParserInfo Command
|
||||
opts = info (parseCommand <**> helper) (fullDesc <> progDesc "Publish tool for Embassy Packages")
|
||||
|
||||
cliMain :: IO ()
|
||||
cliMain =
|
||||
execParser opts
|
||||
>>= (\case
|
||||
CmdInit sh -> init sh
|
||||
CmdRegAdd s pcr -> regAdd s pcr
|
||||
CmdRegDel s -> regRm s
|
||||
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
|
||||
)
|
||||
cliMain = execParser opts >>= \case
|
||||
CmdInit sh -> init sh
|
||||
CmdRegAdd s pcr -> regAdd s pcr
|
||||
CmdRegDel s -> regRm s
|
||||
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
|
||||
CmdCatAdd target cat desc pri -> catAdd target cat desc pri
|
||||
CmdCatDel target cat -> catDel target cat
|
||||
CmdPkgCatAdd target pkg cat -> pkgCatAdd target pkg cat
|
||||
CmdPkgCatDel target pkg cat -> pkgCatDel target pkg cat
|
||||
|
||||
init :: Maybe Shell -> IO ()
|
||||
init sh = do
|
||||
@@ -356,7 +409,7 @@ init sh = do
|
||||
regAdd :: String -> PublishCfgRepo -> IO ()
|
||||
regAdd name val = do
|
||||
loc <- cfgLocation
|
||||
PublishCfg cfg <- inputFile auto loc
|
||||
PublishCfg cfg <- inputFile Dhall.auto loc
|
||||
let cfg' = insert name val cfg
|
||||
writeFile loc (pretty $ embed inject $ PublishCfg cfg')
|
||||
putChunkLn $ "Below is the hash to provide to the server operator for your admin credentials" & fore yellow
|
||||
@@ -373,14 +426,14 @@ regAdd name val = do
|
||||
regRm :: String -> IO ()
|
||||
regRm name = do
|
||||
loc <- cfgLocation
|
||||
PublishCfg cfg <- inputFile auto loc
|
||||
PublishCfg cfg <- inputFile Dhall.auto loc
|
||||
let cfg' = delete name cfg
|
||||
writeFile loc (pretty $ embed inject $ PublishCfg cfg')
|
||||
|
||||
regLs :: IO ()
|
||||
regLs = do
|
||||
loc <- cfgLocation
|
||||
PublishCfg cfg <- inputFile auto loc
|
||||
PublishCfg cfg <- inputFile Dhall.auto loc
|
||||
void $ traverseWithKey f cfg
|
||||
where
|
||||
f k v = do
|
||||
@@ -439,39 +492,10 @@ upload (Upload name mpkg shouldIndex) = do
|
||||
sfs2prog StreamFileStatus {..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) ()
|
||||
|
||||
index :: String -> String -> Version -> IO ()
|
||||
index name pkg v = do
|
||||
PublishCfgRepo {..} <- findNameInCfg name
|
||||
noBody <-
|
||||
parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/index")
|
||||
<&> setRequestHeaders [("accept", "text/plain")]
|
||||
<&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
|
||||
let withBody = setRequestBodyJSON (IndexPkgReq (PkgId $ toS pkg) v) noBody
|
||||
res <- httpLBS withBody
|
||||
-- no output is successful
|
||||
if getResponseStatus res == status200
|
||||
then pure ()
|
||||
else do
|
||||
$logError (decodeUtf8 . LB.toStrict $ getResponseBody res)
|
||||
exitWith (ExitFailure 1)
|
||||
|
||||
index name pkg v = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v)
|
||||
|
||||
deindex :: String -> String -> Version -> IO ()
|
||||
deindex name pkg v = do
|
||||
PublishCfgRepo {..} <- findNameInCfg name
|
||||
noBody <-
|
||||
parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/deindex")
|
||||
<&> setRequestHeaders [("accept", "text/plain")]
|
||||
<&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
|
||||
let withBody = setRequestBodyJSON (IndexPkgReq (PkgId $ toS pkg) v) noBody
|
||||
res <- httpLBS withBody
|
||||
-- no output is successful
|
||||
if getResponseStatus res == status200
|
||||
then pure ()
|
||||
else do
|
||||
$logError (decodeUtf8 . LB.toStrict $ getResponseBody res)
|
||||
exitWith (ExitFailure 1)
|
||||
|
||||
|
||||
deindex name pkg v = performHttp name "POST" [i|/admin/v0/deindex|] (IndexPkgReq (PkgId $ toS pkg) v)
|
||||
|
||||
listUnindexed :: String -> IO ()
|
||||
listUnindexed name = do
|
||||
@@ -485,16 +509,45 @@ listUnindexed name = do
|
||||
putChunk (chunk (unPkgId k <> ": ") & fore blue)
|
||||
putChunkLn $ chunk (show v) & fore yellow
|
||||
|
||||
catAdd :: String -> String -> Maybe String -> Maybe Int -> IO ()
|
||||
catAdd target name desc pri =
|
||||
performHttp target "POST" [i|/admin/v0/category/#{name}|] (AddCategoryReq (toS <$> desc) pri)
|
||||
|
||||
catDel :: String -> String -> IO ()
|
||||
catDel target name = performHttp target "DELETE" [i|/admin/v0/category/#{name}|] ()
|
||||
|
||||
pkgCatAdd :: String -> PkgId -> String -> IO ()
|
||||
pkgCatAdd target pkg cat = performHttp target "POST" [i|/admin/v0/categorize/#{cat}/#{pkg}|] ()
|
||||
|
||||
pkgCatDel :: String -> PkgId -> String -> IO ()
|
||||
pkgCatDel target pkg cat = performHttp target "DELETE" [i|/admin/v0/categorize/#{cat}/#{pkg}|] ()
|
||||
|
||||
findNameInCfg :: String -> IO PublishCfgRepo
|
||||
findNameInCfg name = do
|
||||
loc <- cfgLocation
|
||||
PublishCfg cfg <- inputFile auto loc
|
||||
PublishCfg cfg <- inputFile Dhall.auto loc
|
||||
case lookup name cfg of
|
||||
Nothing -> do
|
||||
$logError "Registry name not found!"
|
||||
exitWith $ ExitFailure 1
|
||||
Just pcr -> pure pcr
|
||||
|
||||
performHttp :: ToJSON a => String -> String -> String -> a -> IO ()
|
||||
performHttp target method route body = do
|
||||
PublishCfgRepo {..} <- findNameInCfg target
|
||||
noBody <-
|
||||
parseRequest (method <> " " <> show publishCfgRepoLocation <> route)
|
||||
<&> setRequestHeaders [("accept", "text/plain")]
|
||||
<&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
|
||||
let withBody = setRequestBodyJSON body noBody
|
||||
res <- httpLBS withBody
|
||||
if getResponseStatus res == status200
|
||||
then pure ()
|
||||
else do
|
||||
$logError (decodeUtf8 . LB.toStrict $ getResponseBody res)
|
||||
exitWith (ExitFailure 1)
|
||||
|
||||
|
||||
instance MonadLogger IO where
|
||||
monadLoggerLog _ _ LevelDebug = putChunkLn . colorLog white
|
||||
monadLoggerLog _ _ LevelInfo = putChunkLn . colorLog blue
|
||||
|
||||
@@ -12,6 +12,7 @@ import Control.Exception ( ErrorCall(ErrorCall) )
|
||||
import Control.Monad.Reader.Has ( ask )
|
||||
import Control.Monad.Trans.Maybe ( MaybeT(..) )
|
||||
import Data.Aeson ( (.:)
|
||||
, (.:?)
|
||||
, (.=)
|
||||
, FromJSON(parseJSON)
|
||||
, ToJSON
|
||||
@@ -29,7 +30,11 @@ import Data.List ( (\\)
|
||||
)
|
||||
import Data.String.Interpolate.IsString
|
||||
( i )
|
||||
import Database.Persist ( entityVal
|
||||
import Database.Persist ( Entity(entityKey)
|
||||
, PersistStoreRead(get)
|
||||
, PersistUniqueRead(getBy)
|
||||
, PersistUniqueWrite(deleteBy, insertUnique, upsert)
|
||||
, entityVal
|
||||
, insert_
|
||||
, selectList
|
||||
)
|
||||
@@ -48,12 +53,16 @@ import Lib.Types.AppIndex ( PackageManifest(..)
|
||||
, PkgId(unPkgId)
|
||||
)
|
||||
import Lib.Types.Emver ( Version(..) )
|
||||
import Model ( Key(AdminKey, PkgRecordKey, VersionRecordKey)
|
||||
import Model ( Category(..)
|
||||
, Key(AdminKey, PkgRecordKey, VersionRecordKey)
|
||||
, PkgCategory(PkgCategory)
|
||||
, Unique(UniqueName, UniquePkgCategory)
|
||||
, Upload(..)
|
||||
, VersionRecord(versionRecordNumber, versionRecordPkgId)
|
||||
, unPkgRecordKey
|
||||
)
|
||||
import Network.HTTP.Types ( status404
|
||||
import Network.HTTP.Types ( status403
|
||||
, status404
|
||||
, status500
|
||||
)
|
||||
import Settings
|
||||
@@ -66,12 +75,15 @@ import Startlude ( ($)
|
||||
, Applicative(pure)
|
||||
, Bool(..)
|
||||
, Eq
|
||||
, Int
|
||||
, Maybe(..)
|
||||
, Monad((>>=))
|
||||
, Show
|
||||
, SomeException(..)
|
||||
, Text
|
||||
, asum
|
||||
, fmap
|
||||
, fromMaybe
|
||||
, getCurrentTime
|
||||
, guarded
|
||||
, hush
|
||||
@@ -83,6 +95,7 @@ import Startlude ( ($)
|
||||
, throwIO
|
||||
, toS
|
||||
, traverse
|
||||
, void
|
||||
, when
|
||||
, zip
|
||||
)
|
||||
@@ -193,3 +206,39 @@ getPkgDeindexR = do
|
||||
infixr 8 .*
|
||||
(.*) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
|
||||
(.*) = (.) . (.)
|
||||
|
||||
data AddCategoryReq = AddCategoryReq
|
||||
{ addCategoryDescription :: !(Maybe Text)
|
||||
, addCategoryPriority :: !(Maybe Int)
|
||||
}
|
||||
instance FromJSON AddCategoryReq where
|
||||
parseJSON = withObject "AddCategoryReq" $ \o -> do
|
||||
addCategoryDescription <- o .:? "description"
|
||||
addCategoryPriority <- o .:? "priority"
|
||||
pure AddCategoryReq { .. }
|
||||
instance ToJSON AddCategoryReq where
|
||||
toJSON AddCategoryReq {..} = object ["description" .= addCategoryDescription, "priority" .= addCategoryPriority]
|
||||
|
||||
postCategoryR :: Text -> Handler ()
|
||||
postCategoryR cat = do
|
||||
AddCategoryReq {..} <- requireCheckJsonBody
|
||||
now <- liftIO getCurrentTime
|
||||
void . runDB $ upsert (Category now cat (fromMaybe "" addCategoryDescription) (fromMaybe 0 addCategoryPriority)) []
|
||||
|
||||
deleteCategoryR :: Text -> Handler ()
|
||||
deleteCategoryR cat = runDB $ deleteBy (UniqueName cat)
|
||||
|
||||
postPkgCategorizeR :: Text -> PkgId -> Handler ()
|
||||
postPkgCategorizeR cat pkg = runDB $ do
|
||||
catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|]
|
||||
_pkgEnt <- get (PkgRecordKey pkg) `orThrow` sendResponseText status404 [i|Package "#{pkg}" does not exist|]
|
||||
now <- liftIO getCurrentTime
|
||||
void $ insertUnique (PkgCategory now (PkgRecordKey pkg) (entityKey catEnt)) `orThrow` sendResponseText
|
||||
status403
|
||||
[i|Package "#{pkg}" is already assigned to category "#{cat}"|]
|
||||
|
||||
deletePkgCategorizeR :: Text -> PkgId -> Handler ()
|
||||
deletePkgCategorizeR cat pkg = runDB $ do
|
||||
catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|]
|
||||
deleteBy (UniquePkgCategory (PkgRecordKey pkg) (entityKey catEnt))
|
||||
|
||||
|
||||
@@ -17,7 +17,10 @@ import Startlude ( ($)
|
||||
)
|
||||
|
||||
manualMigration :: Migration
|
||||
manualMigration = [(0, 1) := migration_0_2_0]
|
||||
manualMigration = [(0, 1) := migration_0_2_0, (1, 2) := migration_0_2_1]
|
||||
|
||||
migration_0_2_1 :: [Operation]
|
||||
migration_0_2_1 = [DropColumn ("category", "parent")]
|
||||
|
||||
migration_0_2_0 :: [Operation]
|
||||
migration_0_2_0 =
|
||||
|
||||
@@ -77,7 +77,6 @@ Metric
|
||||
Category
|
||||
createdAt UTCTime
|
||||
name Text
|
||||
parent CategoryId Maybe
|
||||
description Text
|
||||
priority Int default=0
|
||||
UniqueName name
|
||||
@@ -88,6 +87,7 @@ PkgCategory
|
||||
createdAt UTCTime
|
||||
pkgId PkgRecordId
|
||||
categoryId CategoryId
|
||||
UniquePkgCategory pkgId categoryId
|
||||
deriving Eq
|
||||
deriving Show
|
||||
|
||||
|
||||
Reference in New Issue
Block a user