Feature/admin allowed pkgs (#139)

* update admin endpoints to check if authorized to upload pkg * add auth route for package to check in cli prior to upload * fix param parsing * remove uneeded log * add case for when package is new * move insert auth admin to pkg check * send 200 response on successful insert * invert logic * retype AdminPkgs since PkgRecord id as key will not yet exist * cleanup
2026-03-26 02:11:53 +00:00 · 2024-04-16 15:26:46 -04:00
parent 9af6e6dc76
commit 8834dd1d28
7 changed files with 141 additions and 42 deletions
--- a/config/routes
+++ b/config/routes
@@ -18,6 +18,7 @@
 /package/#ApiVersion/version/#PkgId                 PkgVersionR        GET -- get most recent appId version

 -- ADMIN API V0
+/admin/v0/auth/#PkgId               					CheckPkgAuthR      POST !admin
 /admin/v0/upload                           					PkgUploadR         POST !admin
 /admin/v0/eos-upload                       					EosUploadR         POST !admin
 /admin/v0/index                            					PkgIndexR          POST !admin
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -184,6 +184,7 @@ import Handler.Admin (
    postPkgDeindexR,
    postPkgIndexR,
    postPkgUploadR,
+    postCheckPkgAuthR
 )
 import Handler.Eos (getEosR, getEosVersionR)
 import Handler.Root(getRootR, getMarketplaceR)
--- a/src/Cli/Cli.hs
+++ b/src/Cli/Cli.hs
@@ -53,7 +53,7 @@ import Data.HashMap.Internal.Strict (
 import Data.String.Interpolate.IsString (
    i,
 )
-import Data.Text (toLower)
+import Data.Text (toLower, splitOn, unpack)
 import Dhall (
    Encoder (embed),
    FromDhall (..),
@@ -207,6 +207,8 @@ import Yesod (
 import Prelude (read)
 import Options.Applicative (some)
 import Control.Applicative.HT (lift4)
+import Data.List (last)
+import Data.List (head)


 data Upload = Upload
@@ -526,6 +528,19 @@ upload (Upload name mpkg shouldIndex arches) = do
                    for_ pkgs $ \f -> $logWarn (fromString f)
                    exitWith $ ExitFailure 1
        Just s -> pure s
+    let pkgId_ = head $ splitOn "." $ last $ splitOn "/" $ show pkg
+    pkgAuthBody <-
+        parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/auth/" <> unpack pkgId_)
+            <&> setRequestHeaders [("accept", "text/plain")]
+            <&> setRequestResponseTimeout (responseTimeoutMicro (90_000_000))
+            <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
+    manager <- newTlsManager
+    pkgAuthRes <- runReaderT (httpLbs pkgAuthBody) manager
+    if getResponseStatus pkgAuthRes == status200
+        then pure () -- no output is successful
+        else do
+            $logError (decodeUtf8 . LB.toStrict $ getResponseBody pkgAuthRes)
+            exitWith $ ExitFailure 1
    noBody <-
        parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/upload")
            <&> setRequestHeaders [("accept", "text/plain")]
@@ -535,7 +550,6 @@ upload (Upload name mpkg shouldIndex arches) = do
    bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ())
    body <- observedStreamFile (updateProgress bar . const . sfs2prog) pkg
    let withBody = setRequestBody body noBody
-    manager <- newTlsManager
    res <- runReaderT (httpLbs withBody) manager
    if getResponseStatus res == status200
        then -- no output is successful
--- a/src/Database/Queries.hs
+++ b/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,21 @@ 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) => PkgId -> 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
+
+getPkg:: (Monad m, MonadIO m) => PkgRecordId -> ReaderT SqlBackend m [PkgRecord]
+getPkg pkgId = do
+    pkg <- select $ do
+        p <- from $ table @PkgRecord
+        where_ $ p ^. PkgRecordId ==. val pkgId
+        pure p
+    pure $ entityVal <$> pkg
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -58,7 +58,7 @@ import Handler.Util (
    getHashFromQuery,
    getVersionFromQuery,
    orThrow,
-    sendResponseText,
+    sendResponseText, checkAdminAllowedPkgs, checkAdminAuth,
 )
 import Lib.PkgRepository (
    PkgRepo (PkgRepo, pkgRepoFileRoot),
@@ -79,7 +79,7 @@ import Model (
    Unique (UniqueName, UniquePkgCategory),
    Upload (..),
    VersionRecord (versionRecordNumber, versionRecordPkgId),
-    unPkgRecordKey,
+    unPkgRecordKey, AdminPkgs (AdminPkgs),
 )
 import Network.HTTP.Types (
    status400,
@@ -150,6 +150,28 @@ 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)
+import Network.HTTP.Types (status200)
+
+postCheckPkgAuthR :: PkgId -> Handler ()
+postCheckPkgAuthR pkgId = do
+    whitelist <- getsYesod $ whitelist . appSettings
+    maybeAuthId >>= \case
+        Nothing -> do
+            sendResponseText status401 "User not an authorized admin."
+        Just name -> do
+            if ((length whitelist > 0 && (pkgId `elem` whitelist)) || length whitelist <= 0)
+                then do
+                    (authorized, newPkg) <- checkAdminAllowedPkgs pkgId name
+                    if authorized && not newPkg
+                        then sendResponseText status200 "User authorized to upload this package."
+                    else if authorized && newPkg
+                        -- if pkg is whitelisted and a new upload, add as authorized for this admin user
+                        then do
+                            runDB $ insert_ (AdminPkgs (AdminKey name) pkgId)
+                            sendResponseText status200 "User authorized to upload this package."
+                    else sendResponseText status401 "User not authorized to upload this package."
+                else sendResponseText status500 "Package does not belong on this registry."

 postPkgUploadR :: Handler ()
 postPkgUploadR = do
@@ -175,14 +197,12 @@ postPkgUploadR = do
            removePathForcibly targetPath
            createDirectoryIfMissing True targetPath
            renameDirectory dir targetPath
-            maybeAuthId >>= \case
-                Nothing -> do
-                    $logError
-                        "The Impossible has happened, an unauthenticated user has managed to upload a pacakge to this registry"
-                    pure ()
-                Just name -> do
+            (authorized, name) <- checkAdminAuth packageManifestId
+            if authorized
+                then do
                    now <- liftIO getCurrentTime
-                    runDB $ insert_ (Upload (AdminKey name) (PkgRecordKey packageManifestId) packageManifestVersion now)
+                    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 +250,32 @@ 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
+    (admin, _) <- checkAdminAuth indexPkgReqId
+    if admin
+        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
-            pure ()
+    (admin, _) <- checkAdminAuth indexPkgReqId
+    if admin
+        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,18 +326,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
+    (admin, _) <- checkAdminAuth pkg
+    if admin
+        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
-    catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|]
-    deleteBy (UniquePkgCategory (PkgRecordKey pkg) (entityKey catEnt))
+deletePkgCategorizeR cat pkg = do
+    (admin, _) <- checkAdminAuth pkg
+    if admin
+        then runDB $ do
+            catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|]
+            deleteBy (UniquePkgCategory (PkgRecordKey pkg) (entityKey catEnt))
+        else sendResponseText status401 "User not authorized to uncategorize this package."
--- a/src/Handler/Util.hs
+++ b/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, getPkg)
 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,9 @@ import Data.Aeson (eitherDecodeStrict)
 import Data.Bifunctor (Bifunctor(first))
 import qualified Data.MultiMap as MM
 import Startlude (bimap)
