From a75d9468c03b8e484f8cb86d7880346db8b5a50b Mon Sep 17 00:00:00 2001 From: Lucy Cifferello <12953208+elvece@users.noreply.github.com> Date: Tue, 16 Apr 2024 14:43:35 -0400 Subject: [PATCH] cleanup --- src/Handler/Admin.hs | 124 ++++++++++++++++--------------------------- src/Handler/Util.hs | 15 +++++- 2 files changed, 61 insertions(+), 78 deletions(-) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 475452c..a3521b7 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -58,7 +58,7 @@ import Handler.Util ( getHashFromQuery, getVersionFromQuery, orThrow, - sendResponseText, checkAdminAllowedPkgs, + sendResponseText, checkAdminAllowedPkgs, checkAdminAuth, ) import Lib.PkgRepository ( PkgRepo (PkgRepo, pkgRepoFileRoot), @@ -197,18 +197,12 @@ postPkgUploadR = do removePathForcibly targetPath createDirectoryIfMissing True targetPath renameDirectory dir targetPath - maybeAuthId >>= \case - Nothing -> do - $logError - "Impossible: an unauthenticated user has managed to upload a pacakge to this registry." - pure () - Just name -> do - (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." + (authorized, name) <- checkAdminAuth packageManifestId + 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) @@ -256,44 +250,32 @@ instance ToJSON IndexPkgReq where postPkgIndexR :: Handler () postPkgIndexR = do IndexPkgReq{..} <- requireCheckJsonBody - maybeAuthId >>= \case - Nothing -> do - $logError - "Impossible: 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." + (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 - maybeAuthId >>= \case - Nothing -> do - $logError - "Impossible: 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." + (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] @@ -345,37 +327,25 @@ deleteCategoryR cat = runDB $ deleteBy (UniqueName cat) postPkgCategorizeR :: Text -> PkgId -> Handler () postPkgCategorizeR cat pkg = do - maybeAuthId >>= \case - Nothing -> do - $logError - "Impossible: 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}"|] + (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." + else sendResponseText status401 "User not authorized to categorize this package." deletePkgCategorizeR :: Text -> PkgId -> Handler () deletePkgCategorizeR cat pkg = do - maybeAuthId >>= \case - Nothing -> do - $logError - "Impossible: an unauthenticated user has accessed the uncategorize 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|] - deleteBy (UniquePkgCategory (PkgRecordKey pkg) (entityKey catEnt)) - else sendResponseText status401 "User not authorized to uncategorize this package." \ No newline at end of file + (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." \ No newline at end of file diff --git a/src/Handler/Util.hs b/src/Handler/Util.hs index 3a03451..1caf38c 100644 --- a/src/Handler/Util.hs +++ b/src/Handler/Util.hs @@ -90,6 +90,8 @@ 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 = @@ -264,4 +266,15 @@ checkAdminAllowedPkgs pkgId adminId = do then do res <- runDB $ getAllowedPkgs pkgId (AdminKey adminId) pure $ if length res > 0 then (True, False) else (False, False) - else pure (True, True) \ No newline at end of file + 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) \ No newline at end of file