Fix/misc (#134)

* use latest version of dependency for metadata if best version is unsatisfied

* cleanup

* add config setting to allow protections around package uploads to specific registries

* change to whitelist

* properly parse whitelist

* enable deleting deprecated admin users

config/settings.yml

@@ -39,6 +39,7 @@ marketplace-name: "_env:MARKETPLACE_NAME:CHANGE ME"
 max-eos-version: "_env:MAX_VERSION:0.3.4.0"
 min-eos-version: "_env:MIN_VERSION:0.3.4.0"
 run-migration: "_env:RUN_MIGRATION:false"
+whitelist: "_env:WHITELIST:ADD ME"
 
 database:
   database: "_env:PG_DATABASE:start9_registry"

src/Database/Queries.hs

@@ -19,7 +19,7 @@ import Model (
     Metric (Metric),
     PkgDependency (..),
     PkgRecord (PkgRecord),
-    VersionRecord (VersionRecord), VersionPlatform (VersionPlatform), EntityField (VersionPlatformPkgId, VersionPlatformVersionNumber, VersionPlatformArch),
+    VersionRecord (VersionRecord), VersionPlatform (VersionPlatform), EntityField (VersionPlatformPkgId, VersionPlatformVersionNumber, VersionPlatformArch), PkgRecordId,
  )
 import Orphans.Emver ()
 import Startlude (
@@ -286,14 +286,14 @@ fetchAppVersion :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m (Maybe
 fetchAppVersion pkgId version = get (VersionRecordKey (PkgRecordKey pkgId) version)
 
 
-fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity PkgRecord, P.Entity VersionRecord))
+fetchLatestApp :: MonadIO m => PkgRecordId -> ReaderT SqlBackend m (Maybe (P.Entity PkgRecord, P.Entity VersionRecord))
 fetchLatestApp appId = fmap headMay . sortResults . select $ do
     (service :& version) <-
         from $
             table @PkgRecord
                 `innerJoin` table @VersionRecord
                 `on` (\(service :& version) -> service ^. PkgRecordId ==. version ^. VersionRecordPkgId)
-    where_ (service ^. PkgRecordId ==. val (PkgRecordKey appId))
+    where_ (service ^. PkgRecordId ==. val appId)
     pure (service, version)
     where
         sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd)

src/Foundation.hs

