update admin endpoints to check if authorized to upload pkg

src/Database/Queries.hs

@@ -19,7 +19,7 @@ import Model (
     Metric (Metric),
     PkgDependency (..),
     PkgRecord (PkgRecord),
-    VersionRecord (VersionRecord), VersionPlatform (VersionPlatform), EntityField (VersionPlatformPkgId, VersionPlatformVersionNumber, VersionPlatformArch), PkgRecordId,
+    VersionRecord (VersionRecord), VersionPlatform (VersionPlatform), EntityField (VersionPlatformPkgId, VersionPlatformVersionNumber, VersionPlatformArch, AdminPkgsPkgId, AdminPkgsAdmin), PkgRecordId, AdminPkgs, AdminId,
  )
 import Orphans.Emver ()
 import Startlude (
@@ -327,4 +327,13 @@ getVersionPlatform pkgId arches = do
         where_ $ v ^. VersionPlatformPkgId ==. val pkgId
         where_ (v ^. VersionPlatformArch `in_` (valList arches))
         pure v
-    pure $ entityVal <$> vps
+    pure $ entityVal <$> vps
+
+getAllowedPkgs :: (Monad m, MonadIO m) => PkgRecordId -> AdminId -> ReaderT SqlBackend m [AdminPkgs]
+getAllowedPkgs pkgId adminId = do
+    pkgs <- select $ do
+        p <- from $ table @AdminPkgs
+        where_ $ p ^. AdminPkgsPkgId ==. val pkgId
+        where_ $ p ^. AdminPkgsAdmin ==. val adminId
+        pure p
+    pure $ entityVal <$> pkgs

src/Handler/Admin.hs

@@ -58,7 +58,7 @@ import Handler.Util (
     getHashFromQuery,
     getVersionFromQuery,
     orThrow,
-    sendResponseText,
+    sendResponseText, checkAdminAllowedPkgs,
  )
 import Lib.PkgRepository (
     PkgRepo (PkgRepo, pkgRepoFileRoot),
@@ -150,6 +150,7 @@ import Yesod.Core.Types (JSONResponse (JSONResponse))
 import Database.Persist.Sql (runSqlPool)
 import Data.List (elem, length)
 import Database.Persist ((==.))
+import Network.HTTP.Types.Status (status401)
 
 postPkgUploadR :: Handler ()
 postPkgUploadR = do
@@ -181,8 +182,12 @@ postPkgUploadR = do
                         "The Impossible has happened, an unauthenticated user has managed to upload a pacakge to this registry"
                     pure ()
                 Just name -> do
-                    now <- liftIO getCurrentTime
-                    runDB $ insert_ (Upload (AdminKey name) (PkgRecordKey packageManifestId) packageManifestVersion now)
+                    authorized <- checkAdminAllowedPkgs packageManifestId name
+                    if authorized
+                        then do
+                            now <- liftIO getCurrentTime
+                            runDB $ insert_ (Upload (AdminKey name) (PkgRecordKey packageManifestId) packageManifestVersion now)
+                        else sendResponseText status401 "User not authorized to upload this package."
         else sendResponseText status500 "Package does not belong on this registry."
     where
         retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m)
@@ -230,24 +235,44 @@ instance ToJSON IndexPkgReq where
 postPkgIndexR :: Handler ()
 postPkgIndexR = do
     IndexPkgReq{..} <- requireCheckJsonBody
-    manifest <- getManifestLocation indexPkgReqId indexPkgReqVersion
-    man <-
-        liftIO (decodeFileStrict manifest)
-            `orThrow` sendResponseText
-                status404
-                [i|Could not decode manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|]
-    pool <- getsYesod appConnPool
-    runSqlPoolNoTransaction (upsertPackageVersion man) pool Nothing
-    runSqlPool (upsertPackageVersionPlatform indexPkgReqArches man) pool
+    maybeAuthId >>= \case
+        Nothing -> do
+            $logError
+                "An unauthenticated user has accessed the index endpoint."
+            pure ()
+        Just name -> do
+            authorized <- checkAdminAllowedPkgs indexPkgReqId name
+            if authorized
+                then do
+                    manifest <- getManifestLocation indexPkgReqId indexPkgReqVersion
+                    man <-
+                        liftIO (decodeFileStrict manifest)
+                            `orThrow` sendResponseText
+                                status404
+                                [i|Could not decode manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|]
+                    pool <- getsYesod appConnPool
+                    runSqlPoolNoTransaction (upsertPackageVersion man) pool Nothing
+                    runSqlPool (upsertPackageVersionPlatform indexPkgReqArches man) pool
+                else sendResponseText status401 "User not authorized to index this package."
 
 postPkgDeindexR :: Handler ()
 postPkgDeindexR = do
     IndexPkgReq{..} <- requireCheckJsonBody
-    case indexPkgReqArches of
-        Nothing -> runDB $ delete (VersionRecordKey (PkgRecordKey indexPkgReqId) indexPkgReqVersion)
-        Just a -> do
-            _ <- traverse (deleteArch indexPkgReqId indexPkgReqVersion) a
+    maybeAuthId >>= \case
+        Nothing -> do
+            $logError
+                "An unauthenticated user has accessed the deindex endpoint."
             pure ()
+        Just name -> do
+            authorized <- checkAdminAllowedPkgs indexPkgReqId name
+            if authorized
+                then do
+                    case indexPkgReqArches of
+                        Nothing -> runDB $ delete (VersionRecordKey (PkgRecordKey indexPkgReqId) indexPkgReqVersion)
+                        Just a -> do
+                            _ <- traverse (deleteArch indexPkgReqId indexPkgReqVersion) a
+                            pure ()
+                else sendResponseText status401 "User not authorized to deindex this package."
     where
         deleteArch :: PkgId -> Version -> OsArch -> Handler ()
         deleteArch id v a = runDB $ deleteWhere [VersionPlatformArch ==. a, VersionPlatformVersionNumber ==. v, VersionPlatformPkgId ==. PkgRecordKey id]
@@ -298,16 +323,26 @@ 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}"|]
+postPkgCategorizeR cat pkg = do
+    maybeAuthId >>= \case
+        Nothing -> do
+            $logError
+                "An unauthenticated user has accessed the categorize endpoint."
+            pure ()
+        Just name -> do
+            authorized <- checkAdminAllowedPkgs pkg name
+            if authorized
+                then 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}"|]
 
