diff --git a/config/routes b/config/routes index f9fe684..69e33d9 100644 --- a/config/routes +++ b/config/routes @@ -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 \ No newline at end of file +/admin/v0/deindex PkgDeindexR GET POST !admin +/admin/v0/category/#Text CategoryR POST DELETE !admin +/admin/v0/categorize/#Text/#PkgId PkgCategorizeR POST DELETE !admin \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index 49ca668..929c2e1 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Cli/Cli.hs b/src/Cli/Cli.hs index ce0f01d..c2ab054 100644 --- a/src/Cli/Cli.hs +++ b/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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index dcbc7c8..971f428 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -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)) + diff --git a/src/Migration.hs b/src/Migration.hs index 23deb74..50ea6d2 100644 --- a/src/Migration.hs +++ b/src/Migration.hs @@ -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 = diff --git a/src/Model.hs b/src/Model.hs index 0c61e55..f1d2888 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -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