adds category managment to embassy-publish and admin API

config/routes

@@ -21,3 +21,5 @@
 /admin/v0/upload                           PkgUploadR         POST !admin
 /admin/v0/index                            PkgIndexR          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

src/Application.hs

@@ -151,29 +151,16 @@ import qualified Database.Persist.Migration.Postgres
 import           Database.Persist.Sql           ( SqlBackend )
 import           Foundation                     ( Handler
                                                 , RegistryCtx(..)
-                                                , Route
+                                                , Route(..)
-                                                    ( AppManifestR
-                                                    , AppR
-                                                    , EosR
-                                                    , EosVersionR
-                                                    , ErrorLogsR
-                                                    , IconsR
-                                                    , InfoR
-                                                    , InstructionsR
-                                                    , LicenseR
-                                                    , PackageListR
-                                                    , PkgDeindexR
-                                                    , PkgIndexR
-                                                    , PkgUploadR
-                                                    , PkgVersionR
-                                                    , ReleaseNotesR
-                                                    , VersionLatestR
-                                                    )
                                                 , resourcesRegistryCtx
                                                 , setWebProcessThreadId
                                                 , unsafeHandler
                                                 )
-import           Handler.Admin                  ( getPkgDeindexR
+import           Handler.Admin                  ( deleteCategoryR
+                                                , deletePkgCategorizeR
+                                                , getPkgDeindexR
+                                                , postCategoryR
+                                                , postPkgCategorizeR
                                                 , postPkgDeindexR
                                                 , postPkgIndexR
                                                 , postPkgUploadR

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,15 +328,51 @@ 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 =
+cliMain = execParser opts >>= \case
-    execParser opts
-        >>= (\case
     CmdInit sh                      -> init sh
     CmdRegAdd s pcr                 -> regAdd s pcr
     CmdRegDel s                     -> regRm s
@@ -330,7 +380,10 @@ cliMain =
     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
+index name pkg v = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v)
-    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)
-
 
 deindex :: String -> String -> Version -> IO ()
-deindex name pkg v = do
+deindex name pkg v = performHttp name "POST" [i|/admin/v0/deindex|] (IndexPkgReq (PkgId $ toS pkg) v)
-    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)
-
-
 
 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

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

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 =

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