cleanup

src/Database/Queries.hs

@@ -338,16 +338,16 @@ 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
 
-getPkgNew:: (Monad m, MonadIO m) => PkgRecordId -> ReaderT SqlBackend m [PkgRecord]
+getPkgOnlyCreated:: (Monad m, MonadIO m) => PkgRecordId -> ReaderT SqlBackend m [PkgRecord]
-getPkgNew pkgId = do
+getPkgOnlyCreated pkgId = do
     pkg <- select $ do
         p <- from $ table @PkgRecord
         where_ $ p ^. PkgRecordId ==. val pkgId

src/Handler/Admin.hs

@@ -147,14 +147,12 @@ import Yesod.Core.Types (JSONResponse (JSONResponse))
 import Database.Persist.Sql (runSqlPool)
 import Database.Persist ((==.))
 import Network.HTTP.Types.Status (status401)
-import Control.Monad.Logger (logInfo)
 
 postPkgUploadR :: Handler ()
 postPkgUploadR = do
     resourcesTemp <- getsYesod $ (</> "temp") . resourcesDir . appSettings
     createDirectoryIfMissing True resourcesTemp
     pkgId_ <- getPkgIdParam
-    $logInfo $ "PARAM: " <> show pkgId_
     withTempDirectory resourcesTemp "newpkg" $ \dir -> do
         let path = dir </> "temp" <.> "s9pk"
         case pkgId_ of
@@ -163,11 +161,10 @@ postPkgUploadR = do
                 name <- checkAdminAuthUpload packageManifestId
                 finishUpload dir path name PackageManifest{..}
             Just pkgId -> do
-                $logInfo $ "VALID: " <> show pkgId
                 name <- checkAdminAuthUpload pkgId
                 PackageManifest{..} <- extractPackageManifest dir path
                 if packageManifestId /= pkgId
-                    then sendResponseText status401 [i|Package id #{packageManifestId} does not match request id of #{pkgId}|]
+                    then sendResponseText status401 [i|Package id #{packageManifestId} does not match requested id #{pkgId}|]
                     else finishUpload dir path name PackageManifest{..}
     where
         retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m)

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, getPkgNew)
+import Database.Queries (fetchAllPkgVersions, getVersionPlatform, getAllowedPkgs, getPkgById, getPkgOnlyCreated)
 import Foundation
 import Lib.PkgRepository (
     PkgRepo,
@@ -270,13 +270,13 @@ 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)
-    pkgCreated <- runDB $ getPkgNew (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 pkgCreated > 0
+        else if length pkgExtracted > 0
             then pure (True, True)
         else pure (True, True)
 
@@ -311,10 +311,5 @@ checkAdminAuthUpload pkgId = do
                     else sendResponseText status401 "User not authorized to upload this package."
                 else sendResponseText status401 "Package does not belong on this registry."
 
-getPkgIdParam :: MonadHandler m => m (Maybe PkgId)
+getPkgIdParam :: Handler (Maybe PkgId)
-getPkgIdParam = do
+getPkgIdParam = parseQueryParam "id" ((flip $ note . mappend "Invalid 'id': ") =<< readMaybe)
-    lookupGetParam "id" >>= \case
-        Nothing -> pure Nothing
-        Just v -> case readMaybe v of
-            Nothing -> sendResponseStatus status400 ("Invalid PkgId" :: Text)
-            Just t -> pure (Just t)