diff --git a/package.yaml b/package.yaml index cd21fea..3b17d7d 100644 --- a/package.yaml +++ b/package.yaml @@ -53,6 +53,8 @@ dependencies: - process - protolude - rainbow + - regex-base + - regex-tdfa - shakespeare - template-haskell - terminal-progress-bar diff --git a/src/Database/Queries.hs b/src/Database/Queries.hs index 8e8b32e..231acc6 100644 --- a/src/Database/Queries.hs +++ b/src/Database/Queries.hs @@ -97,7 +97,7 @@ import Model ( VersionRecordNumber, VersionRecordPkgId, VersionRecordTitle, - VersionRecordUpdatedAt, PkgRecordHidden + VersionRecordUpdatedAt, PkgRecordHidden, VersionPlatformRam ), Key (unPkgRecordKey), PkgCategory, @@ -114,7 +114,7 @@ import Startlude ( snd, sortOn, ($>), - (<$>), + (<$>), Int, ) serviceQuerySource :: @@ -122,69 +122,43 @@ serviceQuerySource :: Maybe Text -> Text -> Maybe OsArch -> + Maybe Int -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () -serviceQuerySource mCat query mOsArch = selectSource $ do - case mOsArch of - Just osArch -> do - service <- case mCat of - Nothing -> do - (service :& vp :& pr) <- from $ table @VersionRecord - `innerJoin` table @VersionPlatform `on` (\(service :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service)) - `innerJoin` table @PkgRecord `on` (\(v :& _ :& p) -> (PkgRecordId === VersionRecordPkgId) (p :& v)) - where_ (service ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber) - where_ (vp ^. VersionPlatformArch ==. val osArch) - where_ (pr ^. PkgRecordHidden ==. val False) - where_ $ queryInMetadata query service - pure service - Just category -> do - (service :& _ :& cat :& vp :& pr) <- - from $ - table @VersionRecord - `innerJoin` table @PkgCategory `on` (VersionRecordPkgId === PkgCategoryPkgId) - `innerJoin` table @Category `on` (\(_ :& a :& b) -> (PkgCategoryCategoryId === CategoryId) (a :& b)) - `innerJoin` table @VersionPlatform `on` (\(service :& _ :& _ :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service)) - `innerJoin` table @PkgRecord `on` (\(v :& _ :& _ :& _ :& p) -> (PkgRecordId === VersionRecordPkgId) (p :& v)) - -- if there is a cateogry, only search in category - -- weight title, short, long (bitcoin should equal Bitcoin Core) - where_ $ cat ^. CategoryName ==. val category &&. queryInMetadata query service - where_ (service ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber) - where_ (vp ^. VersionPlatformArch ==. val osArch) - where_ (pr ^. PkgRecordHidden ==. val False) - pure service - groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber) - orderBy - [ asc (service ^. VersionRecordPkgId) - , desc (service ^. VersionRecordNumber) - , desc (service ^. VersionRecordUpdatedAt) - ] - pure service +serviceQuerySource mCat query mOsArch mRam = selectSource $ do + service <- case mCat of Nothing -> do - service <- case mCat of - Nothing -> do - (service :& pr) <- from $ table @VersionRecord - `innerJoin` table @PkgRecord `on` (\(v :& p) -> (PkgRecordId === VersionRecordPkgId) (p :& v)) - where_ $ queryInMetadata query service - where_ (pr ^. PkgRecordHidden ==. val False) - pure service - Just category -> do - (service :& _ :& cat :& pr) <- - from $ - table @VersionRecord - `innerJoin` table @PkgCategory `on` (VersionRecordPkgId === PkgCategoryPkgId) - `innerJoin` table @Category `on` (\(_ :& a :& b) -> (PkgCategoryCategoryId === CategoryId) (a :& b)) - `innerJoin` table @PkgRecord `on` (\(v :& _ :& _ :& p) -> (PkgRecordId === VersionRecordPkgId) (p :& v)) - -- if there is a cateogry, only search in category - -- weight title, short, long (bitcoin should equal Bitcoin Core) - where_ $ cat ^. CategoryName ==. val category &&. queryInMetadata query service - where_ (pr ^. PkgRecordHidden ==. val False) - pure service - groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber) - orderBy - [ asc (service ^. VersionRecordPkgId) - , desc (service ^. VersionRecordNumber) - , desc (service ^. VersionRecordUpdatedAt) - ] + (service :& vp :& pr) <- from $ table @VersionRecord + `innerJoin` table @VersionPlatform `on` (\(service :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service)) + `innerJoin` table @PkgRecord `on` (\(v :& _ :& p) -> (PkgRecordId === VersionRecordPkgId) (p :& v)) + where_ (service ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber) + where_ (vp ^. VersionPlatformArch ==. val mOsArch) + where_ (vp ^. VersionPlatformRam ==. val mRam) + where_ (pr ^. PkgRecordHidden ==. val False) + where_ $ queryInMetadata query service pure service + Just category -> do + (service :& _ :& cat :& vp :& pr) <- + from $ + table @VersionRecord + `innerJoin` table @PkgCategory `on` (VersionRecordPkgId === PkgCategoryPkgId) + `innerJoin` table @Category `on` (\(_ :& a :& b) -> (PkgCategoryCategoryId === CategoryId) (a :& b)) + `innerJoin` table @VersionPlatform `on` (\(service :& _ :& _ :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service)) + `innerJoin` table @PkgRecord `on` (\(v :& _ :& _ :& _ :& p) -> (PkgRecordId === VersionRecordPkgId) (p :& v)) + -- if there is a cateogry, only search in category + -- weight title, short, long (bitcoin should equal Bitcoin Core) + where_ $ cat ^. CategoryName ==. val category &&. queryInMetadata query service + where_ (service ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber) + where_ (vp ^. VersionPlatformArch ==. val mOsArch) + where_ (vp ^. VersionPlatformRam ==. val mRam) + where_ (pr ^. PkgRecordHidden ==. val False) + pure service + groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber) + orderBy + [ asc (service ^. VersionRecordPkgId) + , desc (service ^. VersionRecordNumber) + , desc (service ^. VersionRecordUpdatedAt) + ] + pure service queryInMetadata :: Text -> SqlExpr (Entity VersionRecord) -> (SqlExpr (Value Bool)) queryInMetadata query service = @@ -195,18 +169,12 @@ queryInMetadata query service = getPkgDataSource :: (MonadResource m, MonadIO m) => [PkgId] -> Maybe OsArch -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () getPkgDataSource pkgs mOsArch = selectSource $ do - case mOsArch of - Just osArch -> do - (pkgData :& vp) <- from $ table @VersionRecord - `innerJoin` table @VersionPlatform `on` (\(service :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service)) - where_ (pkgData ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber) - where_ (vp ^. VersionPlatformArch ==. val osArch) - where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs)) - pure pkgData - Nothing -> do - pkgData <- from $ table @VersionRecord - where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs)) - pure pkgData + (pkgData :& vp) <- from $ table @VersionRecord + `innerJoin` table @VersionPlatform `on` (\(service :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service)) + where_ (pkgData ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber) + where_ (vp ^. VersionPlatformArch ==. val mOsArch) + where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs)) + pure pkgData getPkgDependencyData :: @@ -333,12 +301,27 @@ upsertPackageVersionPlatform maybeArches PackageManifest{..} = do let arches = case maybeArches of Just a -> a Nothing -> [X86_64 .. AARCH64] - let records = createVersionPlatformRecord now pkgId packageManifestVersion <$> arches + let records = createVersionPlatformRecord now pkgId packageManifestVersion packageHardwareRam packageHardwareDevice <$> arches repsertMany records where - createVersionPlatformRecord time id version arch = ((VersionPlatformKey id version arch), VersionPlatform + createVersionPlatformRecord time id version ram device arch = ((VersionPlatformKey id version), VersionPlatform time (Just time) id version - arch) \ No newline at end of file + ram + device + (Just arch)) + +getVersionPlatform :: + (Monad m, MonadIO m) => + PkgRecordId -> + [Maybe OsArch] -> + ReaderT SqlBackend m [VersionPlatform] +getVersionPlatform pkgId arches = do + vps <- select $ do + v <- from $ table @VersionPlatform + where_ $ v ^. VersionPlatformPkgId ==. val pkgId + where_ (v ^. VersionPlatformArch `in_` valList arches) + pure v + pure $ entityVal <$> vps \ No newline at end of file diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 1a7c4f0..b8bac80 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -250,7 +250,7 @@ postPkgDeindexR = do pure () where deleteArch :: PkgId -> Version -> OsArch -> Handler () - deleteArch id v a = runDB $ deleteWhere [VersionPlatformArch ==. a, VersionPlatformVersionNumber ==. v, VersionPlatformPkgId ==. PkgRecordKey id] + deleteArch id v a = runDB $ deleteWhere [VersionPlatformArch ==. Just a, VersionPlatformVersionNumber ==. v, VersionPlatformPkgId ==. PkgRecordKey id] newtype PackageList = PackageList {unPackageList :: HashMap PkgId [Version]} diff --git a/src/Handler/Eos/V0/Latest.hs b/src/Handler/Eos/V0/Latest.hs index 6543355..a2e171e 100644 --- a/src/Handler/Eos/V0/Latest.hs +++ b/src/Handler/Eos/V0/Latest.hs @@ -19,8 +19,8 @@ import Database.Esqueleto.Experimental ( ) import Foundation (Handler) import Handler.Package.V0.ReleaseNotes (ReleaseNotes (..)) -import Handler.Util (queryParamAs, getArchQuery) -import Lib.Types.Emver (Version (unVersion), Version(Version), parseVersion) +import Handler.Util (getOsArch, getOsVersion) +import Lib.Types.Emver (Version (unVersion), Version(Version)) import Model (EntityField (..), OsVersion (..)) import Orphans.Emver () import Startlude (Down (..), Eq, Generic, Maybe (..), Ord ((<)), Text, filter, fst, head, pure, sortOn, ($), (&&&), (.), (<$>), (<&>), (<=)) @@ -48,9 +48,9 @@ instance ToTypedContent EosRes where getEosVersionR :: Handler (JSONResponse (Maybe EosRes)) getEosVersionR = do - currentEosVersion <- fromMaybe Version { unVersion = (0,3,0,0) } <$> queryParamAs "eos-version" parseVersion + currentEosVersion <- fromMaybe Version { unVersion = (0,3,0,0) } <$> getOsVersion -- defaults to raspberrypi for those on OS versions where we did not send this param yet - arch <- fromMaybe RASPBERRYPI <$> getArchQuery + arch <- fromMaybe RASPBERRYPI <$> getOsArch allEosVersions <- runDB $ select $ do vers <- from $ table @OsVersion diff --git a/src/Handler/Package/V0/Icon.hs b/src/Handler/Package/V0/Icon.hs index 0f16584..01f0ad8 100644 --- a/src/Handler/Package/V0/Icon.hs +++ b/src/Handler/Package/V0/Icon.hs @@ -10,7 +10,7 @@ import Data.String.Interpolate.IsString ( i, ) import Foundation (Handler) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat) import Handler.Util ( fetchCompatiblePkgVersions, getVersionSpecFromQuery, @@ -40,7 +40,7 @@ import Yesod ( getIconsR :: PkgId -> Handler TypedContent getIconsR pkg = do - osVersion <- getOsVersionQuery + osVersion <- getOsVersionCompat osCompatibleVersions <- fetchCompatiblePkgVersions osVersion pkg spec <- getVersionSpecFromQuery preferMin <- versionPriorityFromQueryIsMin diff --git a/src/Handler/Package/V0/Instructions.hs b/src/Handler/Package/V0/Instructions.hs index 0279c08..e066bca 100644 --- a/src/Handler/Package/V0/Instructions.hs +++ b/src/Handler/Package/V0/Instructions.hs @@ -10,7 +10,7 @@ import Data.String.Interpolate.IsString ( i, ) import Foundation (Handler) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat) import Handler.Util ( fetchCompatiblePkgVersions, getVersionSpecFromQuery, @@ -42,7 +42,7 @@ import Yesod ( getInstructionsR :: PkgId -> Handler TypedContent getInstructionsR pkg = do spec <- getVersionSpecFromQuery - osVersion <- getOsVersionQuery + osVersion <- getOsVersionCompat osCompatibleVersions <- fetchCompatiblePkgVersions osVersion pkg preferMin <- versionPriorityFromQueryIsMin version <- diff --git a/src/Handler/Package/V0/Latest.hs b/src/Handler/Package/V0/Latest.hs index 83068a1..d7a278c 100644 --- a/src/Handler/Package/V0/Latest.hs +++ b/src/Handler/Package/V0/Latest.hs @@ -10,7 +10,7 @@ import Data.List.NonEmpty.Extra qualified as NE import Data.Tuple.Extra (second) import Database.Queries (collateVersions, getPkgDataSource) import Foundation (Handler, RegistryCtx (appSettings)) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat) import Lib.Error (S9Error (..)) import Lib.Types.Core (PkgId) import Lib.Types.Emver (Version (..), satisfies) @@ -18,7 +18,7 @@ import Model (VersionRecord (..)) import Network.HTTP.Types (status400) import Startlude (Bool (True), Down (Down), Either (..), Generic, Maybe (..), NonEmpty, Show, const, encodeUtf8, filter, flip, nonEmpty, pure, ($), (.), (<$>), (<&>)) import Yesod (ToContent (..), ToTypedContent (..), YesodPersist (runDB), YesodRequest (reqGetParams), getRequest, sendResponseStatus) -import Handler.Util (getArchQuery, filterDeprecatedVersions) +import Handler.Util (getOsArch, filterDeprecatedVersions) import Yesod.Core (getsYesod) import Settings (AppSettings(communityVersion)) @@ -36,10 +36,10 @@ getVersionLatestR :: Handler VersionLatestRes getVersionLatestR = do getParameters <- reqGetParams <$> getRequest osPredicate' <- - getOsVersionQuery <&> \case + getOsVersionCompat <&> \case Nothing -> const True Just v -> flip satisfies v - osArch <- getArchQuery + osArch <- getOsArch communityServiceDeprecationVersion <- getsYesod $ communityVersion . appSettings do case lookup "ids" getParameters of diff --git a/src/Handler/Package/V0/License.hs b/src/Handler/Package/V0/License.hs index 70645a5..9b366ee 100644 --- a/src/Handler/Package/V0/License.hs +++ b/src/Handler/Package/V0/License.hs @@ -10,7 +10,7 @@ import Data.String.Interpolate.IsString ( i, ) import Foundation (Handler) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat) import Handler.Util ( fetchCompatiblePkgVersions, getVersionSpecFromQuery, @@ -41,7 +41,7 @@ import Yesod ( getLicenseR :: PkgId -> Handler TypedContent getLicenseR pkg = do - osVersion <- getOsVersionQuery + osVersion <- getOsVersionCompat osCompatibleVersions <- fetchCompatiblePkgVersions osVersion pkg spec <- getVersionSpecFromQuery preferMin <- versionPriorityFromQueryIsMin diff --git a/src/Handler/Package/V0/Manifest.hs b/src/Handler/Package/V0/Manifest.hs index f2dc965..ecb51cb 100644 --- a/src/Handler/Package/V0/Manifest.hs +++ b/src/Handler/Package/V0/Manifest.hs @@ -10,7 +10,7 @@ import Data.String.Interpolate.IsString ( i, ) import Foundation (Handler) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat) import Handler.Util ( addPackageHeader, fetchCompatiblePkgVersions, @@ -42,7 +42,7 @@ import Yesod ( getAppManifestR :: PkgId -> Handler TypedContent getAppManifestR pkg = do - osVersion <- getOsVersionQuery + osVersion <- getOsVersionCompat osCompatibleVersions <- fetchCompatiblePkgVersions osVersion pkg versionSpec <- getVersionSpecFromQuery preferMin <- versionPriorityFromQueryIsMin diff --git a/src/Handler/Package/V0/ReleaseNotes.hs b/src/Handler/Package/V0/ReleaseNotes.hs index e823e8b..b107ccf 100644 --- a/src/Handler/Package/V0/ReleaseNotes.hs +++ b/src/Handler/Package/V0/ReleaseNotes.hs @@ -11,7 +11,7 @@ import Data.Aeson.Key (fromText) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM import Foundation (Handler) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat) import Handler.Util (fetchCompatiblePkgVersions) import Lib.Types.Core (PkgId) import Lib.Types.Emver (Version) @@ -49,7 +49,7 @@ instance ToTypedContent ReleaseNotes where getReleaseNotesR :: PkgId -> Handler ReleaseNotes getReleaseNotesR pkg = do - osVersion <- getOsVersionQuery + osVersion <- getOsVersionCompat osCompatibleVersions <- fetchCompatiblePkgVersions osVersion pkg pure $ constructReleaseNotesApiRes osCompatibleVersions where diff --git a/src/Handler/Package/V0/S9PK.hs b/src/Handler/Package/V0/S9PK.hs index 4ed12d5..8cc52d5 100644 --- a/src/Handler/Package/V0/S9PK.hs +++ b/src/Handler/Package/V0/S9PK.hs @@ -14,7 +14,7 @@ import Database.Queries ( ) import Foundation (Handler) import GHC.Show (show) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat) import Handler.Util ( addPackageHeader, fetchCompatiblePkgVersions, @@ -79,7 +79,7 @@ getAppR file = do Nothing -> sendResponseStatus status416 ("Range Not Satisfiable" :: Text) Just ranges -> pure $ Just ranges let pkg = PkgId . T.pack $ takeBaseName (show file) - osVersion <- getOsVersionQuery + osVersion <- getOsVersionCompat osCompatibleVersions <- fetchCompatiblePkgVersions osVersion pkg versionSpec <- getVersionSpecFromQuery preferMin <- versionPriorityFromQueryIsMin diff --git a/src/Handler/Package/V0/Version.hs b/src/Handler/Package/V0/Version.hs index 5145832..f85b3fb 100644 --- a/src/Handler/Package/V0/Version.hs +++ b/src/Handler/Package/V0/Version.hs @@ -11,7 +11,7 @@ import Data.String.Interpolate.IsString ( i, ) import Foundation (Handler) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat) import Handler.Util ( fetchCompatiblePkgVersions, getVersionSpecFromQuery, @@ -61,7 +61,7 @@ instance ToTypedContent (Maybe AppVersionRes) where getPkgVersionR :: PkgId -> Handler AppVersionRes getPkgVersionR pkg = do - osVersion <- getOsVersionQuery + osVersion <- getOsVersionCompat osCompatibleVersions <- fetchCompatiblePkgVersions osVersion pkg spec <- getVersionSpecFromQuery preferMin <- versionPriorityFromQueryIsMin diff --git a/src/Handler/Package/V1/Index.hs b/src/Handler/Package/V1/Index.hs index 317488c..1edb2f2 100644 --- a/src/Handler/Package/V1/Index.hs +++ b/src/Handler/Package/V1/Index.hs @@ -25,10 +25,10 @@ import Database.Queries ( getPkgDependencyData, serviceQuerySource, ) -import Foundation (Handler, Route (InstructionsR, LicenseR), RegistryCtx (appSettings)) +import Foundation (Handler, Route (InstructionsR, LicenseR), RegistryCtx (appSettings, appConnPool)) import Handler.Package.Api (DependencyRes (..), PackageListRes (..), PackageRes (..)) import Handler.Types.Api (ApiVersion (..)) -import Handler.Util (basicRender, parseQueryParam, getArchQuery, filterDeprecatedVersions) +import Handler.Util (basicRender, parseQueryParam, filterDeprecatedVersions, filterDevices, getPkgArch, getOsArch) import Lib.PkgRepository (PkgRepo, getIcon, getManifest) import Lib.Types.Core (PkgId) import Lib.Types.Emver (Version, VersionRange (..), parseRange, satisfies, (<||)) @@ -68,6 +68,7 @@ import Startlude ( readMaybe, snd, sortOn, + words, zipWith, zipWithM, ($), @@ -90,6 +91,10 @@ import Data.Tuple (fst) import Database.Persist.Postgresql (entityVal) import Yesod.Core (getsYesod) import Data.List (head) +import Yesod (YesodRequest(reqGetParams)) +import Yesod (getRequest) +import Data.Text (isInfixOf) +import Data.List (last) data PackageReq = PackageReq { packageReqId :: !PkgId @@ -115,11 +120,17 @@ data PackageMetadata = PackageMetadata getPackageIndexR :: Handler PackageListRes getPackageIndexR = do osPredicate <- - getOsVersionQuery <&> \case + getOsVersionCompat <&> \case Nothing -> const True Just v -> flip satisfies v - osArch <- getArchQuery + osArch <- getOsArch + pkgArch <- getPkgArch >>= \case + Nothing -> pure $ [Nothing] + Just a -> pure $ Just <$> a + ram <- getRamQuery + hardwareDevices <- getHardwareDevicesQuery communityVersion <- getsYesod $ communityVersion . appSettings + pool <- getsYesod appConnPool do pkgIds <- getPkgIdsQuery category <- getCategoryQuery @@ -127,7 +138,7 @@ getPackageIndexR = do limit' <- fromMaybe 20 <$> getLimitQuery query <- T.strip . fromMaybe "" <$> lookupGetParam "query" let (source, packageRanges) = case pkgIds of - Nothing -> (serviceQuerySource category query osArch, const Any) + Nothing -> (serviceQuerySource category query osArch ram, const Any) Just packages -> let s = getPkgDataSource (packageReqId <$> packages) osArch r = fromMaybe None . (flip lookup $ (packageReqId &&& packageReqVersion) <$> packages) @@ -142,6 +153,10 @@ getPackageIndexR = do .| mapC (second (filter (osPredicate . versionRecordOsVersion))) -- filter out deprecated service versions after community registry release .| mapC (second (filterDeprecatedVersions communityVersion osPredicate)) + .| mapMC (\(b,c) -> do + l <- filterDevices pool hardwareDevices pkgArch c + pure (b, l) + ) -- prune empty version sets .| concatMapC (\(pkgId, vs) -> (pkgId,) <$> nonEmpty vs) -- grab the latest matching version if it exists @@ -172,9 +187,29 @@ getLimitQuery :: Handler (Maybe Int) getLimitQuery = parseQueryParam "per-page" ((flip $ note . mappend "Invalid 'per-page': ") =<< readMaybe) -getOsVersionQuery :: Handler (Maybe VersionRange) -getOsVersionQuery = parseQueryParam "eos-version-compat" (first toS . Atto.parseOnly parseRange) +getOsVersionCompatQueryLegacy :: Handler (Maybe VersionRange) +getOsVersionCompatQueryLegacy = parseQueryParam "eos-version-compat" (first toS . Atto.parseOnly parseRange) +getOsVersionCompatQuery :: Handler (Maybe VersionRange) +getOsVersionCompatQuery = parseQueryParam "os.compat" (first toS . Atto.parseOnly parseRange) + +getOsVersionCompat :: Handler (Maybe VersionRange) +getOsVersionCompat = do + osVersion <- getOsVersionCompatQuery >>= \case + Just a -> pure $ Just a + Nothing -> getOsVersionCompatQueryLegacy + pure osVersion + +getHardwareDevicesQuery :: Handler (HM.HashMap Text Text) +getHardwareDevicesQuery = do + allParams <- reqGetParams <$> getRequest + -- [("hardware.device.processor","intel"),("hardware.device.display","led")] + let hardwareDeviceParams = filter (\(key, _) -> "hardware.device" `isInfixOf` key) allParams + -- [("processor","intel"),("display","led")] + pure $ HM.fromList $ first (last . words) <$> hardwareDeviceParams + +getRamQuery :: Handler (Maybe Int) +getRamQuery = parseQueryParam "hardware.ram" ((flip $ note . mappend "Invalid 'ram': ") =<< readMaybe) getPackageDependencies :: (MonadIO m, MonadLogger m, MonadResource m, Has PkgRepo r, MonadReader r m) => diff --git a/src/Handler/Util.hs b/src/Handler/Util.hs index 4708c4c..d5a2094 100644 --- a/src/Handler/Util.hs +++ b/src/Handler/Util.hs @@ -17,7 +17,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) +import Database.Queries (fetchAllPkgVersions, getVersionPlatform) import Foundation import Lib.PkgRepository ( PkgRepo, @@ -31,7 +31,7 @@ import Lib.Types.Emver ( ) import Model ( UserActivity (..), - VersionRecord (versionRecordOsVersion, versionRecordDeprecatedAt), + VersionRecord (versionRecordOsVersion, versionRecordDeprecatedAt, versionRecordPkgId), VersionPlatform (versionPlatformDevice), ) import Network.HTTP.Types ( Status, @@ -61,7 +61,7 @@ import Startlude ( ($), (.), (<$>), - (>>=), note, (=<<) + (>>=), note, (=<<), catMaybes, all, traverse, or ) import UnliftIO (MonadUnliftIO) import Yesod ( @@ -80,6 +80,12 @@ import Yesod ( import Yesod.Core (addHeader, logWarn) import Lib.Error (S9Error (..)) import Data.Maybe (isJust) +import qualified Data.HashMap.Strict as HM +import Lib.Types.Manifest +import Startlude (MonadIO) +import Text.Regex.TDFA ((=~)) +import Startlude (filterM) +import Database.Persist.Postgresql (ConnectionPool, runSqlPool) orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a orThrow action other = @@ -158,7 +164,7 @@ tickleMAU = do Nothing -> pure () Just sid -> do currentEosVersion <- queryParamAs "eos-version" parseVersion - arch <- getArchQuery + arch <- getOsArch now <- liftIO getCurrentTime void $ liftHandler $ runDB $ insertRecord $ UserActivity now sid currentEosVersion arch @@ -174,11 +180,61 @@ fetchCompatiblePkgVersions osVersion pkg = do Nothing -> const True Just v -> flip satisfies v -getArchQuery :: Handler (Maybe OsArch) -getArchQuery = parseQueryParam "arch" ((flip $ note . mappend "Invalid 'arch': ") =<< readMaybe) +getOsArchQueryLegacy :: Handler (Maybe OsArch) +getOsArchQueryLegacy = parseQueryParam "arch" ((flip $ note . mappend "Invalid 'arch': ") =<< readMaybe) + +getOsArchQuery :: Handler (Maybe OsArch) +getOsArchQuery = parseQueryParam "os.arch" ((flip $ note . mappend "Invalid 'arch': ") =<< readMaybe) + +getOsArch :: Handler (Maybe OsArch) +getOsArch = do + osArch <- getOsArchQuery >>= \case + Just a -> pure $ Just a + Nothing -> getOsArchQueryLegacy + pure osArch + +getOsVersionLegacy :: Handler (Maybe Version) +getOsVersionLegacy = parseQueryParam "eos-version" ((flip $ note . mappend "Invalid 'eos-version': ") =<< readMaybe) + +getOsVersionQuery :: Handler (Maybe Version) +getOsVersionQuery = parseQueryParam "os.version" ((flip $ note . mappend "Invalid 'os.version': ") =<< readMaybe) + +getOsVersion :: Handler (Maybe Version) +getOsVersion = do + osArch <- getOsVersionQuery >>= \case + Just a -> pure $ Just a + Nothing -> getOsVersionLegacy + pure osArch + +getPkgArch :: Handler (Maybe [OsArch]) +getPkgArch = parseQueryParam "hardware.arch" ((flip $ note . mappend "Invalid 'arch': ") =<< readMaybe) filterDeprecatedVersions :: Version -> (Version -> Bool) -> [VersionRecord] -> [VersionRecord] filterDeprecatedVersions communityVersion osPredicate vrs = do if (osPredicate communityVersion) then filter (\v -> not $ isJust $ versionRecordDeprecatedAt v) $ vrs - else vrs \ No newline at end of file + else vrs + +filterDevices :: (MonadUnliftIO m) => ConnectionPool -> (HM.HashMap Text Text) -> [Maybe OsArch] -> [VersionRecord] -> m [VersionRecord] +filterDevices pool hardwareDevices arches pkgRecords = do + res <- filterM compareHd pkgRecords + pure res + where + compareHd pkgRecord = do + let id = versionRecordPkgId pkgRecord + platformDetails <- flip runSqlPool pool $ getVersionPlatform id arches + let pkgDevices = catMaybes $ versionPlatformDevice <$> platformDetails + t <- traverse (areRegexMatchesEqual hardwareDevices) pkgDevices + pure $ or t + +regexMatch :: RegexPattern -> Text -> Bool +regexMatch (RegexPattern pattern) text = text =~ pattern + +areRegexMatchesEqual :: (MonadIO m) => HM.HashMap Text Text -> PackageDevice -> m Bool +areRegexMatchesEqual textMap (PackageDevice regexMap) = + pure $ all checkMatch (HM.toList regexMap) + where + checkMatch :: (Text, RegexPattern) -> Bool + checkMatch (key, regexPattern) = case HM.lookup key textMap of + Just text -> regexMatch regexPattern text + Nothing -> False \ No newline at end of file diff --git a/src/Lib/Types/Core.hs b/src/Lib/Types/Core.hs index 9bb2271..0dbcffe 100644 --- a/src/Lib/Types/Core.hs +++ b/src/Lib/Types/Core.hs @@ -59,7 +59,6 @@ import Web.HttpApiData ( import Yesod (PathPiece (..)) import Prelude (read) - newtype PkgId = PkgId {unPkgId :: Text} deriving stock (Eq, Ord) deriving newtype (FromHttpApiData, ToHttpApiData) diff --git a/src/Lib/Types/Manifest.hs b/src/Lib/Types/Manifest.hs index dc45c5c..8bfeb1c 100644 --- a/src/Lib/Types/Manifest.hs +++ b/src/Lib/Types/Manifest.hs @@ -5,15 +5,21 @@ module Lib.Types.Manifest where import Control.Monad.Fail (MonadFail (..)) -import Data.Aeson (FromJSON (..), withObject, (.:), (.:?)) import Data.HashMap.Internal.Strict (HashMap) import Data.HashMap.Strict qualified as HM import Data.String.Interpolate.IsString (i) import Data.Text qualified as T import Lib.Types.Core (PkgId) import Lib.Types.Emver (Version (..), VersionRange) -import Startlude (ByteString, Eq, Generic, Hashable, Maybe (..), Monad ((>>=)), Read, Show, Text, for, pure, readMaybe, ($)) - +import Startlude (ByteString, Eq, Generic, Hashable, Maybe (..), Monad ((>>=)), Read, Show, Text, for, pure, readMaybe, ($), Int, (.), (<>)) +import Data.Aeson +import Database.Persist.Sql ( PersistFieldSql(..) ) +import Database.Persist.Types (SqlType(..)) +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString.Lazy as BL +import Database.Persist (PersistValue(..)) +import Data.Either (Either(..)) +import Database.Persist.Class ( PersistField(..) ) data PackageManifest = PackageManifest { packageManifestId :: !PkgId @@ -26,6 +32,8 @@ data PackageManifest = PackageManifest , packageManifestAlerts :: !(HashMap ServiceAlert (Maybe Text)) , packageManifestDependencies :: !(HashMap PkgId PackageDependency) , packageManifestEosVersion :: !Version + , packageHardwareDevice :: !(Maybe PackageDevice) + , packageHardwareRam :: !(Maybe Int) } deriving (Show) instance FromJSON PackageManifest where @@ -47,6 +55,8 @@ instance FromJSON PackageManifest where let packageManifestAlerts = HM.fromList a packageManifestDependencies <- o .: "dependencies" packageManifestEosVersion <- o .: "eos-version" + packageHardwareDevice <- o .: "hardware-requirements" >>= (.: "device") + packageHardwareRam <- o .: "hardware-requirements" >>= (.: "ram") pure PackageManifest{..} @@ -63,7 +73,27 @@ instance FromJSON PackageDependency where packageDependencyDescription <- o .:? "description" pure PackageDependency{..} +-- Custom type for regex pattern +newtype RegexPattern = RegexPattern Text + deriving (Show, Eq, Generic) +instance FromJSON RegexPattern where + parseJSON = withText "RegexPattern" (pure . RegexPattern) +instance ToJSON RegexPattern where + toJSON (RegexPattern txt) = toJSON txt + +data PackageDevice = PackageDevice (HashMap Text RegexPattern) + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +instance PersistField PackageDevice where + toPersistValue = PersistByteString . BL.toStrict . encode + fromPersistValue (PersistByteString bs) = case eitherDecode (BL.fromStrict bs) of + Left err -> Left $ TE.decodeUtf8 bs <> ": " <> T.pack err + Right val -> Right val + fromPersistValue _ = Left "Invalid JSON value in database" + +instance PersistFieldSql PackageDevice where + sqlType _ = SqlOther "JSONB" data ServiceAlert = INSTALL | UNINSTALL | RESTORE | START | STOP deriving (Show, Eq, Generic, Hashable, Read) @@ -79,6 +109,14 @@ testManifest = "short": "Create Tor websites, hosted on your Embassy.", "long": "Embassy Pages is a simple web server that uses directories inside File Browser to serve Tor websites." }, + "hardware-requirements" { + "device": { + processor: "", + display: "" + }, + "ram": "8" + + } "assets": { "license": "LICENSE", "icon": "icon.png", diff --git a/src/Model.hs b/src/Model.hs index 1160fe4..9326e30 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -29,6 +29,7 @@ import Lib.Types.Emver ( ) import Orphans.Cryptonite () import Orphans.Emver () +import Orphans.Value () import Startlude ( Eq, Int, @@ -36,8 +37,9 @@ import Startlude ( Text, UTCTime, Word32, - Bool + Bool, ) +import Lib.Types.Manifest (PackageDevice) share @@ -72,8 +74,10 @@ VersionPlatform updatedAt UTCTime Maybe pkgId PkgRecordId versionNumber Version - arch OsArch - Primary pkgId versionNumber arch + ram Int Maybe + device PackageDevice Maybe + arch OsArch Maybe + Primary pkgId versionNumber deriving Eq deriving Show