+                else sendResponseText status401 "User not authorized to categorize this package."
 
 deletePkgCategorizeR :: Text -> PkgId -> Handler ()
 deletePkgCategorizeR cat pkg = runDB $ do

src/Handler/Util.hs

@@ -18,7 +18,7 @@ import Data.String.Interpolate.IsString (
 import Data.Text qualified as T
 import Data.Text.Lazy qualified as TL
 import Data.Text.Lazy.Builder qualified as TB
-import Database.Queries (fetchAllPkgVersions, getVersionPlatform)
+import Database.Queries (fetchAllPkgVersions, getVersionPlatform, getAllowedPkgs)
 import Foundation
 import Lib.PkgRepository (
     PkgRepo,
@@ -32,7 +32,7 @@ import Lib.Types.Emver (
  )
 import Model (
     UserActivity (..),
-    VersionRecord (versionRecordOsVersion, versionRecordDeprecatedAt, versionRecordPkgId), VersionPlatform (versionPlatformDevice),
+    VersionRecord (versionRecordOsVersion, versionRecordDeprecatedAt, versionRecordPkgId), VersionPlatform (versionPlatformDevice), AdminId, Key (PkgRecordKey, AdminKey),
  )
 import Network.HTTP.Types (
     Status,
@@ -61,6 +61,7 @@ import Startlude (
     void,
     ($),
     (.),
+    (>),
     (<$>),
     (>>=), note, (=<<), catMaybes, all, encodeUtf8, toS, fmap, traceM, show, trace, any, or, (++), IO, putStrLn, map
  )
@@ -88,6 +89,7 @@ import Data.Aeson (eitherDecodeStrict)
 import Data.Bifunctor (Bifunctor(first))
 import qualified Data.MultiMap as MM
 import Startlude (bimap)
+import Data.List (length)
 
 orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a
 orThrow action other =
@@ -252,4 +254,9 @@ areRegexMatchesEqual textMap (PackageDevice regexMap) =
     checkMatch :: (Text, RegexPattern) -> Bool
     checkMatch (key, regexPattern) = 
         case MM.lookup key textMap of
-            val -> or $ regexMatch regexPattern <$> val
+            val -> or $ regexMatch regexPattern <$> val
+
+checkAdminAllowedPkgs :: PkgId -> Text -> Handler Bool
+checkAdminAllowedPkgs pkgId adminId = do
+    res <- runDB $ getAllowedPkgs (PkgRecordKey pkgId) (AdminKey adminId)
+    pure $ if length res > 0 then True else False

src/Model.hs

@@ -153,6 +153,10 @@ Admin
     passHash (Digest SHA256)
     deletedAt UTCTime Maybe
 
+AdminPkgs
+    admin AdminId
+    pkgId PkgRecordId
+
 Upload
     uploader AdminId
     pkgId PkgRecordId