@@ -114,7 +114,7 @@ import Lib.PkgRepository (
 import Lib.Types.Core (PkgId, S9PK)
 import Model (
     Admin (..),
-    Key (AdminKey),
+    Key (AdminKey), EntityField (AdminId, AdminDeletedAt),
  )
 import Settings (AppSettings (appShouldLogAll))
 import System.Console.ANSI.Codes (
@@ -150,6 +150,9 @@ import Yesod.Persist.Core (
     YesodPersistRunner (..),
     defaultGetDBRunner,
  )
+import Database.Persist ((==.))
+import Database.Persist (selectFirst)
+import Database.Persist (entityVal)
 
 
 -- | The foundation datatype for your application. This can be a good place to
@@ -312,9 +315,11 @@ instance YesodAuth RegistryCtx where
         pool <- getsYesod appConnPool
         let checkCreds k s = flip runSqlPool pool $ do
                 let passHash = hashWith SHA256 . encodeUtf8 . ("start9_admin:" <>) $ decodeUtf8 s
-                get (AdminKey $ decodeUtf8 k) <&> \case
+                selectFirst [AdminDeletedAt ==. Nothing, AdminId ==. (AdminKey $ decodeUtf8 k)] [] <&> \case
                     Nothing -> False
-                    Just Admin{adminPassHash} -> adminPassHash == passHash
+                    Just adminEntity -> do 
+                        let Admin{adminPassHash} = entityVal adminEntity
+                        adminPassHash == passHash
 
         defaultMaybeBasicAuthId checkCreds defaultAuthSettings
     loginDest _ = PackageIndexR V1

src/Handler/Admin.hs

@@ -144,11 +144,13 @@ import Yesod (
 import Yesod.Auth (YesodAuth (maybeAuthId))
 import Yesod.Core.Types (JSONResponse (JSONResponse))
 import Database.Persist.Sql (runSqlPool)
+import Data.List (elem)
 
 
 postPkgUploadR :: Handler ()
 postPkgUploadR = do
     resourcesTemp <- getsYesod $ (</> "temp") . resourcesDir . appSettings
+    whitelist <- getsYesod $ whitelist . appSettings
     createDirectoryIfMissing True resourcesTemp
     withTempDirectory resourcesTemp "newpkg" $ \dir -> do
         let path = dir </> "temp" <.> "s9pk"
@@ -159,22 +161,25 @@ postPkgUploadR = do
         when (isNothing res) $ do
             $logError "Failed to extract package"
             sendResponseText status500 "Failed to extract package"
-        PackageManifest{..} <-
+        PackageManifest{..} <- do
             liftIO (decodeFileStrict (dir </> "manifest.json"))
                 `orThrow` sendResponseText status500 "Failed to parse manifest.json"
-        renameFile path (dir </> (toS . unPkgId) packageManifestId <.> "s9pk")
+        if (not $ elem packageManifestId whitelist)
-        let targetPath = pkgRepoFileRoot </> show packageManifestId </> show packageManifestVersion
+         then sendResponseText status500 "Package does not belong on this registry."
-        removePathForcibly targetPath
+         else do
-        createDirectoryIfMissing True targetPath
+            renameFile path (dir </> (toS . unPkgId) packageManifestId <.> "s9pk")
-        renameDirectory dir targetPath
+            let targetPath = pkgRepoFileRoot </> show packageManifestId </> show packageManifestVersion
-        maybeAuthId >>= \case
+            removePathForcibly targetPath
-            Nothing -> do
+            createDirectoryIfMissing True targetPath
-                $logError
+            renameDirectory dir targetPath
-                    "The Impossible has happened, an unauthenticated user has managed to upload a pacakge to this registry"
+            maybeAuthId >>= \case
-                pure ()
+                Nothing -> do
-            Just name -> do
+                    $logError
-                now <- liftIO getCurrentTime
+                        "The Impossible has happened, an unauthenticated user has managed to upload a pacakge to this registry"
-                runDB $ insert_ (Upload (AdminKey name) (PkgRecordKey packageManifestId) packageManifestVersion now)
+                    pure ()
+                Just name -> do
+                    now <- liftIO getCurrentTime
+                    runDB $ insert_ (Upload (AdminKey name) (PkgRecordKey packageManifestId) packageManifestVersion now)
     where
         retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m)
 

src/Handler/Package/V1/Index.hs

@@ -51,7 +51,6 @@ import Startlude (
     Show,
     Text,
     Traversable (traverse),
-    catMaybes,
     const,
     encodeUtf8,
     filter,
@@ -90,6 +89,7 @@ import Yesod (
 import Data.Tuple (fst)
 import Database.Persist.Postgresql (entityVal)
 import Yesod.Core (getsYesod)
+import Data.List (head)
 
 data PackageReq = PackageReq
     { packageReqId :: !PkgId
@@ -187,7 +187,7 @@ getPackageDependencies osPredicate PackageMetadata{packageMetadataPkgId = pkg, p
         let pkgDepInfo = fmap (\a -> (entityVal $ fst a, entityVal $ snd a)) pkgDepInfo'
         pkgDepInfoWithVersions <- traverse getDependencyVersions (fst <$> pkgDepInfo)
         let compatiblePkgDepInfo = fmap (filter (osPredicate . versionRecordOsVersion)) pkgDepInfoWithVersions
-        let depMetadata = catMaybes $ zipWith selectDependencyBestVersion pkgDepInfo compatiblePkgDepInfo
+        let depMetadata = zipWith selectDependencyBestVersion pkgDepInfo compatiblePkgDepInfo
         lift $
             fmap HM.fromList $
                 for depMetadata $ \(depId, title, v, isLocal) -> do
@@ -244,13 +244,17 @@ selectLatestVersionFromSpec pkgRanges vs =
 
 
 -- get best version of the dependency based on what is specified in the db (ie. what is specified in the manifest for the package)
-selectDependencyBestVersion :: (PkgDependency, PkgRecord) -> [VersionRecord] -> Maybe (PkgId, Text, Version, Bool)
+selectDependencyBestVersion :: (PkgDependency, PkgRecord) -> [VersionRecord] -> (PkgId, Text, Version, Bool)
 selectDependencyBestVersion pkgDepInfo depVersions = do
     let pkgDepRecord = fst pkgDepInfo
     let isLocal = pkgRecordHidden $ snd pkgDepInfo
     let depId = pkgDependencyDepId pkgDepRecord
     let versionRequirement = pkgDependencyDepVersionRange pkgDepRecord
     let satisfactory = filter ((<|| versionRequirement) . versionRecordNumber) depVersions
+    let pkgId = unPkgRecordKey depId
     case maximumOn versionRecordNumber satisfactory of
-        Just bestVersion -> Just (unPkgRecordKey depId, versionRecordTitle bestVersion, versionRecordNumber bestVersion, isLocal)
+        Just bestVersion -> (pkgId, versionRecordTitle bestVersion, versionRecordNumber bestVersion, isLocal)
-        Nothing -> Nothing
+        -- use latest version of dep for metadata info
+        Nothing -> do
+            let latestDepVersion = head $ sortOn (Down . versionRecordNumber) depVersions
+            (pkgId, versionRecordTitle latestDepVersion, versionRecordNumber latestDepVersion, isLocal)

src/Handler/Util.hs

@@ -25,7 +25,7 @@ import Lib.PkgRepository (
  )
 import Lib.Types.Core (PkgId, OsArch)
 import Lib.Types.Emver (
-    Version (Version, unVersion),
+    Version,
     VersionRange,
     satisfies, parseVersion
  )

src/Model.hs

@@ -148,6 +148,7 @@ Admin
     Id Text
     createdAt UTCTime
     passHash (Digest SHA256)
+    deletedAt UTCTime Maybe
 
 Upload
     uploader AdminId

src/Settings.hs

@@ -17,7 +17,7 @@ import           Startlude                      ( ($)
                                                 , ByteString
                                                 , ConvertText(toS)
                                                 , FilePath
-                                                , IsString(fromString)
+                                                
                                                 , Monad(return)
                                                 , Monoid(mempty)
                                                 , Text
@@ -56,6 +56,10 @@ import           Lib.PkgRepository              ( EosRepo(EosRepo, eosRepoFileRo
                                                 )
 import           Lib.Types.Emver                ( Version )
 import           Orphans.Emver                  ( )
+import Lib.Types.Core (PkgId)
+import Data.String
+import Data.List.Extra (splitOn)
+import Prelude (map, read)
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,
 -- theoretically even a database.
@@ -75,12 +79,12 @@ data AppSettings = AppSettings
     -- ^ Should all log messages be displayed?
     , errorLogRoot              :: !FilePath
     , marketplaceName           :: !Text
-    , maxOsVersion             :: !Version
+    , maxOsVersion              :: !Version
-    , minOsVersion             :: !Version
+    , minOsVersion              :: !Version
     , registryHostname          :: !Text
     , registryVersion           :: !Version
     , resourcesDir              :: !FilePath
-    , needsMigration              :: !Bool
+    , needsMigration            :: !Bool
     , sslAuto                   :: !Bool
     , sslCertLocation           :: !FilePath
     , sslCsrLocation            :: !FilePath
@@ -88,6 +92,7 @@ data AppSettings = AppSettings
     , sslPath                   :: !FilePath
     , staticBinDir              :: !FilePath
     , torPort                   :: !AppPort
+    , whitelist                 :: ![PkgId]
     }
 instance Has PkgRepo AppSettings where
     extract = liftA2 PkgRepo ((</> "apps") . resourcesDir) staticBinDir
@@ -111,8 +116,8 @@ instance FromJSON AppSettings where
         appShouldLogAll           <- o .:? "should-log-all" .!= False
         errorLogRoot              <- o .: "error-log-root"
         marketplaceName           <- o .: "marketplace-name"
-        maxOsVersion             <- o .: "max-eos-version"
+        maxOsVersion              <- o .: "max-eos-version"
-        minOsVersion             <- o .: "min-eos-version"
+        minOsVersion              <- o .: "min-eos-version"
         registryHostname          <- o .: "registry-hostname"
         resourcesDir              <- o .: "resources-path"
         needsMigration            <- o .: "run-migration"
@@ -120,6 +125,7 @@ instance FromJSON AppSettings where
         sslPath                   <- o .: "ssl-path"
         staticBinDir              <- o .: "static-bin-dir"
         torPort                   <- o .: "tor-port"
+        whitelist                 <- parseCommaSeparatedList <$> o .:? "whitelist" .!= []
 
         let sslKeyLocation  = sslPath </> "key.pem"
         let sslCsrLocation  = sslPath </> "certificate.csr"
@@ -141,3 +147,8 @@ compileTimeAppSettings :: AppSettings
 compileTimeAppSettings = case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
     Error   e        -> panic $ toS e
     Success settings -> settings
+
+parseCommaSeparatedList :: String -> [PkgId]
+parseCommaSeparatedList input = do
+    let strings = splitOn "," input
+    map read strings