diff --git a/src/Database/Marketplace.hs b/src/Database/Marketplace.hs index 5463a29..4e3d9d3 100644 --- a/src/Database/Marketplace.hs +++ b/src/Database/Marketplace.hs @@ -15,8 +15,6 @@ import Database.Esqueleto.Experimental , (&&.) , (++.) , (==.) - , Entity(entityKey, entityVal) - , SqlBackend , (^.) , desc , from @@ -31,12 +29,15 @@ import Database.Esqueleto.Experimental , valList , where_ , (||.) + , Value(unValue) ) import Database.Esqueleto.Experimental ( (:&)(..) , table ) -import Lib.Types.AppIndex ( PkgId ) +import Lib.Types.AppIndex ( VersionInfo(..) + , PkgId + ) import Lib.Types.Category import Lib.Types.Emver ( Version , VersionRange @@ -47,6 +48,14 @@ import Startlude hiding ( (%) , on , yield ) +import qualified Data.HashMap.Internal.Strict as HM +import Handler.Types.Marketplace ( ReleaseNotes(ReleaseNotes) ) +import qualified Database.Persist as P +import Database.Persist.Postgresql + hiding ( (||.) + , selectSource + , (==.) + ) searchServices :: (MonadResource m, MonadIO m) => Maybe CategoryTitle @@ -112,3 +121,50 @@ filterOsCompatible :: Monad m filterOsCompatible p = awaitForever $ \(app, versions, requestedVersion) -> do let compatible = filter (p . versionRecordOsVersion . entityVal) versions when (not $ null compatible) $ yield (app, compatible, requestedVersion) + + +fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m ([VersionInfo], ReleaseNotes) +fetchAllAppVersions appConnPool appId = do + entityAppVersions <- runSqlPool (P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []) appConnPool + let vers = entityVal <$> entityAppVersions + let vv = mapSVersionToVersionInfo vers + let mappedVersions = ReleaseNotes $ HM.fromList $ (\v -> (versionInfoVersion v, versionInfoReleaseNotes v)) <$> vv + pure $ (sortOn (Down . versionInfoVersion) vv, mappedVersions) + where + mapSVersionToVersionInfo :: [VersionRecord] -> [VersionInfo] + mapSVersionToVersionInfo sv = do + (\v -> VersionInfo { versionInfoVersion = versionRecordNumber v + , versionInfoReleaseNotes = versionRecordReleaseNotes v + , versionInfoDependencies = HM.empty + , versionInfoOsVersion = versionRecordOsVersion v + , versionInfoInstallAlert = Nothing + } + ) + <$> sv + +fetchLatestApp :: MonadIO m => PkgId -> 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)) + pure (service, version) + where sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd) + + +fetchAppCategories :: MonadIO m => [PkgId] -> ReaderT SqlBackend m (HM.HashMap PkgId [Category]) +fetchAppCategories appIds = do + raw <- select $ do + (sc :& app :& cat) <- + from + $ table @PkgCategory + `innerJoin` table @PkgRecord + `on` (\(sc :& app) -> sc ^. PkgCategoryPkgId ==. app ^. PkgRecordId) + `innerJoin` table @Category + `on` (\(sc :& _ :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId) + where_ (sc ^. PkgCategoryPkgId `in_` valList (PkgRecordKey <$> appIds)) + pure (app ^. PkgRecordId, cat) + let ls = fmap (first (unPkgRecordKey . unValue) . second (pure . entityVal)) raw + pure $ HM.fromListWith (++) ls diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 0da92bc..9e1be6d 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -42,8 +42,6 @@ import Data.Aeson ( (.:) , decode , eitherDecode , eitherDecodeStrict - , object - , withObject ) import qualified Data.Attoparsec.Text as Atto import Data.ByteArray.Encoding ( Base(Base16) @@ -61,28 +59,22 @@ import Data.String.Interpolate.IsString ( i ) import qualified Data.Text as T import Database.Esqueleto.Experimental - ( (:&)((:&)) - , (==.) - , Entity(entityKey, entityVal) + ( Entity(entityKey, entityVal) , SqlBackend - , Value(unValue) , (^.) , desc , from - , in_ - , innerJoin - , on , orderBy , select , table - , val - , valList - , where_ ) import Database.Marketplace ( filterOsCompatible , getPkgData , searchServices , zipVersions + , fetchAllAppVersions + , fetchLatestApp + , fetchAppCategories ) import qualified Database.Persist as P import Database.Persist ( PersistUniqueRead(getBy) @@ -98,7 +90,6 @@ import Lib.PkgRepository ( getManifest ) import Lib.Types.AppIndex ( PkgId(PkgId) , PackageDependency(packageDependencyVersion) , PackageManifest(packageManifestDependencies) - , VersionInfo(..) ) import Lib.Types.AppIndex ( ) import Lib.Types.Category ( CategoryTitle(..) ) @@ -114,7 +105,6 @@ import Model ( Category(..) , EosHash(EosHash, eosHashHash) , Key(PkgRecordKey, unPkgRecordKey) , OsVersion(..) - , PkgCategory , PkgRecord(..) , Unique(UniqueVersion) , VersionRecord(..) @@ -132,8 +122,6 @@ import UnliftIO.Async ( concurrently import UnliftIO.Directory ( listDirectory ) import Util.Shared ( getVersionSpecFromQuery ) import Yesod.Core ( MonadResource - , ToContent(..) - , ToTypedContent(..) , TypedContent , YesodRequest(..) , addHeader @@ -158,115 +146,7 @@ import Database.Persist.Postgresql ( ConnectionPool ) import Control.Monad.Reader.Has ( Has , ask ) - -type URL = Text -newtype CategoryRes = CategoryRes { - categories :: [CategoryTitle] -} deriving (Show, Generic) -instance ToJSON CategoryRes -instance ToContent CategoryRes where - toContent = toContent . toJSON -instance ToTypedContent CategoryRes where - toTypedContent = toTypedContent . toJSON -data PackageRes = PackageRes - { packageResIcon :: URL - , packageResManifest :: Data.Aeson.Value -- PackageManifest - , packageResCategories :: [CategoryTitle] - , packageResInstructions :: URL - , packageResLicense :: URL - , packageResVersions :: [Version] - , packageResDependencies :: HM.HashMap PkgId DependencyRes - } - deriving (Show, Generic) -newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text } - deriving (Eq, Show) -instance ToJSON ReleaseNotes where - toJSON ReleaseNotes {..} = object [ t .= v | (k, v) <- HM.toList unReleaseNotes, let (String t) = toJSON k ] -instance ToContent ReleaseNotes where - toContent = toContent . toJSON -instance ToTypedContent ReleaseNotes where - toTypedContent = toTypedContent . toJSON -instance ToJSON PackageRes where - toJSON PackageRes {..} = object - [ "icon" .= packageResIcon - , "license" .= packageResLicense - , "instructions" .= packageResInstructions - , "manifest" .= packageResManifest - , "categories" .= packageResCategories - , "versions" .= packageResVersions - , "dependency-metadata" .= packageResDependencies - ] -instance FromJSON PackageRes where - parseJSON = withObject "PackageRes" $ \o -> do - packageResIcon <- o .: "icon" - packageResLicense <- o .: "license" - packageResInstructions <- o .: "instructions" - packageResManifest <- o .: "manifest" - packageResCategories <- o .: "categories" - packageResVersions <- o .: "versions" - packageResDependencies <- o .: "dependency-metadata" - pure PackageRes { .. } -data DependencyRes = DependencyRes - { dependencyResTitle :: PkgId - , dependencyResIcon :: URL - } - deriving (Eq, Show) -instance ToJSON DependencyRes where - toJSON DependencyRes {..} = object ["icon" .= dependencyResIcon, "title" .= dependencyResTitle] -instance FromJSON DependencyRes where - parseJSON = withObject "DependencyRes" $ \o -> do - dependencyResIcon <- o .: "icon" - dependencyResTitle <- o .: "title" - pure DependencyRes { .. } -newtype PackageListRes = PackageListRes [PackageRes] - deriving (Generic) -instance ToJSON PackageListRes -instance ToContent PackageListRes where - toContent = toContent . toJSON -instance ToTypedContent PackageListRes where - toTypedContent = toTypedContent . toJSON - -newtype VersionLatestRes = VersionLatestRes (HM.HashMap PkgId (Maybe Version)) - deriving (Show, Generic) -instance ToJSON VersionLatestRes -instance ToContent VersionLatestRes where - toContent = toContent . toJSON -instance ToTypedContent VersionLatestRes where - toTypedContent = toTypedContent . toJSON -data OrderArrangement = ASC | DESC - deriving (Eq, Show, Read) -data PackageListDefaults = PackageListDefaults - { packageListOrder :: OrderArrangement - , packageListPageLimit :: Int -- the number of items per page - , packageListPageNumber :: Int -- the page you are on - , packageListCategory :: Maybe CategoryTitle - , packageListQuery :: Text - } - deriving (Eq, Show, Read) -data EosRes = EosRes - { eosResVersion :: Version - , eosResHeadline :: Text - , eosResReleaseNotes :: ReleaseNotes - } - deriving (Eq, Show, Generic) -instance ToJSON EosRes where - toJSON EosRes {..} = - object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes] -instance ToContent EosRes where - toContent = toContent . toJSON -instance ToTypedContent EosRes where - toTypedContent = toTypedContent . toJSON - -data PackageReq = PackageReq - { packageReqId :: PkgId - , packageReqVersion :: VersionRange - } - deriving Show -instance FromJSON PackageReq where - parseJSON = withObject "package version" $ \o -> do - packageReqId <- o .: "id" - packageReqVersion <- o .: "version" - pure PackageReq { .. } +import Handler.Types.Marketplace getCategoriesR :: Handler CategoryRes getCategoriesR = do @@ -301,7 +181,8 @@ getReleaseNotesR = do case lookup "id" getParameters of Nothing -> sendResponseStatus status400 (InvalidParamsE "get:id" "") Just package -> do - (_, notes) <- fetchAllAppVersions (PkgId package) + appConnPool <- appConnPool <$> getYesod + (_, notes) <- runDB $ fetchAllAppVersions appConnPool (PkgId package) pure notes getEosR :: Handler TypedContent @@ -562,50 +443,3 @@ mapDependencyMetadata domain metadata (appId, depInfo) = do , dependencyResIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|] } ) - -fetchAllAppVersions :: PkgId -> Handler ([VersionInfo], ReleaseNotes) -fetchAllAppVersions appId = do - entityAppVersions <- runDB $ P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] [] - let vers = entityVal <$> entityAppVersions - let vv = mapSVersionToVersionInfo vers - let mappedVersions = ReleaseNotes $ HM.fromList $ (\v -> (versionInfoVersion v, versionInfoReleaseNotes v)) <$> vv - pure (sortOn (Down . versionInfoVersion) vv, mappedVersions) - where - mapSVersionToVersionInfo :: [VersionRecord] -> [VersionInfo] - mapSVersionToVersionInfo sv = do - (\v -> VersionInfo { versionInfoVersion = versionRecordNumber v - , versionInfoReleaseNotes = versionRecordReleaseNotes v - , versionInfoDependencies = HM.empty - , versionInfoOsVersion = versionRecordOsVersion v - , versionInfoInstallAlert = Nothing - } - ) - <$> sv - - -fetchLatestApp :: MonadIO m => PkgId -> 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)) - pure (service, version) - where sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd) - - -fetchAppCategories :: MonadIO m => [PkgId] -> ReaderT SqlBackend m (HM.HashMap PkgId [Category]) -fetchAppCategories appIds = do - raw <- select $ do - (sc :& app :& cat) <- - from - $ table @PkgCategory - `innerJoin` table @PkgRecord - `on` (\(sc :& app) -> sc ^. PkgCategoryPkgId ==. app ^. PkgRecordId) - `innerJoin` table @Category - `on` (\(sc :& _ :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId) - where_ (sc ^. PkgCategoryPkgId `in_` valList (PkgRecordKey <$> appIds)) - pure (app ^. PkgRecordId, cat) - let ls = fmap (first (unPkgRecordKey . unValue) . second (pure . entityVal)) raw - pure $ HM.fromListWith (++) ls diff --git a/src/Handler/Types/Marketplace.hs b/src/Handler/Types/Marketplace.hs new file mode 100644 index 0000000..8aad326 --- /dev/null +++ b/src/Handler/Types/Marketplace.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +module Handler.Types.Marketplace where +import Lib.Types.Category ( CategoryTitle ) +import Data.Aeson +import Startlude +import Yesod +import qualified Data.HashMap.Internal.Strict as HM +import Lib.Types.Emver ( VersionRange + , Version + ) +import Lib.Types.AppIndex ( PkgId ) + + +type URL = Text +newtype CategoryRes = CategoryRes { + categories :: [CategoryTitle] +} deriving (Show, Generic) +instance ToJSON CategoryRes +instance ToContent CategoryRes where + toContent = toContent . toJSON +instance ToTypedContent CategoryRes where + toTypedContent = toTypedContent . toJSON +data PackageRes = PackageRes + { packageResIcon :: URL + , packageResManifest :: Data.Aeson.Value -- PackageManifest + , packageResCategories :: [CategoryTitle] + , packageResInstructions :: URL + , packageResLicense :: URL + , packageResVersions :: [Version] + , packageResDependencies :: HM.HashMap PkgId DependencyRes + } + deriving (Show, Generic) +newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text } + deriving (Eq, Show) +instance ToJSON ReleaseNotes where + toJSON ReleaseNotes {..} = object [ t .= v | (k, v) <- HM.toList unReleaseNotes, let (String t) = toJSON k ] +instance ToContent ReleaseNotes where + toContent = toContent . toJSON +instance ToTypedContent ReleaseNotes where + toTypedContent = toTypedContent . toJSON +instance ToJSON PackageRes where + toJSON PackageRes {..} = object + [ "icon" .= packageResIcon + , "license" .= packageResLicense + , "instructions" .= packageResInstructions + , "manifest" .= packageResManifest + , "categories" .= packageResCategories + , "versions" .= packageResVersions + , "dependency-metadata" .= packageResDependencies + ] +instance FromJSON PackageRes where + parseJSON = withObject "PackageRes" $ \o -> do + packageResIcon <- o .: "icon" + packageResLicense <- o .: "license" + packageResInstructions <- o .: "instructions" + packageResManifest <- o .: "manifest" + packageResCategories <- o .: "categories" + packageResVersions <- o .: "versions" + packageResDependencies <- o .: "dependency-metadata" + pure PackageRes { .. } +data DependencyRes = DependencyRes + { dependencyResTitle :: PkgId + , dependencyResIcon :: URL + } + deriving (Eq, Show) +instance ToJSON DependencyRes where + toJSON DependencyRes {..} = object ["icon" .= dependencyResIcon, "title" .= dependencyResTitle] +instance FromJSON DependencyRes where + parseJSON = withObject "DependencyRes" $ \o -> do + dependencyResIcon <- o .: "icon" + dependencyResTitle <- o .: "title" + pure DependencyRes { .. } +newtype PackageListRes = PackageListRes [PackageRes] + deriving (Generic) +instance ToJSON PackageListRes +instance ToContent PackageListRes where + toContent = toContent . toJSON +instance ToTypedContent PackageListRes where + toTypedContent = toTypedContent . toJSON + +newtype VersionLatestRes = VersionLatestRes (HM.HashMap PkgId (Maybe Version)) + deriving (Show, Generic) +instance ToJSON VersionLatestRes +instance ToContent VersionLatestRes where + toContent = toContent . toJSON +instance ToTypedContent VersionLatestRes where + toTypedContent = toTypedContent . toJSON +data OrderArrangement = ASC | DESC + deriving (Eq, Show, Read) +data PackageListDefaults = PackageListDefaults + { packageListOrder :: OrderArrangement + , packageListPageLimit :: Int -- the number of items per page + , packageListPageNumber :: Int -- the page you are on + , packageListCategory :: Maybe CategoryTitle + , packageListQuery :: Text + } + deriving (Eq, Show, Read) +data EosRes = EosRes + { eosResVersion :: Version + , eosResHeadline :: Text + , eosResReleaseNotes :: ReleaseNotes + } + deriving (Eq, Show, Generic) +instance ToJSON EosRes where + toJSON EosRes {..} = + object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes] +instance ToContent EosRes where + toContent = toContent . toJSON +instance ToTypedContent EosRes where + toTypedContent = toTypedContent . toJSON + +data PackageReq = PackageReq + { packageReqId :: PkgId + , packageReqVersion :: VersionRange + } + deriving Show +instance FromJSON PackageReq where + parseJSON = withObject "package version" $ \o -> do + packageReqId <- o .: "id" + packageReqVersion <- o .: "version" + pure PackageReq { .. } diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index e826228..185a127 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -143,6 +143,7 @@ getBestVersion :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) -> m (Maybe Version) getBestVersion pkg spec = headMay . sortOn Down <$> getViableVersions pkg spec +-- TODO add loadDependencies -- extract all package assets into their own respective files extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => FilePath -> m () extractPkg fp = handle @_ @SomeException cleanup $ do @@ -193,7 +194,8 @@ watchPkgRepoRoot = do stop <- watchTree watchManager root onlyAdded $ \evt -> do let pkg = eventPath evt -- TODO: validate that package path is an actual s9pk and is in a correctly conforming path. - void . forkIO $ runInIO (extractPkg pkg) + void . forkIO $ runInIO $ do + (extractPkg pkg) takeMVar box stop pure $ tryPutMVar box () diff --git a/test/Handler/AppSpec.hs b/test/Handler/AppSpec.hs index b3431d6..b798a09 100644 --- a/test/Handler/AppSpec.hs +++ b/test/Handler/AppSpec.hs @@ -17,7 +17,7 @@ import Seed import Lib.Types.AppIndex import Data.Aeson import Data.Either.Extra -import Handler.Marketplace ( PackageListRes ) +import Handler.Marketplace ( PackageRes ) spec :: Spec spec = do @@ -27,7 +27,7 @@ spec = do setMethod "GET" setUrl ("/package/index" :: Text) statusIs 200 - (res :: PackageListRes) <- requireJSONResponse + (res :: [PackageRes]) <- requireJSONResponse assertEq "response should have two packages" (length res) 3 describe "GET /package/index?ids" $ withApp $ it "returns list of packages at specified version" $ do _ <- seedBitcoinLndStack @@ -35,7 +35,7 @@ spec = do setMethod "GET" setUrl ("/package/index?ids=[{\"id\":\"bitcoind\",\"version\":\"=0.21.1.2\"}]" :: Text) statusIs 200 - (res :: PackageListRes) <- requireJSONResponse + (res :: [PackageRes]) <- requireJSONResponse assertEq "response should have one package" (length res) 1 let pkg = fromJust $ head res let (manifest :: PackageManifest) = fromRight' $ eitherDecode $ encode $ packageResManifest pkg @@ -49,17 +49,17 @@ spec = do setMethod "GET" setUrl ("/package/index?ids=[{\"id\":\"lnd\",\"version\":\"=0.13.3.1\"}]" :: Text) statusIs 200 - (res :: PackageListRes) <- requireJSONResponse + (res :: [PackageRes]) <- requireJSONResponse assertEq "response should have one package" (length res) 1 let pkg = fromJust $ head res - assertEq "package dependency metadata should not be empty" (null $ packageResDependencyInfo pkg) False + assertEq "package dependency metadata should not be empty" (null $ packageResDependencies pkg) False describe "GET /package/index?ids" $ withApp $ it "returns list of packages at exactly specified version" $ do _ <- seedBitcoinLndStack request $ do setMethod "GET" setUrl ("/package/index?ids=[{\"id\":\"bitcoind\",\"version\":\"=0.21.1.1\"}]" :: Text) statusIs 200 - (res :: PackageListRes) <- requireJSONResponse + (res :: [PackageRes]) <- requireJSONResponse assertEq "response should have one package" (length res) 1 let pkg = fromJust $ head res let (manifest :: PackageManifest) = fromRight' $ eitherDecode $ encode $ packageResManifest pkg @@ -70,7 +70,7 @@ spec = do setMethod "GET" setUrl ("/package/index?ids=[{\"id\":\"bitcoind\",\"version\":\">=0.21.1.1\"}]" :: Text) statusIs 200 - (res :: PackageListRes) <- requireJSONResponse + (res :: [PackageRes]) <- requireJSONResponse assertEq "response should have one package" (length res) 1 let pkg = fromJust $ head res let (manifest :: PackageManifest) = fromRight' $ eitherDecode $ encode $ packageResManifest pkg @@ -81,7 +81,7 @@ spec = do setMethod "GET" setUrl ("/package/index?ids=[{\"id\":\"bitcoind\",\"version\":\">=0.21.1.2\"}]" :: Text) statusIs 200 - (res :: PackageListRes) <- requireJSONResponse + (res :: [PackageRes]) <- requireJSONResponse assertEq "response should have one package" (length res) 1 let pkg = fromJust $ head res let (manifest :: PackageManifest) = fromRight' $ eitherDecode $ encode $ packageResManifest pkg