Update/admin upload (#140)

* move auth logic into upload endpoint and remove separate endpoint

* test log

* log param parse

* check for backwards compatibility

* test

* cleanup

config/routes

@@ -1,5 +1,5 @@
-/ 																									RootR 						GET
+/ 																									RootR 						 GET
-/marketplace/#PkgId 																MarketplaceR 			GET
+/marketplace/#PkgId 																MarketplaceR 			 GET
 
 -- EOS API V0
 /eos/v0/latest                             					EosVersionR        GET -- get eos information
@@ -18,8 +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 -- ?id=<pkgId>
-/admin/v0/upload                           					PkgUploadR         POST !admin
 /admin/v0/eos-upload                       					EosUploadR         POST !admin
 /admin/v0/index                            					PkgIndexR          POST !admin
 /admin/v0/deindex                          					PkgDeindexR        GET POST !admin

src/Application.hs

@@ -184,7 +184,6 @@ 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, splitOn, unpack)
+import Data.Text (toLower, splitOn)
 import Dhall (
     Encoder (embed),
     FromDhall (..),
@@ -90,7 +90,7 @@ import Network.HTTP.Simple (
     setRequestBody,
     setRequestBodyJSON,
     setRequestHeaders,
-    setRequestResponseTimeout,
+    setRequestResponseTimeout, setRequestQueryString,
  )
 import Network.HTTP.Types (status200)
 import Network.URI (
@@ -179,7 +179,7 @@ import Startlude (
     ($>),
     (&),
     (.),
-    (<&>),
+    (<&>), encodeUtf8,
  )
 import System.Directory (
     createDirectoryIfMissing,
@@ -529,20 +529,10 @@ upload (Upload name mpkg shouldIndex arches) = do
                     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")
+            <&> setRequestQueryString [("id", Just $ encodeUtf8 pkgId_)]
             <&> setRequestHeaders [("accept", "text/plain")]
             <&> setRequestResponseTimeout (responseTimeoutMicro (5_400_000_000)) -- 90 minutes
             <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)

src/Database/Queries.hs

@@ -96,7 +96,7 @@ import Model (
         VersionRecordNumber,
         VersionRecordPkgId,
         VersionRecordTitle,
-        VersionRecordUpdatedAt, PkgRecordHidden, VersionPlatformRam
+        VersionRecordUpdatedAt, PkgRecordHidden, VersionPlatformRam, PkgRecordUpdatedAt
     ),
     Key (unPkgRecordKey),
     PkgCategory,
@@ -338,10 +338,19 @@ getAllowedPkgs pkgId adminId = do
         pure p
     pure $ entityVal <$> pkgs
 
-getPkg:: (Monad m, MonadIO m) => PkgRecordId -> ReaderT SqlBackend m [PkgRecord]
+getPkgById:: (Monad m, MonadIO m) => PkgRecordId -> ReaderT SqlBackend m [PkgRecord]
-getPkg pkgId = do
+getPkgById pkgId = do
     pkg <- select $ do
         p <- from $ table @PkgRecord
         where_ $ p ^. PkgRecordId ==. val pkgId
         pure p
     pure $ entityVal <$> pkg
+
+getPkgOnlyCreated:: (Monad m, MonadIO m) => PkgRecordId -> ReaderT SqlBackend m [PkgRecord]
+getPkgOnlyCreated pkgId = do
+    pkg <- select $ do
+        p <- from $ table @PkgRecord
+        where_ $ p ^. PkgRecordId ==. val pkgId
+        where_ $ isNothing $ p ^. PkgRecordUpdatedAt 
+        pure p
+    pure $ entityVal <$> pkg

src/Handler/Admin.hs

@@ -58,7 +58,7 @@ import Handler.Util (
     getHashFromQuery,
     getVersionFromQuery,
     orThrow,
-    sendResponseText, checkAdminAllowedPkgs, checkAdminAuth,
+    sendResponseText, checkAdminAuth, checkAdminAuthUpload, getPkgIdParam,
  )
 import Lib.PkgRepository (
     PkgRepo (PkgRepo, pkgRepoFileRoot),
@@ -79,7 +79,7 @@ import Model (
     Unique (UniqueName, UniquePkgCategory),
     Upload (..),
     VersionRecord (versionRecordNumber, versionRecordPkgId),
-    unPkgRecordKey, AdminPkgs (AdminPkgs),
+    unPkgRecordKey,
  )
 import Network.HTTP.Types (
     status400,
@@ -116,10 +116,8 @@ import Startlude (
     (<$>),
     (<<$>>),
     (<>),
-    (>),
+    (/=),
-    (&&),
+    FilePath
-    (||),
-    (<=),
  )
 import System.FilePath (
     (<.>),
@@ -145,68 +143,50 @@ import Yesod (
     runDB,
     sendResponseStatus,
  )
-import Yesod.Auth (YesodAuth (maybeAuthId))
 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
     resourcesTemp <- getsYesod $ (</> "temp") . resourcesDir . appSettings
-    whitelist <- getsYesod $ whitelist . appSettings
     createDirectoryIfMissing True resourcesTemp
+    pkgId_ <- getPkgIdParam
     withTempDirectory resourcesTemp "newpkg" $ \dir -> do
         let path = dir </> "temp" <.> "s9pk"
-        runConduit $ rawRequestBody .| sinkFile path
+        case pkgId_ of
-        pool <- getsYesod appConnPool
+            Nothing -> do
-        PkgRepo{..} <- ask
+                PackageManifest{..} <- extractPackageManifest dir path
-        res <- retry $ extractPkg pool path
+                name <- checkAdminAuthUpload packageManifestId
-        when (isNothing res) $ do
+                finishUpload dir path name PackageManifest{..}
-            $logError "Failed to extract package"
+            Just pkgId -> do
-            sendResponseText status500 "Failed to extract package"
+                name <- checkAdminAuthUpload pkgId
-        PackageManifest{..} <- do
+                PackageManifest{..} <- extractPackageManifest dir path
-            liftIO (decodeFileStrict (dir </> "manifest.json"))
+                if packageManifestId /= pkgId
-                `orThrow` sendResponseText status500 "Failed to parse manifest.json"
+                    then sendResponseText status401 [i|Package id #{packageManifestId} does not match requested id #{pkgId}|]
-        if ((length whitelist > 0 && (packageManifestId `elem` whitelist)) || length whitelist <= 0)
+                    else finishUpload dir path name PackageManifest{..}
-         then do
+    where
+        retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m)
+        extractPackageManifest :: FilePath -> FilePath -> Handler PackageManifest
+        extractPackageManifest dir path = do
+            runConduit $ rawRequestBody .| sinkFile path
+            pool <- getsYesod appConnPool
+            res <- retry $ extractPkg pool path
+            when (isNothing res) $ do
+                $logError "Failed to extract package"
+                sendResponseText status500 "Failed to extract package"
+            liftIO (decodeFileStrict (dir </> "manifest.json")) `orThrow` sendResponseText status500 "Failed to parse manifest.json"
+        finishUpload :: FilePath -> FilePath -> Text -> PackageManifest -> Handler ()
+        finishUpload dir path admin PackageManifest{..} = do
+            PkgRepo{..} <- ask
             renameFile path (dir </> (toS . unPkgId) packageManifestId <.> "s9pk")
             let targetPath = pkgRepoFileRoot </> show packageManifestId </> show packageManifestVersion
             removePathForcibly targetPath
             createDirectoryIfMissing True targetPath
             renameDirectory dir targetPath
-            (authorized, name) <- checkAdminAuth packageManifestId
+            now <- liftIO getCurrentTime
-            if authorized
+            runDB $ insert_ (Upload (AdminKey admin) (PkgRecordKey packageManifestId)packageManifestVersion now)
-                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)
-
 
 postEosUploadR :: Handler ()
 postEosUploadR = 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, getAllowedPkgs, getPkg)
+import Database.Queries (fetchAllPkgVersions, getVersionPlatform, getAllowedPkgs, getPkgById, getPkgOnlyCreated)
 import Foundation
 import Lib.PkgRepository (
     PkgRepo,
@@ -32,7 +32,7 @@ import Lib.Types.Emver (
  )
 import Model (
     UserActivity (..),
-    VersionRecord (versionRecordOsVersion, versionRecordDeprecatedAt, versionRecordPkgId), VersionPlatform (versionPlatformDevice), AdminId, Key (PkgRecordKey, AdminKey),
+    VersionRecord (versionRecordOsVersion, versionRecordDeprecatedAt, versionRecordPkgId), VersionPlatform (versionPlatformDevice), AdminId, Key (PkgRecordKey, AdminKey), AdminPkgs (AdminPkgs),
  )
 import Network.HTTP.Types (
     Status,
@@ -63,6 +63,9 @@ import Startlude (
     (.),
     (>),
     (<$>),
+    (&&),
+    (||),
+    (<=),
     (>>=), note, (=<<), catMaybes, all, encodeUtf8, toS, fmap, traceM, show, trace, any, or, (++), IO, putStrLn, map
  )
 import UnliftIO (MonadUnliftIO)
@@ -89,9 +92,15 @@ import Data.Aeson (eitherDecodeStrict)
 import Data.Bifunctor (Bifunctor(first))
 import qualified Data.MultiMap as MM
 import Startlude (bimap)
-import Data.List (length)
+import Data.List (elem, length)
 import Control.Monad.Logger (logError)
 import Yesod.Auth (YesodAuth(maybeAuthId))
+import Network.HTTP.Types.Status (status401)
+import Yesod (getsYesod)
+import Settings (AppSettings(whitelist))
+import Network.HTTP.Types (status200)
+import Database.Persist (insert_)
+import Yesod (lookupPostParam)
 
 orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a
 orThrow action other =
@@ -261,11 +270,14 @@ areRegexMatchesEqual textMap (PackageDevice regexMap) =
 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)
+    pkg <- runDB $ getPkgById (PkgRecordKey pkgId)
+    pkgExtracted <- runDB $ getPkgOnlyCreated (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 if length pkgExtracted > 0
+            then pure (True, True)
         else pure (True, True)
 
 checkAdminAuth :: PkgId -> Handler (Bool, Text)
@@ -278,3 +290,26 @@ checkAdminAuth pkgId = do
         Just name -> do
             (authorized, _) <- checkAdminAllowedPkgs pkgId name
             pure (authorized, name)
+
+checkAdminAuthUpload :: PkgId -> Handler Text
+checkAdminAuthUpload 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 pure name
+                    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)
+                            pure name
+                    else sendResponseText status401 "User not authorized to upload this package."
+                else sendResponseText status401 "Package does not belong on this registry."
+
+getPkgIdParam :: Handler (Maybe PkgId)
+getPkgIdParam = parseQueryParam "id" ((flip $ note . mappend "Invalid 'id': ") =<< readMaybe)