+import Data.List (length)
+import Control.Monad.Logger (logError)
+import Yesod.Auth (YesodAuth(maybeAuthId))

 orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a
 orThrow action other =
@@ -252,4 +256,25 @@ 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, Bool) -- (authorized, newPkg)
+checkAdminAllowedPkgs pkgId adminId = do
+    -- if pkg does not exist yet, allow, because authorized by whitelist
+    pkg <- runDB $ getPkg (PkgRecordKey pkgId)
+    if length pkg > 0
+        then do
+            res <- runDB $ getAllowedPkgs pkgId (AdminKey adminId)
+            pure $ if length res > 0 then (True, False) else (False, False)
+        else pure (True, True)
+
+checkAdminAuth :: PkgId -> Handler (Bool, Text)
+checkAdminAuth pkgId = do
+    maybeAuthId >>= \case
+        Nothing -> do
+            $logError
+                "Impossible: an unauthenticated user has accessed an authenticated endpoint."
+            pure (False, "")
+        Just name -> do
+            (authorized, _) <- checkAdminAllowedPkgs pkgId name
+            pure (authorized, name)
--- a/src/Model.hs
+++ b/src/Model.hs
@@ -153,6 +153,11 @@ Admin
    passHash (Digest SHA256)
    deletedAt UTCTime Maybe

+AdminPkgs
+    admin AdminId
+    pkgId PkgId
+    UniqueAdminPkg pkgId admin
+
 Upload
    uploader AdminId
    pkgId PkgRecordId