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

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

src/Application.hs

@@ -184,6 +184,7 @@ import Handler.Admin (
     postPkgDeindexR,
     postPkgIndexR,
     postPkgUploadR,
+    postCheckPkgAuthR
  )
 import Handler.Eos (getEosR, getEosVersionR)
 import Handler.Root(getRootR, getMarketplaceR)

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

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 (
@@ -328,3 +328,20 @@ getVersionPlatform pkgId arches = do
         where_ (v ^. VersionPlatformArch `in_` (valList arches))
         pure v
     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

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
+            (authorized, name) <- checkAdminAuth packageManifestId
-                Nothing -> do
+            if authorized
-                    $logError
+                then 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)
+                    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,6 +250,9 @@ instance ToJSON IndexPkgReq where
 postPkgIndexR :: Handler ()
 postPkgIndexR = do
     IndexPkgReq{..} <- requireCheckJsonBody
+    (admin, _) <- checkAdminAuth indexPkgReqId
+    if admin
+        then do
             manifest <- getManifestLocation indexPkgReqId indexPkgReqVersion
             man <-
                 liftIO (decodeFileStrict manifest)
@@ -239,15 +262,20 @@ postPkgIndexR = do
             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
+    (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,7 +326,10 @@ deleteCategoryR cat = runDB $ deleteBy (UniqueName cat)
 
 
 postPkgCategorizeR :: Text -> PkgId -> Handler ()
-postPkgCategorizeR cat pkg = runDB $ do
+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
@@ -308,8 +339,13 @@ postPkgCategorizeR cat pkg = runDB $ do
                         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
+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."

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 =
@@ -253,3 +257,24 @@ areRegexMatchesEqual textMap (PackageDevice regexMap) =
     checkMatch (key, regexPattern) = 
         case MM.lookup key textMap of
             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)

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