diff --git a/src/Database/Queries.hs b/src/Database/Queries.hs index 7d47c13..f258b2f 100644 --- 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,13 @@ getVersionPlatform pkgId arches = do where_ $ v ^. VersionPlatformPkgId ==. val pkgId where_ (v ^. VersionPlatformArch `in_` (valList arches)) pure v - pure $ entityVal <$> vps \ No newline at end of file + 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 \ No newline at end of file diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 8c2003a..b3b71c9 100644 --- a/src/Handler/Admin.hs +++ b/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 diff --git a/src/Handler/Util.hs b/src/Handler/Util.hs index 36687b3..fb9a3fa 100644 --- 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) 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 \ No newline at end of file + 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 \ No newline at end of file diff --git a/src/Model.hs b/src/Model.hs index a7b1566..e617128 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -153,6 +153,10 @@ Admin passHash (Digest SHA256) deletedAt UTCTime Maybe +AdminPkgs + admin AdminId + pkgId PkgRecordId + Upload uploader AdminId pkgId PkgRecordId