fix hanging issue and other dataset consistency issues

package.yaml

@@ -42,6 +42,7 @@ dependencies:
   - monad-logger
   - monad-logger-extras
   - monad-loops
+  - multimap
   - network-uri
   - optparse-applicative
   - parallel

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

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]}

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

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)

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

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",

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