diff --git a/package.yaml b/package.yaml index 3b17d7d..2fad37b 100644 --- a/package.yaml +++ b/package.yaml @@ -42,6 +42,7 @@ dependencies: - monad-logger - monad-logger-extras - monad-loops + - multimap - network-uri - optparse-applicative - parallel diff --git a/src/Database/Queries.hs b/src/Database/Queries.hs index addd7cb..fcba3ff 100644 --- a/src/Database/Queries.hs +++ b/src/Database/Queries.hs @@ -31,7 +31,7 @@ import Startlude ( getCurrentTime, maybe, ($), - (.), Bool (False), fst, + (.), Bool (False), fst, bimap, ) import System.FilePath (takeExtension) import UnliftIO ( @@ -55,7 +55,6 @@ import Database.Esqueleto.Experimental ( asc, desc, from, - groupBy, ilike, in_, innerJoin, @@ -97,7 +96,7 @@ import Model ( VersionRecordNumber, VersionRecordPkgId, VersionRecordTitle, - VersionRecordUpdatedAt, PkgRecordHidden, VersionPlatformRam, VersionPlatformCreatedAt, VersionPlatformUpdatedAt + VersionRecordUpdatedAt, PkgRecordHidden, VersionPlatformRam ), Key (unPkgRecordKey), PkgCategory, @@ -133,7 +132,7 @@ serviceQuerySource mCat query arches mRam = selectSource $ do `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 `in_` (valList $ Just <$> arches)) + where_ (vp ^. VersionPlatformArch `in_` (valList arches)) where_ (vp ^. VersionPlatformRam >=. val mRam ||. isNothing (vp ^. VersionPlatformRam)) where_ (pr ^. PkgRecordHidden ==. val False) where_ $ queryInMetadata query service @@ -150,11 +149,10 @@ serviceQuerySource mCat query arches mRam = selectSource $ do -- 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 `in_` (valList $ Just <$> arches)) + where_ (vp ^. VersionPlatformArch `in_` (valList arches)) where_ (vp ^. VersionPlatformRam >=. val mRam ||. isNothing (vp ^. VersionPlatformRam)) where_ (pr ^. PkgRecordHidden ==. val False) pure (service, vp) - groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber, vp ^. VersionPlatformCreatedAt, vp ^. VersionPlatformUpdatedAt, vp ^. VersionPlatformPkgId, vp ^. VersionPlatformVersionNumber) orderBy [ asc (service ^. VersionRecordPkgId) , desc (service ^. VersionRecordNumber) @@ -174,7 +172,7 @@ getPkgDataSource pkgs arches mRam = selectSource $ do (pkgData :& vp) <- from $ table @VersionRecord `innerJoin` table @VersionPlatform `on` (\(service :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service)) where_ (pkgData ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber) - where_ (vp ^. VersionPlatformArch `in_` (valList $ Just <$> arches)) + where_ (vp ^. VersionPlatformArch `in_` (valList arches)) where_ (vp ^. VersionPlatformRam >=. val mRam ||. isNothing (vp ^. VersionPlatformRam)) where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs)) pure (pkgData, vp) @@ -221,19 +219,17 @@ getCategoriesFor pkg = fmap (fmap entityVal) $ collateVersions :: MonadUnliftIO m => ConduitT (Entity VersionRecord, Entity VersionPlatform) (PkgId, [(VersionRecord, VersionPlatform)]) (ReaderT SqlBackend m) () -collateVersions = awaitForever $ \(v0, _) -> do +collateVersions = awaitForever $ \(v0, vp) -> do let pkg = unPkgRecordKey . versionRecordPkgId $ entityVal v0 - minput <- await let pull = do - -- mvn <- await - case minput of + mvn <- await + case mvn of Nothing -> pure Nothing Just vn -> do let pkg' = unPkgRecordKey . versionRecordPkgId $ entityVal $ fst vn if pkg == pkg' then pure (Just vn) else leftover vn $> Nothing ls <- unfoldM pull - let withoutEntity = fmap (\a -> (entityVal $ fst a, entityVal $ snd a)) ls - yield (pkg, withoutEntity) + yield (pkg, bimap entityVal entityVal (v0, vp) : fmap (\(v, vp') -> (entityVal v, entityVal vp')) ls) getDependencyVersions :: @@ -309,14 +305,14 @@ upsertPackageVersionPlatform maybeArches PackageManifest{..} = do let records = createVersionPlatformRecord now pkgId packageManifestVersion packageHardwareRam packageHardwareDevice <$> arches repsertMany records where - createVersionPlatformRecord time id version ram device arch = ((VersionPlatformKey id version), VersionPlatform + createVersionPlatformRecord time id version ram device arch = ((VersionPlatformKey id version arch), VersionPlatform time (Just time) id version ram device - (Just arch)) + arch) getVersionPlatform :: (Monad m, MonadIO m) => @@ -327,6 +323,6 @@ getVersionPlatform pkgId arches = do vps <- select $ do v <- from $ table @VersionPlatform where_ $ v ^. VersionPlatformPkgId ==. val pkgId - where_ (v ^. VersionPlatformArch `in_` (valList $ Just <$> arches)) + 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 b8bac80..1a7c4f0 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 ==. Just a, VersionPlatformVersionNumber ==. v, VersionPlatformPkgId ==. PkgRecordKey id] + deleteArch id v a = runDB $ deleteWhere [VersionPlatformArch ==. a, VersionPlatformVersionNumber ==. v, VersionPlatformPkgId ==. PkgRecordKey id] newtype PackageList = PackageList {unPackageList :: HashMap PkgId [Version]} diff --git a/src/Handler/Package/V0/Latest.hs b/src/Handler/Package/V0/Latest.hs index aab4f92..20ca18f 100644 --- a/src/Handler/Package/V0/Latest.hs +++ b/src/Handler/Package/V0/Latest.hs @@ -16,7 +16,7 @@ import Lib.Types.Core (PkgId) import Lib.Types.Emver (Version (..), satisfies) 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, ($), (.), (<$>), (<&>), (>>=), fst) +import Startlude (Bool (True), Down (Down), Either (..), Generic, Maybe (..), NonEmpty, Show, const, encodeUtf8, filter, flip, nonEmpty, pure, ($), (.), (<$>), (<&>), (>>=), fst, traceM, show) import Yesod (ToContent (..), ToTypedContent (..), YesodPersist (runDB), YesodRequest (reqGetParams), getRequest, sendResponseStatus) import Handler.Util (filterDeprecatedVersions, getPkgArch, filterDevices) import Yesod.Core (getsYesod) @@ -63,7 +63,7 @@ getVersionLatestR = do .| mapC (second (filter (osPredicate' . versionRecordOsVersion . fst))) -- filter hardware device compatability .| mapMC (\(b,c) -> do - l <- filterDevices hardwareDevices pkgArch c + l <- filterDevices hardwareDevices c pure (b, l) ) -- filter out deprecated service versions after community registry release diff --git a/src/Handler/Package/V1/Index.hs b/src/Handler/Package/V1/Index.hs index dda70d7..5001f33 100644 --- a/src/Handler/Package/V1/Index.hs +++ b/src/Handler/Package/V1/Index.hs @@ -16,6 +16,7 @@ import Data.HashMap.Strict qualified as HM import Data.List (lookup) import Data.List.NonEmpty qualified as NE import Data.Text qualified as T +import qualified Data.MultiMap as MM import Database.Persist.Sql (SqlBackend) import Database.Queries ( collateVersions, @@ -68,7 +69,6 @@ import Startlude ( readMaybe, snd, sortOn, - words, zipWith, zipWithM, ($), @@ -93,8 +93,8 @@ import Yesod.Core (getsYesod) import Data.List (head) import Yesod (YesodRequest(reqGetParams)) import Yesod (getRequest) -import Data.Text (isInfixOf) import Data.List (last) +import Data.Text (isPrefixOf) data PackageReq = PackageReq { packageReqId :: !PkgId @@ -150,7 +150,7 @@ getPackageIndexR = do .| mapC (second (filter (osPredicate . versionRecordOsVersion . fst))) -- filter hardware device compatability .| mapMC (\(b,c) -> do - l <- filterDevices hardwareDevices pkgArch c + l <- filterDevices hardwareDevices c pure (b, l) ) -- filter out deprecated service versions after community registry release @@ -198,13 +198,13 @@ getOsVersionCompat = do Nothing -> getOsVersionCompatQueryLegacy pure osVersion -getHardwareDevicesQuery :: Handler (HM.HashMap Text Text) +getHardwareDevicesQuery :: Handler (MM.MultiMap Text Text) getHardwareDevicesQuery = do allParams <- reqGetParams <$> getRequest -- [("hardware.device.processor","intel"),("hardware.device.display","led")] - let hardwareDeviceParams = filter (\(key, _) -> "hardware.device" `isInfixOf` key) allParams + let hardwareDeviceParams = filter (\(key, _) -> "hardware.device" `isPrefixOf` key) allParams -- [("processor","intel"),("display","led")] - pure $ HM.fromList $ first (last . words) <$> hardwareDeviceParams + pure $ MM.fromList $ first (last . T.splitOn ".") <$> hardwareDeviceParams getRamQuery :: Handler (Maybe Int) getRamQuery = parseQueryParam "hardware.ram" ((flip $ note . mappend "Invalid 'ram': ") =<< readMaybe) diff --git a/src/Handler/Util.hs b/src/Handler/Util.hs index 58adaab..2cfb320 100644 --- a/src/Handler/Util.hs +++ b/src/Handler/Util.hs @@ -62,7 +62,7 @@ import Startlude ( ($), (.), (<$>), - (>>=), note, (=<<), catMaybes, all, encodeUtf8, toS, fmap + (>>=), note, (=<<), catMaybes, all, encodeUtf8, toS, fmap, traceM, show, trace, any, or, (++), IO, putStrLn, map ) import UnliftIO (MonadUnliftIO) import Yesod ( @@ -86,6 +86,8 @@ import Lib.Types.Manifest import Text.Regex.TDFA ((=~)) import Data.Aeson (eitherDecodeStrict) import Data.Bifunctor (Bifunctor(first)) +import qualified Data.MultiMap as MM +import Startlude (bimap) orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a orThrow action other = @@ -227,13 +229,14 @@ filterDeprecatedVersions communityVersion osPredicate vrs = do then filter (\v -> not $ isJust $ versionRecordDeprecatedAt v) $ vrs else vrs -filterDevices :: (MonadUnliftIO m) => (HM.HashMap Text Text) -> [OsArch] -> [(VersionRecord, VersionPlatform)] -> m [VersionRecord] -filterDevices hardwareDevices arches pkgRecords = do +filterDevices :: (MonadUnliftIO m) => (MM.MultiMap Text Text) -> [(VersionRecord, VersionPlatform)] -> m [VersionRecord] +filterDevices hardwareDevices pkgRecords = do pure $ catMaybes $ fmap (compareHd hardwareDevices) pkgRecords where - compareHd :: HM.HashMap Text Text -> (VersionRecord, VersionPlatform) -> Maybe VersionRecord + compareHd :: MM.MultiMap Text Text -> (VersionRecord, VersionPlatform) -> Maybe VersionRecord compareHd hd (vr, vp) = case versionPlatformDevice vp of - Nothing -> Just vr + Nothing -> do + Just vr Just d -> if areRegexMatchesEqual hd d then Just vr else Nothing @@ -241,11 +244,12 @@ filterDevices hardwareDevices arches pkgRecords = do regexMatch :: RegexPattern -> Text -> Bool regexMatch (RegexPattern pattern) text = text =~ pattern -areRegexMatchesEqual :: HM.HashMap Text Text -> PackageDevice -> Bool +areRegexMatchesEqual :: MM.MultiMap Text Text -> PackageDevice -> Bool areRegexMatchesEqual textMap (PackageDevice regexMap) = - all checkMatch (HM.toList regexMap) + any 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 + checkMatch (key, regexPattern) = + case MM.lookup key textMap of + _ : xs -> or $ regexMatch regexPattern <$> xs + [] -> False \ No newline at end of file diff --git a/src/Lib/Types/Manifest.hs b/src/Lib/Types/Manifest.hs index d9ed9c1..cdec626 100644 --- a/src/Lib/Types/Manifest.hs +++ b/src/Lib/Types/Manifest.hs @@ -111,10 +111,10 @@ testManifest = }, "hardware-requirements" { "device": { - "processor": "intel", - "display": "r'^{.*}$'" + "processor": "^[A-Za-z0-9]+$", + "display": "^[A-Za-z0-9]+$" }, - "ram": "8" + "ram": "8000000000" } "assets": { "license": "LICENSE", diff --git a/src/Model.hs b/src/Model.hs index 9326e30..0841e06 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -76,8 +76,8 @@ VersionPlatform versionNumber Version ram Int Maybe device PackageDevice Maybe - arch OsArch Maybe - Primary pkgId versionNumber + arch OsArch + Primary pkgId versionNumber arch deriving Eq deriving Show